%INCLUDE "ercc10:OPOUTS" %CONSTINTEGER ISUB=x'5B',IADD=x'5a',LGR=x'58',AND=x'54',ICP=x'59'; ! variant mnemonics %INCLUDE "ercs20:ib11.specs" %EXTERNALROUTINE ICL9CEZALGOL %INTEGER I,J,K ! PRODUCED BY OLDPS FROM S4ALGPS ON 29/08/85 %CONSTBYTEINTEGERARRAY CLETT(0:252)= 1, 44, 1, 43, 1, 45, 1, 40, 1, 41, 2, 201, 198, 4, 212, 200, 197, 206, 4, 197, 204, 211, 197, 1, 94, 2, 42, 42, 1, 42, 1, 47, 3, 196, 201, 214, 4, 212, 210, 213, 197, 5, 198, 193, 204, 211, 197, 3, 193, 206, 196, 2, 207, 210, 4, 201, 205, 208, 204, 5, 197, 209, 213, 201, 214, 3, 206, 207, 212, 7, 201, 206, 212, 197, 199, 197, 210, 4, 210, 197, 193, 204, 7, 194, 207, 207, 204, 197, 193, 206, 1, 59, 5, 214, 193, 204, 213, 197, 5, 204, 193, 194, 197, 204, 6, 211, 215, 201, 212, 195, 200, 6, 211, 212, 210, 201, 206, 199, 5, 193, 210, 210, 193, 217, 9, 208, 210, 207, 195, 197, 196, 213, 210, 197, 2, 58, 40, 7, 195, 207, 205, 205, 197, 206, 212, 1, 58, 2, 58, 61, 4, 211, 212, 197, 208, 5, 213, 206, 212, 201, 204, 5, 215, 200, 201, 204, 197, 1, 61, 2, 62, 61, 1, 62, 1, 35, 2, 60, 61, 1, 60, 2, 92, 61, 3, 198, 207, 210, 2, 196, 207, 5, 194, 197, 199, 201, 206, 8, 197, 216, 212, 197, 210, 206, 193, 204, 5, 193, 204, 199, 207, 204, 4, 199, 207, 212, 207, 3, 197, 206, 196, 3, 207, 215, 206, 6, 195, 207, 196, 197, 207, 206, 7, 195, 207, 196, 197, 207, 198, 198, 7, 211, 208, 197, 195, 201, 193, 204, 4, 206, 193, 205, 197 %CONSTINTEGERARRAY SYMBOL(1300:2012)= 1305, 1305, 1001, 1018, 1305, 1313, 1311, 0, 1001, 1018, 1305, 1313, 1000, 1320, 1316, 2, 1318, 4, 1320, 1000, 1330, 1324, 1001, 1355, 1326, 1003, 1330, 6, 1330, 8, 1348, 1342, 10, 1439, 13, 1010, 1313, 1320, 1011, 1348, 18, 1330, 1348, 1010, 1313, 1320, 1011, 1348, 1355, 1353, 1393, 1320, 1348, 1355, 1000, 1371, 1362, 1030, 1038, 1330, 1371, 1039, 1369, 6, 1010, 1648, 1011, 1664, 8, 1371, 1000, 1378, 1376, 0, 1330, 1371, 1378, 1000, 1393, 1384, 1038, 1330, 1371, 1039, 1391, 6, 1010, 1648, 1011, 1664, 8, 1393, 1000, 1408, 1396, 23, 1398, 25, 1400, 2, 1402, 4, 1404, 28, 1406, 30, 1408, 32, 1413, 1411, 36, 1413, 41, 1422, 1416, 47, 1418, 51, 1420, 54, 1422, 59, 1428, 1426, 65, 1449, 1428, 1449, 1432, 1432, 1422, 1432, 1439, 1437, 1413, 1422, 1432, 1439, 1000, 1449, 1447, 10, 1439, 13, 1428, 18, 1439, 1449, 1428, 1463, 1454, 1330, 1797, 1330, 1457, 1001, 1355, 1459, 1408, 1463, 6, 1439, 8, 1470, 1466, 69, 1468, 77, 1470, 82, 1479, 1473, 69, 1475, 77, 1477, 82, 1479, 1000, 1488, 1486, 90, 1538, 92, 1012, 1013, 1488, 1000, 1516, 1493, 98, 1026, 1300, 1497, 104, 1027, 1300, 1501, 111, 1028, 1300, 1506, 1470, 118, 1021, 1300, 1512, 1470, 124, 1022, 1300, 1555, 1516, 1463, 1017, 1300, 1524, 1522, 6, 1001, 1524, 8, 1524, 1000, 1531, 1529, 1531, 1001, 1524, 1531, 1000, 1538, 1534, 0, 1538, 8, 1014, 134, 1546, 1544, 137, 1005, 1013, 1538, 1546, 1000, 1555, 1553, 90, 1538, 1488, 1013, 1546, 1555, 1000, 1570, 1568, 90, 137, 1010, 6, 1001, 1524, 8, 1575, 1582, 1011, 1013, 1570, 1000, 1575, 1573, 145, 1575, 1000, 1582, 1580, 1570, 92, 1012, 1582, 1000, 1589, 1587, 1570, 1589, 1582, 1589, 1000, 1610, 1593, 98, 1610, 1596, 104, 1610, 1599, 111, 1610, 1603, 1470, 118, 1610, 1607, 1470, 124, 1610, 1610, 1463, 1610, 1614, 1614, 1001, 1614, 1621, 1619, 0, 1001, 1614, 1621, 1000, 1629, 1625, 1001, 1378, 1629, 6, 1629, 8, 1639, 1637, 10, 1439, 13, 1621, 18, 1629, 1639, 1621, 1648, 1646, 0, 1010, 1629, 1011, 1639, 1648, 1000, 1664, 1651, 1008, 1655, 1001, 1355, 1035, 1658, 1330, 1035, 1661, 1439, 1035, 1664, 1629, 1035, 1673, 1671, 1531, 1010, 1648, 1011, 1664, 1673, 1000, 1686, 1680, 1020, 1355, 147, 1686, 1439, 1686, 1019, 1355, 147, 1696, 1330, 1696, 1694, 1025, 1004, 1020, 1355, 147, 1686, 1696, 1000, 1706, 1704, 1025, 1004, 1019, 1355, 147, 1696, 1706, 1000, 1717, 1712, 150, 1330, 155, 1330, 1715, 161, 1439, 1717, 1000, 1725, 1723, 0, 1330, 1706, 1717, 1725, 1000, 1734, 1732, 0, 1330, 145, 1330, 1725, 1734, 1000, 1744, 1739, 1463, 1017, 1300, 1744, 1470, 118, 1021, 1786, 1749, 1749, 1300, 1755, 1749, 1755, 1753, 0, 1744, 1755, 1000, 1765, 1758, 1765, 1765, 1038, 1330, 145, 1330, 1725, 1039, 1775, 1775, 1038, 1313, 1002, 145, 1313, 1002, 1775, 1039, 1786, 1784, 0, 1313, 1002, 145, 1313, 1002, 1775, 1786, 1000, 1791, 1791, 1300, 1765, 1791, 1797, 1795, 0, 1786, 1797, 1000, 1812, 1800, 167, 1802, 169, 1804, 172, 1806, 174, 1808, 176, 1810, 179, 1812, 181, 1821, 1819, 1029, 1001, 145, 1034, 1812, 1821, 1000, 1833, 1824, 1918, 1827, 184, 1833, 1833, 10, 1439, 13, 1812, 1874, 1846, 1846, 1010, 1004, 1355, 147, 1330, 1706, 1011, 1717, 188, 1812, 1868, 1860, 1849, 1918, 1852, 184, 1833, 1858, 10, 1439, 13, 1812, 1874, 1860, 1000, 1868, 1866, 1538, 1812, 1821, 1036, 1868, 1015, 1874, 1872, 191, 1015, 1874, 1846, 1886, 1878, 191, 1860, 1881, 184, 1833, 1884, 1918, 1905, 1886, 1905, 1900, 1891, 197, 1900, 1016, 1895, 206, 1900, 1016, 1897, 191, 1900, 1037, 1846, 1905, 1903, 1001, 1905, 1000, 1912, 1910, 18, 1812, 1912, 1912, 1000, 1918, 1916, 191, 1860, 1918, 1846, 1929, 1923, 1025, 1004, 1673, 1926, 1001, 1355, 1929, 212, 1629, 2013, 1933, 1821, 1006, 1939, 217, 1016, 1007, 1905, 1006, 1958, 1470, 124, 1022, 1033, 1010, 1001, 1018, 1516, 1015, 1479, 1546, 90, 1538, 1013, 1011, 1812, 1886, 1006, 1965, 1470, 118, 1021, 1024, 1744, 1006, 1971, 1463, 1017, 1023, 1300, 1006, 1974, 191, 1015, 1986, 104, 1027, 1001, 1018, 1031, 147, 1010, 1629, 1011, 1639, 1006, 1991, 221, 1032, 1734, 1006, 1997, 1029, 1001, 145, 1034, 1929, 2000, 137, 1005, 2003, 225, 1006, 2006, 232, 1006, 2011, 240, 248, 1001, 1006, 2013, 90 %CONSTINTEGER SS= 1929 %CONSTINTEGER RELEASE=1 %CONSTSTRING (9) LADATE="20Aug85" %STRING (63) HD %OWNSHORTINTEGERARRAY SNNNO(0:53) %CONSTBYTEINTEGERARRAY TSNAME(0:52)=2,1(4),2(8),1,2,0(10),1,2, 0(6),1,0,0,2,0(3),1, 1,0,0,3,0(3),1,1,0,0,0 NEWLINES(3); SPACES(5) HD="ERCC ALGOL 60 COMPILER RELEASE ".TOSTRING(RELEASE+'0')."VERSION ".LADATE PRINTSTRING(HD) NEWLINES(3) %CONSTBYTEINTEGERARRAY BYTES(1:4)=4,8,4,8 %CONSTSHORTINTEGERARRAY HOPCODE(1:7)=0,16,0(5); %OWNINTEGERARRAY FIXED GLA(0:13)=m'AGLA',0, {reserved&hd of code} 0(2), {glast addr & sst addr} 5<<24!RELEASE<<16,0{langflag & addr diag tables}, 0,0, {reserved for ctable addr & top of stack pointer} 0(2), {two work words for array dec subroutines} 0(3),x'00040010' {mdaigs ref} %CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48), 1(10),0(7),2(26),0(6),2(26),0(5),0(128) %OWNSHORTINTEGER MAXLEVELS=31 %CONSTBYTEINTEGERARRAY GRMAP(0:16)=0,1,2,3,15,16,18,20,22, 4,5,6,7,8,9,10,14 %CONSTSTRING (4) MAINEP="S#GO" %CONSTSTRING (8) MDEP="S#nDIAG" %CONSTSTRING (11) STKTOP="EMAS3TOPSTK" %CONSTSHORTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE %CONSTINTEGER CODER=12 %CONSTINTEGER WSPR=11 %CONSTINTEGER GLAREG=13 %CONSTINTEGER EPREG=14 ! THE FOLLOWING FUNNY WORDS ARE CYCLE CONTROL WORDS FOR SEARCHING THE ! LIST OF FREE REGISTERS. THE TOP HALF IS INC(SIGNED) AND THE BOTTOM ! TWO BYTES ARE START AND FINISH RESPECTIVELY %CONSTINTEGER GR0=X'1010F'; ! 1,1,15 %CONSTINTEGER GR1=X'1010F'; ! 1,1,15 %CONSTINTEGER FR0=X'FFFE1610'; ! 6,-2,0 %CONSTINTEGER ADDREG=X'FFFF0E01'; ! 14,-1,1 %SHORTINTEGER CCSIZE,DSIZE,CONSTL1,CONSTL4,CONSTL8 %SHORTINTEGER SAVEFPS,FPHEAD,LEVELINF %INTEGER ASL,NNAMES,ARSIZE,DTPTR,PPCURR,PTLAST,OLDLINE,LINE,LENGTH,NEXTP,N0,NUM,SNUM,RLEVEL, NMAX,CONSTPTR,PRIVLABEL,LEVEL,CA,RR,TYPE,LASTNAME,FPNAME,FPCOUNT,FPPTR,DECMADE %BYTEINTEGER FAULTY,MONE,HIT,INHCODE,PERM,TTOPUT,LIST,ADFLAG,LINENOS,DIAGS1,CHECKSP, CTYPE,DCOMP,BFFLAG,CPRMODE,UNASS,FFLAG,CHECKS,QFLAG,SMAP %LONGREAL CVALUE,IMAX,CTIME %INTEGER MASK,RBASE,MARGIN,NEXT,N,ITEM,LOGEPDISP,EXPEPDISP,P,Q,R,S,T,U,V,NEST,FNAME,LDPTR, GLACA,CCSTATE,SSTL,QMAX,STMTS,LASTAT,FILE ADDR,FILE PTR,FILE END,FILE SIZE,LASTEND, UNASSPAT,GLABEL,GRATCNT %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP"(%INTEGER N) %BEGIN FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN %IF FILE ADDR#0 %THENSTART 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(28)&X'100' {maxdict}#0 %THEN FILE SIZE=64*4096 ARSIZE=2*FILESIZE+4096 NNAMES=511 %IF FILESIZE>32000 %THEN NNAMES=1023 ASL=32*NNAMES ASL=32760 %IF ASL>32760; ! MAX FOR 16BIT LINKS ASL=ASL&X'FFFFFFF0' DSIZE=6*NNAMES %END %INTEGERARRAY REGISTER,GRUSE,GRAT,GRINF(0:22) %INTEGERARRAY SET,STACKBASE,RAL,FLAG,L,M,NMDECS(0:MAXLEVELS) %SHORTINTEGERARRAY AVL WSP(1:4,0:MAXLEVELS) %SHORTINTEGERARRAY CYCLE,JUMP,NAME,LABEL,JROUND,DHEADS(0:MAXLEVELS) %INTEGERARRAY PLABS(0:15) %BYTEINTEGERARRAYFORMAT CCF(0:FILESIZE+7) %BYTEINTEGERARRAYNAME CC %BYTEINTEGERARRAYFORMAT AF(-2:ARSIZE) %BYTEINTEGERARRAYNAME A %BYTEINTEGERARRAY ASLIST(0:ASL+32),LETT(0:DSIZE+20) %SHORTINTEGERARRAY WORD,TAGS(0:NNAMES) %INTEGERARRAY NTYPE(0:NNAMES) %ROUTINESPEC CNOP(%INTEGER I,J) %ROUTINESPEC PCONST(%INTEGER X) %ROUTINESPEC PSI(%INTEGER OPCODE,J,BASE,DISP) %ROUTINESPEC PSS(%INTEGER OPCODE,N,BASE,DISP,P,Q) !%ROUTINESPEC LIST PRG %ROUTINESPEC PLANT(%INTEGER VALUE) %ROUTINESPEC PRR(%INTEGER OPCODE,R1,R2) %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %ROUTINESPEC COMPARE %ROUTINESPEC PNAME(%INTEGER MODE) %ROUTINESPEC CONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT %LONGREALFNSPEC FROMAR8(%INTEGER PTR) %INTEGERFNSPEC FROMAR4(%INTEGER PTR) %INTEGERFNSPEC FROMAR2(%INTEGER PTR) %ROUTINESPEC TOAR8(%INTEGER PTR, %LONGREAL VALUE) %ROUTINESPEC TOAR4(%INTEGER PTR,VALUE) %ROUTINESPEC TOAR2(%INTEGER PTR,VALUE) %ROUTINESPEC RECODE %ROUTINESPEC PRINT USE %ROUTINESPEC PROLOGUE %ROUTINESPEC EPILOGUE %ROUTINESPEC CSS(%INTEGER P) %ROUTINESPEC ABORT %ROUTINESPEC WARN(%INTEGER N,V) %ROUTINESPEC FAULT(%INTEGER N,VALUE) %ROUTINESPEC FINALISE %ROUTINESPEC PRINT NAME(%INTEGER N) %INTEGERFNSPEC NEWCELL %ROUTINESPEC INSERTATEND(%SHORTINTEGERNAME S, %INTEGER A,B,C) %ROUTINESPEC CHECK ASL %ROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1,S2) %ROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1,S2,S3) %ROUTINESPEC POP(%SHORTINTEGERNAME CELL, %INTEGERNAME S1,S2) %ROUTINESPEC POP123(%SHORTINTEGERNAME C, %INTEGERNAME P,Q,R) %ROUTINESPEC PUSH(%SHORTINTEGERNAME CELL, %INTEGER S1,S2) %ROUTINESPEC PUSH123(%SHORTINTEGERNAME 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) %ROUTINESPEC READ PRG %ONEVENT 9 %START; ->INEND; %FINISH ! START OF COMPILATION CC==ARRAY(COMREG(14)+INTEGER(COMREG(14)+4),CCF) A==ARRAY(ADDR(CC(0))+4096,AF) %BEGIN %CONSTBYTEINTEGERARRAY ILETT(0:422)=3, 'A','B','S', 4,'I','A','B','S', 4,'S','I','G','N', 6,'E','N','T','I','E','R', 5,'R','O','U','N','D', 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', 8,'I','N','S','Y','M','B','O','L', 9,'O','U','T','S','Y','M','B','O','L', 6,'I','N','R','E','A','L', 7,'O','U','T','R','E','A','L', 9,'I','N','I','N','T','E','G','E','R', 13,'O','U','T','T','E','R','M','I','N','A','T','O','R', 10,'O','U','T','I','N','T','E','G','E','R', 9,'O','U','T','S','T','R','I','N','G', 6,'L','E','N','G','T','H', 7,'C','P','U','T','I','M','E', 11,'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E','C','T','O','U','T','P','U','T', 7,'N','E','W','L','I','N','E', 5,'S','P','A','C','E', 8,'N','E','W','L','I','N','E','S', 6,'S','P','A','C','E','S', 10,'N','E','X','T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M','B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L', 4,'R','E','A','D', 7,'N','E','W','P','A','G','E', 5,'P','R','I','N','T', 11,'P','R','I','N','T','S','T','R','I','N','G', 4,'C','O','D','E', 8,'R','E','A','D','1','9','0','0', 9,'P','R','I','N','T','1','9','0','0', 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', 6,'R','E','A','D','C','H', 6,'N','E','X','T','C','H', 7,'P','R','I','N','T','C','H', 6,'S','K','I','P','C','H', 7,'M','O','N','I','T','O','R', 255 %CONSTBYTEINTEGERARRAY ITYPE(1:53)=130, 129(4),130(8),129,130,128(10),129,130, 128(6),129,128(2),130,128(3),129, 130,128(2),131,128(3),129(2),128(3) %INTEGER I,J,LL DTPTR=0; PPCURR=0; OLDLINE=0 LINE=0; RLEVEL=0; NMAX=0; CONSTPTR=0 LEVEL=0; CA=0; FFLAG=0; LASTAT=0 FAULTY=0; PERM=0; ADFLAG=0 DCOMP=0; BFFLAG=0; CPRMODE=0 NEXT=1; LDPTR=0; FPNAME=0; FPHEAD=0 FPCOUNT=0; FPPTR=0; SAVEFPS=0 RBASE=10; LOGEPDISP=0; EXPEPDISP=0 CONSTL1=0; CONSTL4=0; CONSTL8=0 IMAX=(-1)>>1; PRIVLABEL=24999; GLABEL=x'7fff' SSTL=0; STMTS=1; SNUM=0 LETT(0)=0 N0=14; N=12 GLACA=N0<<2; CCSTATE=-1 CHECKSP=1; CHECKS=1 LINENOS=1; DIAGS1=1; INHCODE=0; MONE=1 LIST=1; MARGIN=1024; UNASS=1 LEVELINF=0 I=COMREG(27) QFLAG=I&1 QFLAG=1; ! force to quotes pro tem SMAP=I>>7&1 LIST=0 %IF I&2#0 LINENOS=0 %IF I&4#0 UNASS=0 %IF I&16#0 CHECKS=0 %IF I&32#0 DCOMP=I>>14&1 TTOPUT=COMREG(40) DIAGS1=0 %IF I&64#0 %IF I&(1<<16)#0 %THENSTART CHECKS=0; CHECKSP=0 LINENOS=0; UNASS=0 %FINISH %CYCLE I=0,1,MAXLEVELS SET(I)=0; STACKBASE(I)=0; RAL(I)=0 CYCLE(I)=0; JUMP(I)=0; NAME(I)=0 LABEL(I)=0; FLAG(I)=0; JROUND(I)=0; DHEADS(I)=0 L(I)=0; M(I)=0 %CYCLE J=1,1,4 AVL WSP(J,I)=0 %REPEAT %REPEAT %CYCLE I=0,1,22 REGISTER(I)=0; GRUSE(I)=0 GRAT(I)=0; GRINF(I)=0 %REPEAT GRATCNT=1 REGISTER(11)=-1; REGISTER(12)=-1; REGISTER(13)=-1 %CYCLE I=0,1,NNAMES WORD(I)=0; TAGS(I)=0; NTYPE(I)=0 %REPEAT ! THIS WAS %ROUTINE SET UP LIST %CYCLE I=0,16,ASL-16 SHORT INTEGER(ADDR(ASLIST(I))+30)=I %REPEAT INTEGER(ADDR(ASLIST(0)))=-1 INTEGER(ADDR(ASLIST(4)))=-1 INTEGER(ADDR(ASLIST(8)))=-1 INTEGER(ADDR(ASLIST(12)))=X'FFFF0000' ! THIS WAS %END; ! OF ROUTINE SET UP LIST 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 SNNNO(LL)=LASTNAME LL=LL+1 K=K+I+1 I=ILETT(K) %REPEAT; ! AND COMPILED SNUM=LL-1 LASTAT=-2 %END PINITIALISE(-1,RELEASE,ADDR(HD)) 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))+24*4096 %IF J>I %THEN I=J %ELSE I=(I+7)&(-8) A==ARRAY(I,AF) ARSIZE=ADDR(CC(0))+(8*16*4096-1024)-I Q=1; QMAX=1; LINE=0 %CYCLE R=0,1,31 A(R)=0 %REPEAT STACKBASE(1)=20; ! LINK FOR GLOBAL PROCS R=32; LEVEL=1 LABEL5:P=SS LINE=LINE+1 RR=R; TOAR2(R+2,LINE) R=R+4 COMPARE FAULT(102,0) %IF R>ARSIZE ->LABEL6 %IF HIT=0 TOAR2(RR,R-RR) %IF LEVEL=0 %THEN FAULT(14,0) %AND ->LABEL7 LABEL9:->LABEL7 %IF Q>=LENGTH-6; ->LABEL5 LABEL6:FAULT(100,0) R=RR ->LABEL9 LABEL7: !DEAL WITH END OF PROGRAM TOAR4(R,0); R=R+4 %IF LEVEL>1 %THEN FAULT(15,0) I=0 NEWLINE PRINTCH(13) %IF FAULTY=0 %THENSTART WRITE(LINE,5) PRINT STRING(" STATEMENTS ANALYSED:- SIZE=") WRITE(R,5) NEWLINE %FINISHELSESTART PRINTSTRING(" CODE GENERATION NOT ATTEMPTED") COMREG(24)=8 COMREG(47)=FAULTY %RETURN %FINISH NEXTP=32 PROLOGUE NEXTP=32 LEVEL=1; RLEVEL=1; RBASE=10 %CYCLE I=NEXTP NEXTP=NEXTP+FROMAR2(NEXTP) LINE=FROMAR2(I+2) %EXITIF LINE=0 CSS(I+4) RECODE %IF DCOMP#0 %REPEAT EPILOGUE RECODE %IF DCOMP#0 FINALISE %RETURN %ROUTINE FINALISE !*********************************************************************** !* PASS INFORMATION TO PUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %STRING (15) S %INTEGER JJ,KK,XTRA GLACA=(GLACA+7)&(-8) CONSTPTR=(CONSTPTR+7)&(-8) CNOP(0,8) FIXED GLA(4)=3 {algol}<<24!RELEASE<<16 %IF INHCODE=0 %THENSTART PDBYTES(2,0,N0<<2,ADDR(FIXED GLA(0))); ! FRONT OF GLAP I=X'E2E2E2E2' PD4(6,DTPTR,I) ! PFIX(2,4,1,0); ! relocate word 1 of gla to hd of code PFIX(2,8,5,0); ! relocate word 2 of gla to glast PFIX(2,12,4,0); ! RELOCATE WORD 3 OF GLA TO SST PFIX(2,20,6,0); ! relocate word 5 of gla to diagtables S=STKTOP PDXREF(4,2,28,S); ! DEFINE TOPOFSTORE WORD %FINISH DTPTR=(DTPTR+11)&(-8) SSTL=(SSTL+7)&(-8) %CYCLE I=0,1,10 REGISTER(I)=0 %REPEAT REGISTER(1)=GLACA REGISTER(3)=SSTL REGISTER(4)=CONSTPTR REGISTER(5)=DTPTR %IF INHCODE=0 %THEN faulty=PTERMINATE(ADDR(REGISTER(0)),PTLAST) CA=REGISTER(0); ! code size returned by pterminate PRINTSTRING(" CODE") WRITE(CA,6); PRINTSTRING(" BYTES GLAP") WRITE(GLACA,3); PRINTSTRING("+") WRITE(CONSTPTR,1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(SSTL+DTPTR,3); PRINTSTRING(" BYTES TOTAL") K=CA+GLACA+SSTL+DTPTR+CONSTPTR; REGISTER(5)=K WRITE(K,5); PRINTSTRING(" BYTES") NEWLINE; PRINT CH(13); ! MARKER FOR COMP TO PRINT !SUMMARY %IF FAULTY=0 %THENSTART WRITE(STMTS,7); PRINTSTRING(" STATEMENTS COMPILED") %FINISHELSESTART PRINTSTRING("PROGRAM CONTAINS"); WRITE(FAULTY,2) PRINTSTRING(" FAULTS") STMTS=FAULTY %FINISH NEWLINES(2) I=0; I=8 %IF FAULTY#0 COMREG(24)=I COMREG(47)=STMTS %END %ROUTINE READ PRG %ROUTINESPEC GET LINE %INTEGER DEL %BYTEINTEGERARRAY TLINE(0:161) %CONSTBYTEINTEGERARRAY QSYM(1:78)=' ', '/','<','>','(',')','-',' ', 'E','Q','L','T','L','E','G','T','G','E','N','E', '1','0','*','*',' ', ' ', 'L','E','S','S',' ', 'P','O','W','E','R','E','Q','U','A','L',' ', ' ', 'G','R','E','A','T','E','R','N','O','T','L','E','S','S',' ', 'N','O','T','E','Q','U','A','L',' ', ' ', 'N','O','T','G','R','E','A','T','E','R' ! ***1900 OR D.I.N. REPRESENTATIONS %CONSTBYTEINTEGERARRAY STARTPOS(1:10)=1,8,25,26,31,42,43,58,67,68 ! ***POINTER TO START OF BLOCK IN QSYM FOR EACH POSSIBLE LENGTH %CONSTBYTEINTEGERARRAY ULINED(0:127)= %C X'00',X'01',X'02',X'03',X'04',X'05',X'06',X'07', X'08',X'09',X'0A',X'0B',X'0C',X'0D',X'0C',X'0F', X'10',X'11',X'12',X'13',X'14',X'15',X'16',X'17', X'18',X'19',X'1A',X'1B',X'1C',X'1D',X'1C',X'1F', X'20',X'21',X'22',X'23',X'24',X'25',X'26',X'27', X'28',X'29',X'2A',X'2B',X'2C',X'2D',X'2C',X'2F', X'30',X'31',X'32',X'33',X'34',X'35',X'36',X'37', X'38',X'39',X'3A',X'3B',X'3C',X'3D',X'3C',X'3F', X'40',X'C1',X'C2',X'C3',X'C4',X'C5',X'C6',X'C7', X'C8',X'C9',X'CA',X'CB',X'CC',X'CD',X'CE',X'CF', X'D0',X'D1',X'D2',X'D3',X'D4',X'D5',X'D6',X'D7', X'D8',X'D9',X'DA',X'5B',X'5C',X'5D',X'5E',X'5F', X'60',X'C1',X'C2',X'C3',X'C4',X'C5',X'C6',X'C7', X'C8',X'C9',X'CA',X'CB',X'CC',X'CD',X'CE',X'CF', X'D0',X'D1',X'D2',X'D3',X'D4',X'D5',X'D6',X'D7', X'D8',X'D9',X'DA',X'7B',X'7C',X'7D',X'7E',X'7F' %CONSTBYTEINTEGERARRAY BASSYM(1:84)=0,X'C4',X'C9',X'D6', 0,0,0,'[', 0,0,0,']', 0,0,0,123, 0,0,0,125, 0,0,0,'_', 0,0,0,'=', 0,0,0,'<', 0,0,'<','=', 0,0,0,'>', 0,0,'>','=', 0,0,0,'#', 0,0,0,'&', 0,0,'*','*', 0,0,0,'<', 0,0,'*','*', 0,0,0,'=', 0,0,0,'>', 0,0,'>','=', 0,0,0,'#', 0,0,'<','=' ! ***ALGOL BASIC SYMBOL EQUIVALENTS OF QSYM(1ST LINE=%DIV) %CONSTBYTEINTEGERARRAY BASPTR(1:10)=1,25,25,53,57,57,65,73,73,77 ! ***EQIVALENT POINTERS TO STARTPOS %CONSTBYTEINTEGER MAXSIZE=25 %BYTEINTEGERARRAY WORD(1:MAXSIZE+1) %BYTEINTEGER SIZE,POSN,MATCH,COUNT,LETTERFLAG %INTEGER LL,LP LL=0; LP=0 LENGTH=-4; DEL=0 %IF LIST#0 %THEN PRINTSTRING(" LINE STMNT ") LABEL2:LP=LP+1 %IF LP>LL %THEN GET LINE %AND LP=1 I=TLINE(LP) %IF QFLAG#0 %AND I='''' %START ! ***QFLAG=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) %EXITIF I=''''; ! ***END OF QUOTED WORD %IF I#' ' %AND I#NL %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 %EXITIF SIZE>MAXSIZE %FINISH %REPEAT %IF 0LABEL2 %FINISH POSN=POSN+SIZE; ! ***NEXT WORD FOR COMPARISON COUNT=COUNT+1 %MONITORANDSTOPIF COUNT>20 %REPEAT %FINISH %IF LETTERFLAG=1 %AND SIZE#0 %START !! ***ASSUME TO BE KEYWORD %CYCLE I=1,1,SIZE LENGTH=LENGTH+1 CC(LENGTH+4)=ULINED(WORD(I)) %REPEAT %FINISHELSESTART; ! ***PUT WORD INTO CC AS IT STANDS LENGTH=LENGTH+1 CC(LENGTH+4)='''' %IF SIZE#0 %START %CYCLE I=1,1,SIZE LENGTH=LENGTH+1 CC(LENGTH+4)=WORD(I) %IF WORD(I)=';' %THEN STMTS=STMTS+1 %REPEAT %FINISH %UNLESS SIZE>MAXSIZE %THEN LP=LP-1 %AND ->LABEL2 %FINISH I=CC(LENGTH+4) ->STNUMCHK %FINISH %UNLESS I='%' %AND QFLAG#1 %THEN ->LABEL3 DEL=128; ->LABEL2 LABEL3:DEL=0 %UNLESS 'A'<=I<='Z' ->LABEL2 %IF I=' ' %OR I=NL I=I!DEL LENGTH=LENGTH+1; CC(LENGTH+4)=I %IF I=';' %THEN STMTS=STMTS+1 ! STNUMCHK:%IF I='N'+128 %AND CC(LENGTH+3)='I'+128 %AND CC(LENGTH+2)='G'+128 %AND %C CC(LENGTH+1)='E'+128 %AND CC(LENGTH)='B'+128 %THEN STMTS=STMTS+1 ! %IF I='D'+128 %AND CC(LENGTH+3)='N'+128 %AND CC(LENGTH+2)='E'+128 %AND %C ':'#CC(LENGTH+1)#';' %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 CC(LENGTH-3)#'B'+128) %THEN %C STMTS=STMTS+1 ! ->LABEL2 %ROUTINE GET LINE %INTEGER K LL=0 %IF FILE ADDR=0 %THENSTART; ! SOURCE NOT A 'CLEAN' FILE %UNTIL K=NL %CYCLE READ SYMBOL(K) TLINE(LL+1)=K LL=LL+1 %REPEAT %FINISHELSESTART %SIGNALEVENT 9,0 %IF FILEPTR>=FILE END %UNTIL K=NL %OR K=0 %CYCLE K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE FILE PTR=FILE PTR+1 TLINE(LL+1)=K LL=LL+1 %REPEAT %FINISH LINE=LINE+1 %IF LIST#0 %THENSTART WRITE(LINE,5) WRITE(STMTS,5) SPACES(5) TLINE(0)=LL PRINT STRING(STRING(ADDR(TLINE(0)))) %FINISH ! %IF LL>73 %THEN TLINE(73)=10 %AND LL=73 %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 THIS SYM>128 %AND LAST SYM<128 %START ! %IF QFLAG=1 %THEN PRINTSYMBOL('''') %ELSE PRINTSYMBOL('%') ! %FINISH ! %IF LAST SYM>128 %AND THIS SYM<128 %START ! %IF QFLAG=1 %THEN PRINTSYMBOL('''') %ELSE SPACE ! %FINISH ! PRINT SYMBOL(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(1:205)= %C 1, 1, 3, 4, 0, 2, 6, 8, 12, 13, 4, 15, 17, 19, 12, 5, 6, 17, 20, 21, 7, 17, 12, 13, 0, 8, 24, 17, 20, 27, 9, 24, 31, 34, 0, 10, 31, 39, 43, 0, 11, 6, 19, 12, 0, 12, 6, 19, 46, 0, 14, 3, 4, 50, 0, 15, 52, 50, 0, 0, 16, 17, 19, 12, 0, 17, 19, 55, 17, 0, 18, 58, 60, 61, 62, 19, 58, 60, 61, 66, 20, 70, 74, 58, 76, 21, 70, 55, 19, 79, 22, 81, 31, 19, 83, 23, 55, 17, 20, 21, 24, 86, 20, 89, 21, 25, 92, 86, 93, 0, 26, 96, 97, 19, 100, 27, 103, 20, 74, 105, 29, 24, 17, 20, 107, 34, 3, 4, 112, 0, 35, 3, 4, 55, 112, 37, 74, 3, 4, 114, 40, 118, 120, 0, 0, 42, 89, 86, 20, 21, 43, 74, 123, 125, 0, 47, 126, 129, 0, 0, 48, 131, 132, 20, 134, 57, 136, 52, 0, 0, 98, 138, 0, 0, 0, 99, 138, 0, 0, 0, 103, 143, 3, 145, 0, 104, 3, 4, 143, 0, 106, 147, 149, 3, 145, 108, 151, 132, 20, 134, 127, 152, 0, 0, 0 %CONSTSHORTINTEGERARRAY LETT(1:157)= %C X'9161',X'2868',X'A3DE',X'685D',X'C800',X'6045',X'2B00',X'4BAD', X'0B13',X'27DF',X'9000',X'9968',X'A5D3',X'1940',X'9DD3',X'A0D0', X'705B',X'2800',X'73E8',X'4B80',X'2E21',X'94E7',X'7000',X'4BAD', X'0B13',X'2000',X'B059',X'A97F',X'6267',X'A000',X'8065',X'0B4B', X'A164',X'9C0B',X'1A4D',X'48C3',X'A25F',X'7000',X'4B87',X'7CA5', X'28E9',X'6640',X'9C0B',X'1A4D',X'4948',X'08C7',X'2CE7',X'4899', X'2800',X'2B89',X'9800',X'6A67',X'9A5D',X'3800',X'849F',X'1949', X'AC8A',X'BC9F',X'71C0',X'73C0',X'7980',X'9D45',X'98E5',X'4C29', X'9800',X'8065',X'0B4B',X'A165',X'9800',X'8065',X'0B4B',X'A493', X'1800',X'0CA5',X'0E40',X'225B',X'2BA7',X'4BDC',X'B059',X'4900', X'08E9',X'A858',X'8165',X'6A69',X'A148',X'B065',X'4845',X'6140', X'13DF',X'6143',X'7000',X'33E4',X'4B87',X'7CA5',X'28E8',X'226C', X'7C0B',X'905D',X'24C0',X'4BA9',X'29CB',X'9000',X'63C7',X'0B00', X'13EB',X'7100',X'614D',X'A403',X'953F',X'6267',X'A000',X'616D', X'2B26',X'225B',X'2BA7',X'4BDD',X'9800',X'2147',X'6380',X'6A67', X'8303',X'1948',X'4BA7',X'490A',X'7D68',X'4B19',X'29C3',X'6000', X'2B27',X'2800',X'9D44',X'1A03',X'9000',X'9D1B',X'7500',X'114F', X'4B80',X'0909',X'9167',X'9845',X'4B13',X'A640',X'705B',X'2CC0', X'63DD',X'3800',X'9D25',X'4B8E',X'1BDD',X'9D00',X'2B40',X'994B', X'F859',X'3BD9',X'FB43',X'7543',X'6000' %INTEGER I,J,K,M,Q,S PRINTSTRING(" (") I=-4 I=I+5 %UNTIL N=WORD(I) %OR I=201 %CYCLE J=1,1,4 K=WORD(I+J) %IF K=0 %THENEXIT SPACE %UNLESS J=1 %UNTIL M&1=0 %CYCLE M=LETT(K); S=11 %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 QP=Q %IF FAULTY=0 %START PFAULTY %IF DCOMP#0 %THENMONITOR %FINISH %IF N=100 %THENSTART %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 (CC(Q)='E'+128 %AND CC(Q+1)='N'+128 %AND %C CC(Q+2)='D'+128) %OR (CC(Q)='B'+128 %AND CC(Q+1)='E'+128 %AND %C CC(Q+2)='G'+128 %AND CC(Q+3)='I'+128 %AND CC(Q+4)='N'+128 %AND Q>QMAX) %CYCLE I=J; J=CC(Q) %IF J>128 %AND I<128 %START %IF QFLAG=1 %THEN PRINTSTRING(" '") %ELSE PRINTSTRING(" %") T=T+2 %FINISH %IF I>128 %AND J<128 %START %IF QFLAG=1 %THEN PRINTSYMBOL('''') %ELSE SPACE T=T+1 %FINISH PRINT SYMBOL(J&127) T=T+1 %IF Q=QMAX %THEN S=T Q=Q+1 %REPEAT ! %IF S<115 %THENSTART NEWLINE; SPACES(S+4) PRINT SYMBOL('!') %FINISH NEWLINE %FINISHELSESTART PRINTSTRING(" *"); WRITE(LINE,4) I=3; I=3*LEVEL %IF LIST=0; SPACES(I) CHECKSP=1; FAULTY=FAULTY+1 INHCODE=1; ! STOP GENERATING CODE PRINTSTRING("FAULT"); WRITE(N,2) MESSAGE(N) %IF N>100 %THENSTART PRINTSTRING(" DISASTER ") ABORT; %STOP %FINISH PRINTNAME(FNAME) %UNLESS FNAME=0 %FINISH %IF TTOPUT#0 %THENSTART Q=QP; J=TTOPUT; TTOPUT=0 SELECT OUTPUT(J) FAULT(N,FNAME) FAULTY=FAULTY-1 NEWLINE SELECT OUTPUT(82) TTOPUT=J %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(WORD(V)))).T %ELSE S=MESS(N) PRINTSTRING(" ? WARNING :- ".S." AT STATEMENT NO") WRITE(LINE,1) %END %ROUTINE ABORT PRINTSTRING(" **************** ABORT******************** ABORT *******") %MONITORANDSTOP %END %ROUTINE COMPARE %INTEGER RA,RL,RP,RQ,RR,RS,MARKER,SC,ALT %SWITCH BIP(1000:1039) RP=SYMBOL(P) RQ=Q; RR=R; ! RESET VALUES OF LINE&AR PTRS RL=LEVEL; SC=LINE ALT=1; ! FIRST ALTERNATIVE TO BE TRIED P=P+1; RA=SYMBOL(P); RS=P; ! RA TO NEXT PHRASE ALTERNATIVE ! ROUTINE REALLY STARTS HERE LABEL1:R=R+1 BIP(1000): SUCC: ! SUCCESS ON TO NEXT ITEM RS=RS+1; ->LABEL8 %IF RS=RA; ! RS=NEXT ALTERNATIVE MEANS THAT ! THIS ALT HAS BEEN COMPLETED SO ! EXIT WITH HIT=1 ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT ! WRITE(ITEM,5) %IF PRINTMAP#0 ->LABEL4 %IF ITEM>=1300; ! BRICK IS A PHRASE TYPE I=CC(Q); ! OBTAIN CURRENT CHARACTER ->BIP(ITEM) %IF ITEM>=1000; ! BRICK IS BUILT IN PHRASE ! BRICK IS LITERAL ->FAIL %UNLESS I=CLETT(ITEM+1); ! CHECK FIRST CHAR Q=Q+1; J=2; K=CLETT(ITEM) %WHILE J<=K %CYCLE ->FAIL %UNLESS CC(Q)=CLETT(J+ITEM) Q=Q+1; J=J+1 %REPEAT; !CHECK IT WITH LITERAL DICT !ENTRY ->SUCC; ! MATCHED SUCCESSFULLY LABEL4: ! PHRASE TYPE ALTERNATE P=ITEM; COMPARE; ! RCALL COMPARE TO RECOGNISE IT ->SUCC %IF HIT#0; ! FOUND FAIL: QMAX=Q %IF Q>QMAX; ! FAILURE - NOTE POSITION REACHD LABEL5:Q=RQ; R=RR; LINE=SC; ! RESET LINE AND A.R. POINTERS ->LABEL7 %IF RA=RP; !TOTAL FAILURE NO ALT LEFT TO !TRY RS=RA; ALT=ALT+1; ! MOVE TO NEXT ALT OF PHRASE RA=SYMBOL(RA); ->LABEL1 LABEL8: ! COMPLETE SUCCESS A(RR)=ALT HIT=1; %RETURN LABEL7: ! UTTER FAILURE LEVEL=RL HIT=0; %RETURN BIP(1001): ! PHRASE NAME BIP(1004): ! PHRASE OLDNAME %IF LASTAT=Q %THENSTART A(R+1)<-LASTNAME A(R)=LASTNAME>>8 Q=LASTEND R=R+2; ->SUCC %FINISH ->FAIL %UNLESS TRTAB(I)=2 PNAME(ITEM-1004) ->SUCC %IF HIT=1; ->FAIL BIP(1002): ! PHRASE INTEGER CONSTANT BIP(1003): ! PHRASE CONST CONST(ITEM-1003) ->FAIL %IF HIT=0 ->SUCC6 %IF CTYPE=2; ! %REAL %IF S>>12#0 %THEN PUSH(CONSTL4,S,0) A(R)=1 TOAR4(R+1,S); R=R+5; ->SUCC SUCC6:A(R)=2; TOAR8(R+1,CVALUE) PUSH123(CONSTL8,INTEGER(ADDR(CVALUE)),INTEGER(ADDR(CVALUE)+4),0) R=R+9; ->SUCC BIP(1005): ! PHRASE COMMENT TEXT S=0 %WHILE I#';' %CYCLE %IF I&128#0 %THEN S=1 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 %AND CC(J+2)='G'+128 %AND CC(J+1)='E'+128 %AND %C CC(J)='B'+128 %THEN ->SEP %IF I=';' %THEN Q=Q+1 %AND ->SEP %IF I='E'+128 %AND CC(Q+1)='N'+128 %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 FAIL0: ! 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 %AND CC(Q+3)='E'+128 Q=Q+1; ->FAIL0 BIP(1008): ! PHRASE TEXTTEXT=BETWEEN QUOTES TEXTTEXT ->FAIL %IF HIT=0; ->LABEL1 BIP(1009): ! PHRASE NAMELIST BIP(1012): ! PHRASE OLD NAMELIST ! GIVES AR IN FORM NNAMES,NAME1,....NAMEN U=R; V=1; R=R+2 PNAME(ITEM-1012); ->FAIL %IF HIT=0 LABEL90:%IF ITEM=1009 %THEN INSERTATEND(FPHEAD,LASTNAME,0,0) ->LABEL91 %UNLESS CC(Q)=',' Q=Q+1 I=CC(Q) PNAME(ITEM-1012) ->LABEL92 %IF HIT=0; V=V+1; ->LABEL90 LABEL92:Q=Q-1 LABEL91:TOAR2(U,V); ->SUCC BIP(1010): ! PHRASE HOLE MARKER=R; R=R+2; ->SUCC BIP(1011): ! PHRASE MARK I=R-MARKER A(MARKER+1)<-I A(MARKER)<-I>>8 ->SUCC BIP(1013): ! PHRASE UP STATEMENT COUNT LINE=LINE+1; ->SUCC BIP(1014): ! PHRASE LETTER STRING ->FAIL %UNLESS 'A'<=I<='Z' Q=Q+1 %WHILE 'A'<=CC(Q)<='Z' ->SUCC BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL LEVEL=LEVEL+1 JROUND(LEVEL)=0 RAL(LEVEL)=R; A(R)=0; A(R+1)=0; ! RAL FOR LINKING LABELS A(R+2)=0; A(R+3)=0; R=R+4 FLAG(LEVEL)=R; A(R)=0; A(R+1)=0; ! FLAG FOR LINKING SCALARS A(R+2)=0; A(R+3)=0; R=R+4 L(LEVEL)=R; A(R)=0; A(R+1)=0; ! L FOR LINKING ARRAYS A(R+2)=0; A(R+3)=0; R=R+4 M(LEVEL)=R; A(R)=0; A(R+1)=0; ! M FOR LINKING SWITCHES A(R+2)=0; A(R+3)=0; R=R+4 NMDECS(LEVEL)=R; A(R)=0; A(R+1)=0; ! NMDECS FOR LINKING OWNS A(R+2)=0; A(R+3)=0; R=R+4 STACKBASE(LEVEL)=R; A(R)=0; A(R+1)=0; ! STACKBASE FOR LINKING PROCS A(R+2)=0; A(R+3)=0; R=R+4 SET(LEVEL)=R R=R+4; ->SUCC BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL %IF JROUND(LEVEL)&255#0 %THEN JROUND(LEVEL)=JROUND(LEVEL)-1 %AND ->SUCC UP: %CYCLE I=0,1,NNAMES %IF WORD(I)#0 %AND NTYPE(I)&31=LEVEL %START NTYPE(I)=0 %IF TAGS(I)#0 %THENSTART POP(TAGS(I),J,K) NTYPE(I)=J %FINISH %FINISH %REPEAT TOAR4(SET(LEVEL),R-SET(LEVEL)) LEVEL=LEVEL-1 ->SUCC BIP(1017): ! PHRASE SCALAR TYPE TYPE=A(R-1); ->SUCC BIP(1018): ! PHRASE DECLARE NAME I=A(R-1)+A(R-2)<<8 J=NTYPE(I) %IF J&31=LEVEL %THENSTART QMAX=Q-T %AND ->LABEL5 %UNLESS TYPE=J>>8&255 %AND (TYPE>=128 %OR TYPE=38) %FINISHELSESTART %IF J#0 %THEN PUSH(TAGS(I),J,0) NTYPE(I)<-TYPE<<8!LEVEL %FINISH ->SUCC BIP(1019): ! PHRASE TYPE=ARITHMETIC ->SUCC %IF 1<=NTYPE(LASTNAME)>>8&7<=2 QMAX=QMAX-T; ->LABEL5 BIP(1020): ! PHRASE TYPE=BOOLEAN ->SUCC %IF NTYPE(LASTNAME)>>8&7=3 QMAX=QMAX-T; ->LABEL5 BIP(1021): ! PHRASE ARRAYTYPE TYPE=A(R-1)+32 TYPE=34 %IF TYPE=36; ->SUCC BIP(1022): ! PHRASE PROCTYPE TYPE=A(R-1)&3+128; ->SUCC BIP(1023): ! PHRASE LINK SCALAR DECLNS ->FAIL %IF LEVEL<=1 TOAR4(FLAG(LEVEL),R-FLAG(LEVEL)-1) A(R)=0; A(R+1)=0; FLAG(LEVEL)=R; A(R+2)=0; A(R+3)=0; R=R+4; ->SUCC BIP(1024): ! PHRASE LINK ARRAY DECLNS ->FAIL %IF LEVEL<=1 TOAR4(L(LEVEL),R-L(LEVEL)-1) A(R)=0; A(R+1)=0; L(LEVEL)=R; A(R+2)=0; A(R+3)=0; R=R+4; ->SUCC BIP(1025): ! PHRASE CHKLPL(LOOK FOR :=) I=Q I=I+1 %WHILE ';'#CC(I)#':' %IF CC(I)=':' %AND CC(I+1)='=' %THEN ->SUCC ->FAIL BIP(1026): ! PHRASE LABTYPE TYPE=6; ->SUCC 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 (CC(I+1)#'C'+128 %OR CC(I+2)#'O'+128 %OR %C CC(I+3)#'M'+128) %THEN ->SUCC ->FAIL BIP(1030): ! TYPE=ARR ->SUCC %IF NTYPE(LASTNAME)>>8&32#0 QMAX=QMAX-T; ->FAIL BIP(1031): ! PHRASE LINK SWITCH DECLNS ->FAIL %IF LEVEL<=1 TOAR4(M(LEVEL),R-M(LEVEL)-2) A(R)=0; A(R+1)=0; M(LEVEL)=R; A(R+2)=0; A(R+3)=0; R=R+4; ->SUCC BIP(1032): ! PHRASE LINK OWN DECLNS ->FAIL %IF LEVEL<=1 TOAR4(NMDECS(LEVEL),R-NMDECS(LEVEL)) A(R)=0; A(R+1)=0; NMDECS(LEVEL)=R; A(R+2)=0; A(R+3)=0; R=R+4; ->SUCC BIP(1033): ! PHRASE LINK PROC STMNTS TOAR4(STACKBASE(LEVEL),R-STACKBASE(LEVEL)-1) A(R)=0; A(R+1)=0; STACKBASE(LEVEL)=R; A(R+2)=0; A(R+3)=0; R=R+4; ->SUCC BIP(1034): ! PHRASE LINKLAB ->FAIL %IF LEVEL<=1 TOAR4(RAL(LEVEL),R-RAL(LEVEL)-2) A(R)=0; A(R+1)=0; RAL(LEVEL)=R; A(R+2)=0; A(R+3)=0; R=R+4; ->SUCC BIP(1035): ! PHRASE NOMORE ->SUCC %IF I=')' %OR I=',' ->FAIL BIP(1036): ! PHRASE CMPND ->FAIL %IF LEVEL<=1; ! force in a block at outer level ->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): ! lhsqbrk %IF I='[' %THEN Q=Q+1 %AND ->SUCC ->FAIL %UNLESS I='(' %AND CC(Q+1)='/' Q=Q+2; ->SUCC BIP(1039): ! rhsqbrk %IF I=']' %THEN Q=Q+1 %AND ->SUCC ->FAIL %UNLESS I='/' %AND CC(Q+1)=')' Q=Q+2; ->SUCC %END; !OF ROUTINE 'COMPARE' %ROUTINE PNAME(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME * !*********************************************************************** %INTEGER JJ,KK,LL,FQ,FS HIT=0; FQ=Q; FS=CC(Q) ->LABEL3 %UNLESS TRTAB(FS)=2; ! 1ST CHAR MUST BE LETTER S=2; T=1; LETT(NEXT+1)=FS %CYCLE Q=Q+1; I=CC(Q) %EXITIF TRTAB(I)=0 T=T+1; S=S+1 LETT(NEXT+T)=I %REPEAT LETT(NEXT)=T; ! INSERT LENGTH FAULT(108,0) %IF NEXT+S>DSIZE; !DICTIONARY OVERFLOW JJ=NNAMES&(19*T+31*FS) %CYCLE NUM=JJ,1,JJ+NNAMES KK=NUM&NNAMES; ! TREAT DICTIONARY AS CYCLIC LL=WORD(KK) ->LABEL2 %IF LL=0; ! NAME NOT KNOWN ->LABEL41 %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT FAULT(104,0); ! TOO MANY NAMES LABEL2:%IF MODE=0 %THEN Q=FQ %AND ->LABEL3 WORD(KK)=NEXT; NEXT=NEXT+S LABEL41:LASTAT=FQ; HIT=1; LASTNAME=KK A(R+1)<-LASTNAME A(R)=LASTNAME>>8; R=R+2 LASTEND=Q LABEL3:%END %ROUTINE CONST(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR NORMAL MODE=2 FOR EXPONENT (IE INTEGER CONSTANTS) * !*********************************************************************** %INTEGER Z %LONGLONGREAL CV,X CV=0; I=CC(Q); CTYPE=1 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 ->LABEL150 N: I=I&15; CV=10*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=10; CTYPE=2 I=CC(Q) ->LABEL150 %UNLESS '0'<=I<='9'; ! '23.' NOT VALID IN ALGOL %WHILE '0'<=I<='9' %CYCLE CV=CV+(I&15)/X X=10*X; Q=Q+1 I=CC(Q) %REPEAT ALPHA: ! TEST FOR EXPONENT ->FIX %UNLESS MODE=0 %AND CC(Q)='&' Q=Q+1; X=CV; CTYPE=2 Z=1; ->LABEL39 %IF '+'#CC(Q)#'-' Z=-1 %IF CC(Q)='-'; Q=Q+1 LABEL39:CONST(2); ->LABEL150 %IF HIT=0; S=S*Z CTYPE=2 ->LABEL150 %UNLESS-78<=S<=78 %OR S=-99; ! OUTSIDE RANGE %IF S=-99 %THEN CV=0 %ELSE CV=X*10**S FIX: ! SEE IF IT IS INTEGER ->LABEL41 %IF CTYPE=1 CVALUE=CV; ! imp uses load rounded (pds hopes) CTYPE=2; HIT=1; %RETURN LABEL41:->LABEL150 %IF CV>IMAX S=INT(CV) CTYPE=1; HIT=1; %RETURN LABEL150:HIT=0; ! FAILURE %END %ROUTINE TEXTTEXT %CONSTINTEGER TXT1='<' %INTEGER S,J,BR,FIRST,LAST,OLDLINE S=R; R=R+1; BR=1; OLDLINE=LINE ->LABEL98 %UNLESS I=TXT1 %OR I=123; !FAIL UNLESS INITIAL QUOTE FIRST=I; LAST=FIRST+2 Q=Q+1; J=0 %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 A(R+J)=I %IF Q>LENGTH %THEN LINE=OLDLINE %AND FAULT(106,0) J=J+1; Q=Q+1 %REPEAT %IF J>256 %THEN J=256 %AND WARN(5,0) R=R+J+1 J=J-1 A(S)=J; PUSH(CONSTL1,0,S) HIT=1; ->LABEL99 LABEL98:HIT=0 LABEL99:%END ! THE NEXT 4 ROUTINES CAN BE !MACROISED USING MVC ! %ROUTINE TOAR2(%INTEGER PTR,VALUE) ABORT %IF VALUE>>16#0 *L_1,PTR; *A_1,A; *MVC_0(2,1),VALUE+2 %END %ROUTINE TOAR4(%INTEGER PTR,VALUE) *L_1,PTR; *A_1,A; *MVC_0(4,1),VALUE %END %ROUTINE TOAR8(%INTEGER PTR, %LONGREAL VALUE) *L_1,PTR; *A_1,A; *MVC_0(8,1),VALUE %END %INTEGERFN FROMAR2(%INTEGER PTR) %INTEGER VALUE VALUE=0 *L_1,PTR; *A_1,A; *MVC_VALUE+2(2),0(1) %RESULT=VALUE %END %INTEGERFN FROMAR4(%INTEGER PTR) %INTEGER AD *L_1,PTR; *A_1,A; *MVC_AD(4),0(1) %RESULT=AD %END %LONGREALFN FROMAR8(%INTEGER PTR) %LONGREAL AD *L_1,PTR; *A_1,A; *MVC_AD(8),0(1) %RESULT=AD %END %ROUTINE PRINTNAME(%INTEGER N) %INTEGER J,V,K V=0 SPACE %IF 0<=N<=NNAMES %THEN V=WORD(N) K=LETT(V) %IF K=0 %THEN PRINTSTRING("???") %ELSE 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.PUT 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 * !*********************************************************************** %ROUTINE RECODE PRINTSTRING(" code for statement "); WRITE(LINE,4) NEWLINE PLINEDECODE PRINT USE %END %ROUTINE PRINTUSE !*********************************************************************** !* UP TO TWO USES ARE REMEMBERED INFO IN GRINF1 & GRINF2 * !* BOTTOM HALF OF GRUSE RELATES TO INF1 TOP HALF TO INF2 * !* THE MEANS CLEARING GRUSE TO FORGETS THE REG COMPLETELY * !* ARRAY REGISTER KEEPS THE CLAIM STATUS AND GRAT THE LAST USE * !*********************************************************************** %CONSTSTRING (3) %ARRAY REGNAMES(0:22)="GR0","GR1","GR2","GR3", "GR4","GR5","GR6","GR7", "GR8","GR9","GRA","GRB", "GRC","GRD","GRE","GRF", "FR0","FR1","FR2","FR3", "FR4","FR5","FR6" %CONSTSTRING (15) %ARRAY USES(0:17)=" NOT KNOWN "," I-RESULT ", " TEMPORARY "," RTPARAM ", " NAMEBASE "," LIT CONST ", " TAB CONST "," ADDR OF ", " BASE OF "," LOCAL VAR ", " LOCALTEMP "," 4K MULT ", " 4K FORLAB "," BASE REG ", " 4K FOR EPI"," DV BASE ", " STRWKAREA "," Dv ADDR " %CONSTSTRING (11) %ARRAY STATE(-1:3)= %C " LOCKED "," FREE ", " I-RESULT "," TEMPORARY ", " RT-PARAM " %ROUTINESPEC OUT(%INTEGER USE,INF) %INTEGER I,USE,JJ %CYCLE I=0,1,22 %IF REGISTER(I)<0 %AND 10<=I<=14 %THENCONTINUE %IF REGISTER(I)!GRUSE(I)#0 %START USE=GRUSE(I) PRINTSTRING(REGNAMES(I).STATE(REGISTER(I))) WRITE(GRAT(I),2) OUT(USE&255,GRINF(I)) NEWLINE %FINISH %REPEAT %RETURN %ROUTINE OUT(%INTEGER USE,INF) %CONSTINTEGER LNMASK=B'1000001110000000' %CONSTINTEGER UNMASK=B'0000001110000000' PRINTSTRING("USE = ".USES(USE)) %IF LNMASK&1<4096 %THEN %C PRHEX(INF,8) %ELSE WRITE(INF,1) %END %END %ROUTINE PLANT(%INTEGER HALFWORD) ! ADD A HALF WORD OF BINARY TO THE BUFFER PCODEHALF(HALFWORD) CA=CA+2 %END %ROUTINE PCONST(%INTEGER WORD) ! ADD A WORD OF BINARY TO THE BUFFER PCODEWORD(WORD) CA=CA+4 %END %ROUTINE PRR(%INTEGER OPCODE,R1,R2) PIXRR(OPCODE,R1,R2) %END %ROUTINE PSI(%INTEGER OPCODE,J,B,D) PIX SI(OPCODE,J,B,D) %END %ROUTINE PSS(%INTEGER OPCODE,N,B1,D1,B2,D2) PIX SS(OPCODE,0,N,B1,D1,B2,D2) %END %ROUTINE CNOP(%INTEGER I,J) PCNOP(I,J) %END %ROUTINE PGLA(%INTEGER BDRY,L,INF ADR) %INTEGER I,J J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) PDBYTES(2 {gla},GLACA,L,INF ADR) GLACA=GLACA+L %END %ROUTINE GET ENV(%SHORTINTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I %CYCLE I=0,1,22 PUSH123(HEAD,GRINF(I),GRAT(I),I<<8!GRUSE(I)) %IF GRUSE(I)#0 %REPEAT %END %ROUTINE RESTORE(%SHORTINTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I,R,USE,INF,AT CCSTATE=-1 %CYCLE I=0,1,22 %IF GRUSE(I)=12 %THEN PDROP(I) %IF REGISTER(I)>=0 %THEN GRUSE(I)=0 %AND GRINF(I)=0 %REPEAT %WHILE HEAD#0 %CYCLE POP123(HEAD,INF,AT,I) R=I>>8; USE=I&255 %IF REGISTER(R)>=0 %THEN GRUSE(R)=USE %AND GRINF(R)=INF GRAT(R)=AT %REPEAT %END %INTEGERFN NEW CELL %INTEGER I *basr_15,0 *using_15 *L_1,ASL; *LTR_2,1; *BC_7, FAULT(107,0) LABEL1:*A_2,ASLIST; *MVC_ASL+2(2),14(2); !ASL TO NEXT FREE CELL *XC_0(16,2),0(2); ! NEWCELL TO ZERO *ST_1,I *drop_15 %RESULT=I %END %ROUTINE PUSH(%SHORTINTEGERNAME CELL, %INTEGER S1,S2) %INTEGER J J=NEWCELL; *l_1,j *LR_4,1; ! NECESSARY FOR FNS *LM_15,1,CELL; *LH_3,0(15); *SR_2,2 *STH_4,0(15); *A_4,ASLIST; *STM_0,3,0(4) %END %ROUTINE PUSH123(%SHORTINTEGERNAME CELL, %INTEGER S1,S2,S3) %INTEGER J J=NEWCELL; *l_1,j *LR_4,1; ! NECESSARY FOR FNS *LM_15,2,CELL; *LH_3,0(15) *STH_4,0(15); *A_4,ASLIST; *STM_0,3,0(4) %END %ROUTINE POP(%SHORTINTEGERNAME CELL, %INTEGERNAME S1,S2) *LM_1,3,CELL; *LH_4,0(1); *L_15,ASLIST *L_0,0(4,15); *ST_0,0(2); ! SET S1 *L_0,4(4,15); *ST_0,0(3); ! SET S2 *basr_2,0 *using_2 *LTR_4,4; *BC_8,; ! HEAD =0 FOR NULL LIST *LH_0,14(4,15); *STH_0,0(1); ! HEADCELL TO OLD 2ND CELL *L_3,ASL; *STH_3,14(4,15); *ST_4,ASL *drop_2 LABEL1:%END %ROUTINE POP123(%SHORTINTEGERNAME CELL, %INTEGERNAME S1,S2,S3) *LM_1,3,CELL; *LH_4,0(1); *L_15,ASLIST *L_0,0(4,15); *ST_0,0(2); ! SET S1 *L_0,4(4,15); *ST_0,0(3); ! SET S2 *L_0,8(4,15); *L_3,S3; *ST_0,0(3); ! SET S3 *basr_2,0 *using_2 *LTR_4,4; *BC_8,; ! HEAD =0 FOR NULL LIST *LH_0,14(4,15); *STH_0,0(1); ! HEADCELL TO OLD 2ND CELL *L_3,ASL; *STH_3,14(4,15); *ST_4,ASL *drop_2 LABEL1:%END %ROUTINE REPLACE1(%INTEGER CELL,S1) INTEGER(ADDR(ASLIST(CELL)))=S1 %END %ROUTINE REPLACE2(%INTEGER CELL,S2) INTEGER(ADDR(ASLIST(CELL+4)))=S2 %END %ROUTINE REPLACE3(%INTEGER CELL,S3) INTEGER(ADDR(ASLIST(CELL+8)))=S3 %END %ROUTINE MLINK(%INTEGERNAME CELL) CELL=SHORTINTEGER(ADDR(ASLIST(CELL+14))) %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. *basr_3,0 *using_3 *LM_0,1,LAB; *L_2,ASLIST AGAIN:*LTR_4,1; *BC_8, *C_0,4(1,2) *BC_8, *LH_1,14(1,2) *BC_15, FAIL: *L_1,0(4,2); ! IF FAIL LOADS-1 ELSE RESULT FOUND:*ST_1,LIST *drop_3 %RESULT=LIST %END !%INTEGERFN FIND3(%INTEGER S3, LIST) !!*********************************************************************** !!* SEARCHES LIST FOR S3 IN STREAM 3 * !!* RETURNS CELL NO AS RESULT * !!*********************************************************************** ! *LM_0,1,S3 ! *L_2,ASLIST !AGAIN: *LTR_4,1 ! *BC_8, ! *C_0,8(1,2) ! *BC_8, ! *LH_1,14(1,2) ! *BC_15, !FAIL: *BCTR_1,0 !FOUND: *ST_1,LIST ! %RESULT =LIST !%END %ROUTINE FROM123(%INTEGER CELL, %INTEGERNAME S1,S2,S3) *LM_1,4,CELL; *A_1,ASLIST *LM_15,1,0(1); *ST_15,0(2) *ST_0,0(3); *ST_1,0(4) %END %ROUTINE FROM12(%INTEGER CELL, %INTEGERNAME S1,S2) *LM_1,3,CELL; *A_1,ASLIST *LM_0,1,0(1); *ST_0,0(2); *ST_1,0(3) %END %INTEGERFN FROM1(%INTEGER CELL) %RESULT=INTEGER(ADDR(ASLIST(CELL))) %END %INTEGERFN FROM2(%INTEGER CELL) %RESULT=INTEGER(ADDR(ASLIST(CELL))+4) %END %INTEGERFN FROM3(%INTEGER CELL) %RESULT=INTEGER(ADDR(ASLIST(CELL))+8) %END %ROUTINE CLEAR LIST(%SHORTINTEGERNAME OPHEAD) *basr_15,0 *using_15 *L_1,OPHEAD; *Lh_1,0(1); *LTR_1,1; *BC_8, *L_2,ASLIST; *L_0,ASL; *ST_1,ASL AGAIN:*LR_3,1; *LH_1,14(1,2); ! NEXT LINK *LTR_1,1; *BC_7,; ! IS IT ZERO? *STH_0,14(3,2); ! LAST LINK TO OLD VALUE OF ASL *drop_15 EMPTY:OPHEAD=0 %END %ROUTINE CONCAT(%SHORTINTEGERNAME LIST1,LIST2) ! ADDS LIST2 TO BOTTOM OF LIST1 *basr_5,0 *using_5 *L_4,LIST1; *L_15,LIST2 *LH_0,0(15); *L_2,ASLIST; *LH_1,0(4) *LTR_3,1; *BC_7,; *STH_0,0(4); *BC_15, ON: *LR_3,1; *LH_1,14(3,2); ! NEXT LINK *LTR_1,1; *BC_7, *STH_0,14(3,2); ! LAST LINK TO NEW LIST COMM: *STH_1,0(15); ! ZERO HEAD OF LIST2 IN CASE *drop_5 %END; ! AN ERROR PUTS CELL TWICE ONTO ! FREE LIST - CATASTROPHIC! %ROUTINE INSERT AT END(%SHORTINTEGERNAME CELL, %INTEGER S1,S2,S3) !*********************************************************************** !* ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL' * !*********************************************************************** %INTEGER J J=NEWCELL; *l_1,j *L_2,ASLIST *L_4,CELL; *LH_3,0(4); ! GET HEAD CELL *basr_15,0 *using_15 *LTR_3,3; *BC_7,; ! LIST NOT EMPTY *STH_1,0(4); *BC_15,; ! EMPTY LIST -- CELL TO TOP ON: *LR_4,3; *LH_3,14(2,4); ! IS NEXT CELL THE BOTTOM?? *LTR_3,3; *BC_7, *STH_1,14(2,4) LOAD: *AR_1,2; *MVC_0(12,1),S1 *drop_15 %END %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 !*********************************************************************** !* CHECK ASL AND PRINT NO OF FREE CELLS. DEBUGGING SERVICE ONLY * !*********************************************************************** %INTEGER N,Q Q=ASL; N=0 %WHILE Q#0 %CYCLE N=N+1 MLINK(Q) %REPEAT NEWLINE PRINTSTRING("FREE CELLS AFTER LINE ") WRITE(LINE,3) PRINTSYMBOL('=') WRITE(N,3) %END %ROUTINE PRINTLIST(%INTEGER CELL) %INTEGER S1,S2,S3 PRINTSTRING("print of list"); WRITE(CELL,5) NEWLINE %WHILE CELL>0 %CYCLE FROM123(CELL,S1,S2,S3) WRITE(CELL,5); SPACES(3) PRHEX(S1,8); SPACES(3) PRHEX(S2,8); SPACES(3) PRHEX(S3,8); SPACES(3) NEWLINE MLINK(CELL) %REPEAT %END %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5 * !* IF 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 PFIX(2,GLARAD,AREA,VALUE) %END %ROUTINE GXREF(%STRING (255) NAME, %INTEGER AT) !*********************************************************************** !* ASK PUT TO ARRANGE TO RELOCATE FOUR WORDS AT 'AT' * !* IN THE GLA BY EXTERNAL PROCEDURE NAME 'NAME'. * !*********************************************************************** %STRING (8) ID ID<-NAME; ! MOVE IN NAME AT=PXNAME(0,NAME,AT) %END %ROUTINE CXREF(%STRING (255) NAME, %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 Z0,Z1,Z2,Z3 Z1=0; Z0=0; Z2=0; Z3=-1 PGLA(4,16,ADDR(Z0)); ! 4 ZERO WORDS AT=GLACA-16 GXREF(NAME,AT) %END %ROUTINE PROLOGUE !*********************************************************************** !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* !*********************************************************************** %ROUTINESPEC CHK DUPS(%SHORTINTEGERNAME CONST, %INTEGER L) %ROUTINESPEC ERR EXIT(%INTEGER A,B) %CONSTINTEGERARRAY FIXEDCA(0:23)=X'40800000',0(3), X'41100000',0, X'4E000000',0, X'4E000001',0, X'4E000000',-1, X'80808080'(2), X'80000000',1, 2,3,-4,-8, X'48800000',0, X'0000FFFF',X'00010000' %INTEGER I,J,K,HEADP %SHORTINTEGER HEAD ! ! FIRST GENERATE THE TABLE OF 4K MULTIPLES AT LABEL P0 ! PLABS(0)=CA PTLAST=2*(R//4096)+4 %CYCLE I=0,1,PTLAST PCONST(4096*I) %REPEAT ! ! NEXT GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! PLABS(1)=CA %CYCLE I=0,1,23 PCONST(FIXEDCA(I)) %REPEAT UNASSPAT=FIXEDCA(12); ! THE UNASSIGNED PATTERN HEAD=0 PUSH123(HEAD,0,0,X'80000000'+PLABS(1)+4) PUSH123(HEAD,-1,0,X'80000000'+PLABS(1)+44) %CYCLE K=1,1,3 PUSH123(HEAD,K,0,X'80000000'+PLABS(1)+4*(K+14)) %REPEAT CHK DUPS(CONSTL4,4) HEAD=0; %IF CA&7#0 %THEN PCONST(0) ! ! SIMILARLY FOR THE REAL CONSTANTS ! %CYCLE K=2,2,6 PUSH123(HEAD,FIXEDCA(K),FIXEDCA(K+1),X'80000000'+PLABS(1)+4*K) %REPEAT CHK DUPS(CONSTL8,8) ! ! NOW THE STRINGS ! HEADP=CONSTL1 %WHILE HEADP#0 %CYCLE I=FROM2(HEADP) K=A(I); REPLACE1(HEADP,CA) PLANT(K<<8!A(I+1)&127) J=1 %WHILE J0 %THEN ->P12 OVERWRITE(11) PIX RX(LGR,3,0,GLAREG,36) PIX RX(ST,3,0,11,8) PIX RX(ST,11,0,11,4) PIX RX(LGR,1,0,3,4) PRR(LTR,1,1) PRR(BASR,2,0) PIX RX(BC,2,0,2,6) PRR(SR,1,1) PIX RX(LGR,0,0,3,8) PIX RX(ST,0,0,11,12) PIX RX(LA,4,1,11,7) PIX RX(LGR,1,0,3,12) PIX RX(MH,1,0,3,10) PRR(LCR,0,1) PB: PIX RX(AND,4,0,12,PLABS(1)+4*19); ! N 4,=F'-8' PRR(AR,0,11) PIX RX(LGR,1,0,GLAREG,28) PIX RX(ICP,4,0,1,0) PJUMP(BC,PLABS(8)&x'ffff',10,1) PIX RS(LM,1,3,11,4) %IF UNASS=0 %THENSTART PRR(LR,11,4) PRR(BCR,15,15) %FINISHELSESTART PIX RX(LD,0,0,12,PLABS(1)+4*12) PIX RX(ST,15,0,GLAREG,32) PRR(BASR,15,0) PIX RX(STD,0,0,11,0) PIX RX(LA,11,0,11,8) PRR(CR,11,4) PRR(BCR,4,15) PIX RX(LGR,15,0,GLAREG,32) PRR(BCR,15,15) %FINISH P12: ! !* MULTI DIMENSION ARRAY DECLARATION !* VALID FOR ANY NO OF DIMENSION BUT THE COMPILER JIB AT >12 !* LOGIC AS FOR 1D BUT MORE COMPLICATED ! ! L 3,36(GLA) POINTER TO DV ! ST 3,8(11) HEAD IN FREE SPACE AS FOR 1D ! ST 11,4(11) ! STM 5,7,16(11) DUMP 3 REGS FOR EXTRA WORKSPACE ! L 6,0(3) NO OF DIMENSIOS (ND) ! BCTR 6,0 ! L 2,32(3) STRIDE OF SECOND D ! LTR 2,2 ! BALR 7,0 ! BC 10,*+6 ! SR 2,2 'INSIDEOUT' NO FAULT IN ALGOL ! ST 2,12(11) 4TH WORD OF HEAD ! LR 5,6 ! L 1,4(3) TOTSIZE ! L 6,12(3) LB(1) TO WORK OUT ADDR(A(0,..)) ! MH 6,22(3) times stride (1) ! LCR 0,6 !L2 LA 3,12(3) on a dimension ! L 6,12(3) LB(N) ! MH 6,22(3) times STRIDE(N) ! SR 0,6 accumulated ! BCT 5,L2 ! LA 4,7(1,11) ! LM 5,7,16(11) RESTORE SAVED REGISTERS ! !* CONTINUE WITH EXCESS BLOCK CHECK AND UNASSGNED FILLING AS 1D ! %IF PLABS(12)>0 %THEN ->P13 OVERWRITE(12) PIX RX(LGR,3,0,GLAREG,36) PIX RX(ST,3,0,11,8) PIX RX(ST,11,0,11,4) PIX RS(STM,5,7,11,16) PIX RX(LGR,6,0,3,0) PRR(BCTR,6,0) PIX RX(LGR,2,0,3,32) PRR(LTR,2,2) PRR(BASR,7,0) PUSING(7) PIX RX(BC,10,0,7,6) PRR(SR,2,2) PIX RX(ST,2,0,11,12) PRR(LR,5,6) PIX RX(LGR,1,0,3,4) PIX RX(LGR,6,0,3,12) PIX RX(MH,6,0,3,22) PRR(LCR,0,6) PLABEL(GLABEL) PIX RX(LA,3,0,3,12) PIX RX(LGR,6,0,3,12) PIX RX(MH,6,0,3,22) PIX RR(SR,0,6) PJUMP(BCT,GLABEL,5,4) GLABEL=GLABEL-1 PDROP(7) PIX RX(LA,4,1,11,7) PIX RS(LM,5,7,11,16) ->PB P13: ! !* ARRAY BY VALUE SUBROUTINE !* GR3 POINTS TO THE HEADER OF ARRAY TO BE COPIED !* THIS ROUTINE COPIES ARRAY AND THEN ADJUSTS THE HEADER TO !* POINT TO THE COPY ! ST 15,32(GLA) SAVE RETURN ADDRESS ! L 2,8(3) POINTER TO DOPE VECTOR ! BASR 15,0 set base reg for jumps ! using 15 notify put ! CLC 0(1,11),11(2) compare reqd item size with dv item size ! BC 2,FLT each item needs floating ! BC 4,fix each item needs fixing ! l 1,4(2) totsize ! SRL 1,3 SIZE IN DOUBLE WORDS ! LA 1,1(1) UP TO NEXT DW BNDRY ! SLL 1,3 AND BACK TO BYTES ! L 4,4(3) ADDRESS OF FIRST ELEMENT ! LR 0,11 ADDRESS OF 1ST ELEMENT OF COPY ! ar 11,1 cliam space for array copy ! L 15,0(3) ADDR(A(0,..)) OF ORIGINAL ! S 15,4(3) CONVERTED TO A RELATIVE OFFSET ! AR 15,0 and IS ADJUSTED TO NEW ! STM 15,0,0(3) AND STORED BACK IN HEAD ! LR 3,1 NOW COPY ARRAY with MVCL ! MVCL 0,2 !xit EQU * glabel ! L 15,32(GLA) ! BR 15 !flt EQU * glabel-1 ! lm 0,1,0(2) first 2 items in dv ! ar 1,1 size adjusted ! stm 0,1,0(11) and stored ! l 1,8(2) elsize ! ar 1,1 is adjusted ! st 1,8(11) and stored ! st 11,8(3) store pointer to revised dv ! l 1,12(3) stride from head ! ar 1,1 is revised ! st 1,12(3) and replaced ! la 11,12(11) ! la 2,12(2) !agn equ * glabel-5 ! mvc 0(8,11),0(2) lb&ub moved ! l 1,8(2) stride picked up ! ar 1,1 is adjusted ! st 1,8(11) and stored ! la 11,12(11) ! la 2,12(2) ! bct 0,agn ! la 11,7(11) ! n 11,plabs(1)+76 =f'-8' ! l 2,8(3) pointer to revised dv ! l 1,4(2) revised size in bytes ! SRL 1,3 size in words ! l 2,4(3) addr first element ! l 0,0(3) addr zero element ! sr 0,2 made relative ! ar 0,0 doubled as each item doubles in size ! ar 0,11 pointed at copy of array ! st 0,0(3) and replaced into array head ! st 11,4(3) addr first similarly replaced ! ltr 1,1 check for array of 0 elements (legal in Algol) ! bc 12,xit ! sdr 2,2 zero freg for normalising !nint equ * glabel-2 ! l 0,0(2) next integer ! st 0,0(11) to temp ! lpr 0,0 ! st 0,4(11) mantissa ! nc 0(4,11),plabs(1)+56 =x'80000000' ! oi 0(11),x'4e' exponent added ! ld 0,0(11) now normalise real ! adr 0,2 by adding zero ! std 0,0(11) into new place ! la 2,4(2) to next integer ! la 11,8(11) for next real ! bct 1,nint for next ! bc 15,xit !fix equ * fix floating point arrays ! lm 0,1,0(2) first 2 items in dv ! sra 1,1 size adjusted ! stm 0,1,0(11) and stored ! l 1,8(2) elsize ! sra 1,1 is adjusted ! st 1,8(11) and stored ! st 11,8(3) store pointer to revised dv ! l 1,12(3) stride from head ! sra 1,1 is revised ! st 1,12(3) and replaced ! la 11,12(11) ! la 2,12(2) !agn2 equ * glabel-6 ! mvc 0(8,11),0(2) lb&ub moved ! l 1,8(2) stride picked up ! sra 1,1 is adjusted ! st 1,8(11) and stored ! la 11,12(11) ! la 2,12(2) ! bct 0,agn2 ! l 2,8(3) pointer to revised dv ! l 1,4(2) revised size in bytes ! srl 1,2 in double words ! l 2,4(3) addr first to be fixed ! l 0,0(3) addr zero element ! sr 0,2 relativised ! sra 0,1 and halved as integer are half the size of reals ! ar 0,11 and pointed at copy of array ! st 0,0(3) ! st 11,4(3) new actual first element stored ! ltr 1,1 beware of arrays with no elements ! bc 12,xit ! ld 2,plabs(1)+0 d'0.5' ! ld 4,plabs(1)=80 =x'4880000000000000' ! ld 6,plabs(1)+24 =x'4e00000000000000' !nreal equ * glabel-4 ! ld 0,0(2) next for fixing ! adr 0,2 +0.5 ! cdr 0,4 check not too big ! bc 10,plabs(10) ! adr 0,4 ! bc 4,plabs(10) too negative ! awr 0,6 ! std 0,0(11) ! xi 4(11),x'80' flip sign == subtract 2**32 ! mvc 0(4,11),4(11) close into final posn ! la 2,8(2) ! la 11,4(11) ! bct 1,nreal ! la 11,7(11) ! n 11,plabs(1)+76 =f'-8' ! bc 15,xit ! drop 15 %IF PLABS(13)>0 %THEN ->P14 OVERWRITE(13) PIX RX(ST,15,0,GLAREG,32) PIX RX(LGR,2,0,3,8) PIX RX(LGR,1,0,2,4) PIX RR(BASR,15,0) PUSING(15) PIX SS(CLC,0,1,11,0,2,11) PJUMP(BC,GLABEL-1,2,0) PJUMP(BC,GLABEL-3,4,0) pix rx(lgr,1,0,2,4) PIX RS(SRL,1,0,0,3) PIX RX(LA,1,0,1,1) PIX RS(SLL,1,0,0,3) PIX RX(LGR,2,0,3,4) PRR(LR,0,11) PRR(AR,11,1) PIX RX(LGR,15,0,3,0) PIX RX(ISUB,15,0,3,4) PRR(AR,15,0) PIX RS(STM,15,0,3,0) PRR(LR,3,1) PIXRR(MVCL,0,2) PLABEL(GLABEL); ! label xit PIX RX(LGR,15,0,GLAREG,32) PRR(BCR,15,15) PLABEL(GLABEL-1); ! label flt pix rs(lm,0,1,2,0) pix rr(ar,1,1) pix rs(stm,0,1,11,0) pix rx(lgr,1,0,2,8) pix rr(ar,1,1) pix rx(st,1,0,11,8) pix rx(st,11,0,3,8) pix rx(lgr,1,0,3,12) pix rr(ar,1,1) pix rx(st,1,0,3,12) pix rx(la,11,0,11,12) pix rx(la,2,0,2,12) plabel(glabel-5) pix ss(mvc,0,8,11,0,2,0) pix rx(lgr,1,0,2,8) pix rr(ar,1,1) pix rx(st,1,0,11,8) pix rx(la,11,0,11,12) pix rx(la,2,0,2,12) pjump(bct,glabel-5,0,0) pix rx(la,11,0,11,7) pixrx(and,11,0,coder,plabs(1)+76) pix rx(lgr,2,0,3,8) pix rx(lgr,1,0,2,4) PIX RS(SRL,1,0,0,3) PIX RX(LGR,2,0,3,4) PIX RX(LGR,0,0,3,0) PIX RR(SR,0,2) PIX RR(AR,0,0) PIX RR(AR,0,11) PIX RX(ST,0,0,3,0) PIX RX(ST,11,0,3,4) PIX RR(LTR,1,1) PJUMP(BC,GLABEL,12,0) PIX RR(SDR,2,2) PLABEL(GLABEL-2); ! label nint PIX RX(LGR,0,0,2,0) PIX RX(ST,0,0,11,0) PIX RR(LPR,0,0) PIXRX(ST,0,0,11,4) PIX SS(NC,0,4,11,0,CODER,PLABS(1)+56) PIX SI(OI,x'4e',11,0) PIX RX(LD,0,0,11,0) PIX RR(ADR,0,2) PIX RX(STD,0,0,11,0) PIX RX(LA,2,0,2,4) PIX RX(LA,11,0,11,8) PJUMP(BCT,GLABEL-2,1,0) PJUMP(BC,GLABEL,15,0) PLABEL(GLABEL-3); ! label fix pix rs(lm,0,1,2,0) pix rs(sra,1,0,0,1) pix rs(stm,0,1,11,0) pix rx(lgr,1,0,2,8) pix rs(sra,1,0,0,1) pix rx(st,1,0,11,8) pix rx(st,11,0,3,8) pix rx(lgr,1,0,3,12) pix rs(sra,1,0,0,1) pix rx(st,1,0,3,12) pix rx(la,11,0,11,12) pix rx(la,2,0,2,12) plabel(glabel-6) pix ss(mvc,0,8,11,0,2,0) pix rx(lgr,1,0,2,8) pix rs(sra,1,0,0,1) pix rx(st,1,0,11,8) pix rx(la,11,0,11,12) pix rx(la,2,0,2,12) pjump(bct,glabel-6,0,0) pix rx(lgr,2,0,3,8) pix rx(lgr,1,0,2,4) PIX RS(SRL,1,0,0,2) PIX RX(LGR,2,0,3,4) PIX RX(LGR,0,0,3,0) PIX RR(SR,0,2) PIX RS(SRA,0,0,0,1) PIX RR(AR,0,11) PIX RX(ST,0,0,3,0) PIX RX(ST,11,0,3,4) PIX RR(LTR,1,1) PJUMP(BC,GLABEL,12,0) PIX RX(LD,2,0,CODER,PLABS(1)) PIX RX(LD,4,0,CODER,PLABS(1)+80) PIX RX(LD,6,0,CODER,PLABS(1)+24) PLABEL(GLABEL-4); ! label nreal PIX RX(LD,0,0,2,0) PIX RR(ADR,0,2) PIX RR(CDR,0,4) PJUMP(BC,PLABS(10)&x'ffff',10,0) PIX RR(ADR,0,4) PJUMP(BC,PLABS(10)&x'ffff',4,0) PIX RR(AWR,0,6) PIX RX(STD,0,0,11,0) PIX SI(XI,x'80',11,4) PIX SS(MVC,0,4,11,0,11,4) PIX RX(LA,2,0,2,8) PIX RX(LA,11,0,11,4) PJUMP(BCT,GLABEL-4,1,0) PIX RX(LA,11,0,11,7) PIX RX(AND,11,0,CODER,PLABS(1)+76) PJUMP(BC,GLABEL,15,0) PDROP(15) GLABEL=GLABEL-7 P14: !* EVALUATE X**Y. Y IS 32(GLA) AND X IS 64(11) !* SUBROUTINE GIVES FAULT 21 IF X<0 OR (X=0 AND Y<=0) !* REPEATED MULTIPLICATION IS USED IF Y>0 AND FRACPT(Y)=0 !* CODE PLANTED IS AS FOLLOWS:- ! LD 2,64(11) OBTAIN X ! LD 0,32(13) OBTAIN Y ! LA 0,x'505' ERROR NO ! LTDR 6,2 ! BCR 4,12 ERROR IF X<0 ! BALR 1,0 SET A BASE REGISTER ! BC 2,TRYMULT BRANCH UNLESS X=0 ! LTDR 0,0 WHEREUPON INSPECT Y ! BCR 12,12 ERROR IF Y<=0 ! ldr 0,2 ! BCR 15,15 0**(+VE)=0 AND 0 IS IN FR2 !TRYMULT LTDR 4,0 INSPECT Y AGAIN ! BC 4,NONINT Y<0 NEEDS LOG & EXP ! AW 4,=X'4E00000000000000' ! STD 4,0(11) SAVE FRACPT(Y) ! AD 4,=D'0' NORMALISE ! CDR 4,0 ! BC 7,NONINT FRACPT IS NONZERO ! L 2,4(11) INTEGER FORM OF Y ! LD 0,=D'1' ! LTR 2,2 ! BCR 8,15 X**0=1 FOR ALL +VE X ! MDR 0,6 ! BCT 2,*-2 EVALUATE BY REPEATED MULTIPLICATION ! BCR 15,15 RETURNING RESULT IN FR2 !NONINT ST 15,0(11) ! STM 4,14,24(11) SAVE REGISTERS W OLD VALUE OF R11 ! LA 11,8(11) SAVE AND PROTECT RETURN ADDRESS ! STD 2,64(11) PASS X TO LOG ROUTINE ! LM 12,14,LOGEP CALL ALGOL LOG ! BALR 15,14 ! MD 0,32(GLA) ! STD 0,64(11) EVALUATE EXP(Y*LOG(X)) ! STM 4,14,16(11) ! L 15,0(11) FAKE RETURN DIRECT TO PROGRAM ! LM 12,14,EXPEP ! BCR 15,14 DOES NOT RETURN ! %IF PLABS(14)>0 %THEN ->P15 %IF LOGEPDISP=0 %THEN CXREF("S#ILOG",LOGEPDISP) %IF EXPEPDISP=0 %THEN CXREF("S#IEXP",EXPEPDISP) OVERWRITE(14) PIX RX(LD,2,0,11,64) PIX RX(LD,0,0,GLAREG,32) PIX RX(LA,0,0,0,x'505') PRR(LTDR,6,2) PJUMP(BC,PLABS(2)&x'ffff',4,1) PRR(BASR,1,0) PUSING(1) PJUMP(BC,GLABEL,2,0) PRR(LTDR,0,0) PJUMP(BC,PLABS(2)&x'ffff',12,2) PRR(LDR,0,2) PRR(BCR,15,15) PLABEL(GLABEL) PRR(LTDR,4,0) PJUMP(BC,GLABEL-1,4,0) PIX RX(AW,4,0,12,24+PLABS(1)); ! DISP OF X'4E000000000000' PIX RX(STD,4,0,11,0) PIX RX(AD,4,0,12,8+PLABS(1)); ! DISP OF D'0' PRR(CDR,4,0) PJUMP(BC,GLABEL-1,7,0) PIX RX(LGR,2,0,11,4) PIX RX(LD,0,0,12,16+PLABS(1)); ! DISP OF D'1' PRR(LTR,2,2) PRR(BCR,8,15) PLABEL(GLABEL-2) PRR(MDR,0,6) PJUMP(BCT,GLABEL-2,2,0) PRR(BCR,15,15) PLABEL(GLABEL-1) PIX RX(ST,15,0,11,0) PIX RS(STM,4,14,11,24) PIX RX(LA,11,0,11,8) PIX RX(STD,2,0,11,64) PIX RS(LM,12,14,GLAREG,LOGEPDISP) PRR(BASR,15,14) PIX RX(MD,0,0,GLAREG,32) PIX RS(STM,4,14,11,16) PIX RX(STD,0,0,11,64) PIX RS(LM,12,14,GLAREG,EXPEPDISP) PIX RX(LGR,15,0,11,0) PRR(BCR,15,14) PDROP(1) GLABEL=GLABEL-3 P15: %RETURN %ROUTINE OVERWRITE(%INTEGER LAB) !*********************************************************************** !* OVERWRITE THE NO-OPS IN PROLOGUE WITH JUMP TO CURRENT ADDRESS * !*********************************************************************** K=PLABS(LAB)&X'FFFFFF' PLABEL(K) PLABS(LAB)=K %END %END %ROUTINE CSS(%INTEGER PIN) %ROUTINESPEC MERGE INFO %ROUTINESPEC REDUCE ENV(%SHORTINTEGERNAME HEAD) %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG) %ROUTINESPEC ENTER LAB(%INTEGER M,FLAG,LEVEL) %ROUTINESPEC SET LOCAL BASE %ROUTINESPEC CEND(%INTEGER KKK) %ROUTINESPEC CBPAIR(%INTEGERNAME LB,UB) %ROUTINESPEC CCOND %ROUTINESPEC REMOVE LABS %ROUTINESPEC SET LINE %ROUTINESPEC C FORSTMNT %ROUTINESPEC CSTMNT %ROUTINESPEC CUI %ROUTINESPEC GOTOLAB(%INTEGERNAME REPORT, %INTEGER MODE) %ROUTINESPEC CDE(%INTEGERNAME REPORT, %INTEGER MODE) %ROUTINESPEC CSDE(%INTEGERNAME REPORT, %INTEGER MODE) %ROUTINESPEC CCMPNDSTMNT %ROUTINESPEC CBLK(%INTEGER BLKTYPE) %ROUTINESPEC BULKM(%INTEGER A,B,C,D,E,F) %ROUTINESPEC ETORP(%SHORTINTEGERNAME A,B, %INTEGER C) %ROUTINESPEC TORP(%SHORTINTEGERNAME HEAD,NOPS, %INTEGER MODE) %ROUTINESPEC SET USE(%INTEGER R,U,I) %ROUTINESPEC NAMEXP(%INTEGER A,B) %ROUTINESPEC CSEXP(%INTEGER REG,MODE) %ROUTINESPEC FREE AND FORGET(%INTEGER REG) %ROUTINESPEC SAVE IRS(%INTEGER MODE) %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, %INTEGERNAME B,C,D) %ROUTINESPEC MAKE DECS(%INTEGER P,K) %ROUTINESPEC DECLARE OWNS %ROUTINESPEC DECLARE ARRAYS %ROUTINESPEC DECLARE SCALARS %ROUTINESPEC DECLARE LABS %ROUTINESPEC DECLARE PROC %ROUTINESPEC DECLARE SWITCHES %ROUTINESPEC CLABEL %ROUTINESPEC COLABEL %ROUTINESPEC MOVE R(%INTEGER R,N) %ROUTINESPEC GET WSP(%INTEGERNAME PLACE, %INTEGER SIZE) %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) %ROUTINESPEC RTDES(%INTEGER A,B) %ROUTINESPEC GTHUNKS(%INTEGER A,P, %INTEGERNAME B) %INTEGERFNSPEC CHECK FPROCS(%INTEGER A,B) %ROUTINESPEC CRCALL(%INTEGER A,B,DUMMY) %ROUTINESPEC PROTECT ST(%ROUTINE ACTION, %INTEGER I,J,K) %ROUTINESPEC CALL THUNKS(%INTEGER A,B,C) %ROUTINESPEC FETCH STRING(%INTEGER REG) %ROUTINESPEC CNAME(%INTEGER Z,REG) %ROUTINESPEC CANAME(%INTEGER Z,BS,DP) %ROUTINESPEC ADJUST INDEX(%INTEGER M, %INTEGERNAME I,D) %ROUTINESPEC CSNAME(%INTEGER Z,REG) %ROUTINESPEC LOAD ABASE(%INTEGER NAM, %INTEGERNAME REG) %ROUTINESPEC COPY TAG(%INTEGER KK) %ROUTINESPEC REDUCE TAG %ROUTINESPEC REPLACE TAG(%INTEGER KK) %ROUTINESPEC RT JUMP(%INTEGER CODE,R1,RT) %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK) %ROUTINESPEC TESTNST %ROUTINESPEC UNPACK %ROUTINESPEC PACK(%INTEGERNAME PTYPE) %ROUTINESPEC LOAD DV(%INTEGERNAME REG, %INTEGER B,D,T) %ROUTINESPEC DUMP(%INTEGER CODE,REG,DIS,X,LEVEL) %ROUTINESPEC DUMPM(%INTEGER OPCODE,R1,R2,B,D) %ROUTINESPEC DUMPSI(%INTEGER OPCODE,L,B,D) %ROUTINESPEC RHEAD(%INTEGER KK) %ROUTINESPEC PPJ(%INTEGER MASK,N) %ROUTINESPEC FIND USE(%INTEGERNAME REG, %INTEGER TYPE,USE,INF) %ROUTINESPEC CLAIM(%INTEGER A, %INTEGERNAME REG) %ROUTINESPEC FIND REG(%INTEGER A, %INTEGERNAME REG) %ROUTINESPEC FORGET(%INTEGER REG) %ROUTINESPEC FORGETM(%INTEGER UPPER) %ROUTINESPEC FIND SEQ(%INTEGERNAME ONE,TWO) %ROUTINESPEC REMEMBER %INTEGERFNSPEC CONST FIND(%INTEGER L,AD) %ROUTINESPEC STORE CONST(%INTEGERNAME B,D, %INTEGER L,AD) %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR) %SWITCH SW(1:15) %RECORDFORMAT RD(%SHORTINTEGER PTYPE, %BYTEINTEGER XB,FLAG, %INTEGER D,XTRA) %INTEGER P; P=PIN %SHORTINTEGER TWSPHEAD,RDHEAD,SNDISP,ACC,K,KFORM %INTEGER TCELL,ADISP,JJ,JJJ,KK,QQ,BASE,INDEX,DISP,PTYPE,I,J,OLDI,USEBITS %BYTEINTEGER ROUT,NAM,ARR,TYPE %OWNINTEGER FPTR=0 %INTEGERARRAY SGRUSE,SGRINF(0:22) RDHEAD=0; TWSPHEAD=0 SNDISP=0; ACC=1; K=0; KFORM=0 ->SW(A(P)) SW(1): ! SET LINE %IF LEVEL<=1 %THEN FAULT(57,0) %ANDRETURN NMDECS(LEVEL)=NMDECS(LEVEL)!1 P=P+1; CSTMNT LABEL1:CLEAR LIST(RDHEAD) %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK) RETURN WSP(JJ,KK) %REPEAT %RETURN SW(2): ! %END SET LINE CEND(FLAG(LEVEL)) %RETURN SW(3): ! %PROCEDURE %BEGIN %INTEGER PNAME,EXTRN,Q,PP,PTYPEP,PARN,DISP,TYPEP,LINK,NP,LINEP,PE,PL %SHORTINTEGER OPHEAD PP=P; PNAME=FROMAR2(P+8); ! PROCEDURE NAME EXTRN=P+6+FROMAR2(P+6); ! TO OLABEL PL=EXTRN EXTRN=EXTRN+7 %WHILE A(EXTRN)=1 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+1 %UNLESS ROUT=1 %AND OLDI=LEVEL %AND J>=14 %THEN DECLARE PROC P=PP ->LABEL99 %IF EXTRN<=2 %OR J=14 JJ=-1; ! for id no (not used) %IF LEVEL=1 %THENSTART %IF CPRMODE=0 %THEN CPRMODE=2 FAULT(55,PNAME) %IF CPRMODE#2 PPROC(STRING(ADDR(LETT(WORD(PNAME)))),1 {ext},-1 {parm},JJ) %FINISHELSE PPROC("",0,-1 {pchkword},JJ) COPY TAG(PNAME) LINK=K; Q=ACC JJ=LINK; NP=FROM2(LINK); ! NO OF PARAMS<<16! paramspace J=0; REPLACE TAG(PNAME); ! TO RT BOBY GIVEN PRIVLABEL=PRIVLABEL-1 %UNLESS CPRMODE=2 %AND LEVEL=1 %START JROUND(LEVEL+1)=PRIVLABEL ENTER JUMP(15,PRIVLABEL,0) %FINISH PTYPEP=PTYPE RHEAD(PNAME) ! ! GO DOWN THE PARAMETER LIST OF THE PROCEDURE AND DECLARE THE ! PARAMETERS AS LOCAL VARIABLE AT THIS LEVEL ! MLINK(LINK) %WHILE LINK#0 %CYCLE FROM123(LINK,TYPEP,PARN,DISP) J=PARN>>16; PTYPE=TYPEP K=PARN&X'FFFF'; ACC=0; KFORM=LINK TEST NST; SNDISP=M'FP' ACC=BYTES(TYPE) %IF TYPE<=3 %AND ROUT=0 %IF PTYPE>=4096 %START; ! PROCEDURE PARAMETERS OPHEAD=0; JJ=J %WHILE JJ>0 %CYCLE INSERT ATEND(OPHEAD,FROM1(JJ),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 DUMPSI(MVI,BYTES(PTYPE&7),WSPR,0); ! flag for a-by-v subroutine DUMP(LA,3,DISP&X'FFFF',0,RBASE) PPJ(0,13) %FINISH DECMADE=1 MLINK(LINK) %REPEAT N=Q; ! TOTAL SPACE OCCUPIED BY SAVE !AREA AND PARAMS Q=PP+11 %IF NP>>16>0 %THEN Q=Q+4*NP>>16-1 MAKE DECS(Q,PTYPEP) P=PL; COLABEL %IF EXTRN=4 %THENSTART P=PE+1; LINE=LINEP; SET LINE CSTMNT; P=PP CEND(FLAG(LEVEL)) %FINISH LABEL99:%END ->LABEL1 SW(4): ! %ARRAY SW(5): ! SW(8): ! '%OWN' (TYPE)(OWNDEC) FAULT(40,0) %UNLESS NMDECS(LEVEL)=0 %RETURN SW(6): ! %BEGIN %BEGIN PTYPE=0 %IF LEVEL=1=RLEVEL %AND CPRMODE=0 %THENSTART JJ=-1 PPROC(MAINEP,x'80000001',0,JJ) L(1)=0; M(1)=0 CPRMODE=1 PIX RX(ST,15,0,11,60) PRR(LR,10,11) SET(RLEVEL)=PMARKER(2) RBASE=10; REGISTER(10)=-1 STACKBASE(1)=10<<16!4 N=64; NMAX=N FORGETM(16) PIX RX(LA,1,0,0,256); ! LA 1,256 PIX RS(SLL,1,0,0,19); ! SLL 1,19 PRR(SPM,1,0); ! SPM 1 PROGRAM MASK AS IMP PTYPE=1 %FINISH RHEAD(-1) MAKE DECS(P+1,-1) %END ->LABEL1 SW(7): ! %SWITCH := %BEGIN %INTEGER N,DIS,REP,I,PL,FLAG,SWNAME SWNAME=FROMAR2(P+1) COPYTAG(SWNAME) REP=0; N=SNDISP DIS=K+4 P=P+9 PRIVLABEL=PRIVLABEL-1 PL=PRIVLABEL %IF N<100 %THEN FLAG=B'11' %ELSE FLAG=B'10' ENTER JUMP(15,PL,FLAG) %CYCLE I=1,1,N PSLABEL(DIS,I) FORGETM(16) CDE(REP,2) P=P+3 %REPEAT ENTER LAB(PL,B'110',LEVEL) %END ->LABEL1 SW(9): ! : P=P+1; CLABEL; CSS(P) SW(10): ! %COMMENT %RETURN SW(11): ! %CODEON SW(12): ! %CODEOFF %RETURN SW(13): ! %SPECIALNAME J=0; PTYPE=SNPT SNDISP=0; ACC=0 Q=FROMAR2(P+1) STORE TAG(Q,SNUM) COPY TAG(Q) SNUM=SNUM+1 %RETURN SW(14): ! %RETURN %ROUTINE DECLARE OWNS !*********************************************************************** !* OWN DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES * !* ARRAYS HAVE A HEADER IN THE GLA. PUT 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,AH4,AD,NNAMES FAULT(40,0) %IF NMDECS(LEVEL)&1#0 P=P+6 NAM=0; ARR=A(P-1)-1; ROUT=0 ICONST1=0; ICONST2=0 TYPE=A(P); TYPE=2 %IF TYPE=4 ACC=BYTES(TYPE); P=P+2 PACK(PTYPE) ->NON SCALAR %UNLESS ARR=0 ! %UNTIL A(P-1)=2 %CYCLE; ! DOWN J=0; K=FROMAR2(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+3 %REPEAT ->LABEL99 NONSCALAR: ! OWN ARRAYS !*********************************************************************** !* P:= * !* P:=',',%NULL * !*********************************************************************** P=P+1; PP=P; NNAMES=1; ! P TO START OF DECLIST P=P+3 %AND NNAMES=NNAMES+1 %WHILE A(P+2)=1 P=P+3; BP=ACC ! ! NOW OUTPUT A DOPE VECTOR ! AH3=DOPE VECTOR(BP,QQ,LENGTH,AH4) %UNTIL NNAMES=0 %CYCLE K=FROMAR2(PP) CONSTPTR=(CONSTPTR+7)&(-8) ! ! 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. ! AH1=CONSTPTR-QQ AH2=CONSTPTR CLEAR(LENGTH) PGLA(4,16,ADDR(AH1)) TAGDISP=GLACA-16 RELOCATE(TAGDISP,AH1,5); ! RELOCATE ADDR(A(0)) RELOCATE(TAGDISP+4,AH2,5); ! RELOCATE ADDR(A(FIRST)) RELOCATE(TAGDISP+8,AH3,4); ! RELOCATE DV POINTER STAG(TAGDISP) PP=PP+3 NNAMES=NNAMES-1 %REPEAT %IF A(P)=1 %THEN P=P+2 %AND ->NONSCALAR ->LABEL99 %ROUTINE CLEAR(%INTEGER LENGTH) %INTEGER Z Z=0 LENGTH=(LENGTH+3)&(-4) PDPATTERN(5,CONSTPTR,LENGTH>>2,4,ADDR(Z)) %IF INHCODE=0 CONSTPTR=CONSTPTR+LENGTH %END %ROUTINE STAG(%INTEGER J) TEST NST SNDISP=0 RBASE=GLAREG STORE TAG(K,J) RBASE=11-RLEVEL %END LABEL99:%END; %ROUTINE MAKE DECS(%INTEGER PP,KK) !*********************************************************************** !* PP TO LIST OF LIKS:- * !* A(PP) = LINKS FOR LABELS, A(PP+4) = LINKS FOR SCALARS * !* A(PP+8) = LINK FOR ARRAYS, A(PP+12) = LINK FOR SWITCHES * !* A(PP+16) = LINK FOR OWN DECS,A(PP+20) = LINK FOR PROCEDURES * !* KK <0 FOR BEGIN BLOCKS >0 FOR PROCEDURES * !*********************************************************************** %INTEGER SAVELINE,Q,QQ,ARRAYS SAVELINE=LINE; ARRAYS=0 Q=PP+4; QQ=FROMAR4(Q) %WHILE QQ#0 %CYCLE; ! FIRST LOCAL SCALARS Q=QQ+Q-1 LINE=FROMAR2(Q-2) P=Q DECLARE SCALARS Q=Q+2 QQ=FROMAR4(Q) %REPEAT ! Q=PP+16; QQ=FROMAR4(Q) %WHILE QQ#0 %CYCLE; ! SECOND THE OWNS Q=Q+QQ P=Q-1; LINE=FROMAR2(P-2) DECLARE OWNS QQ=FROMAR4(Q) %REPEAT ! LINE=SAVELINE P=PP; DECLARE LABS; ! THE LABELS P=PP+12; DECLARE SWITCHES; ! AND SWITCHES Q=PP+20; QQ=FROMAR4(Q) %WHILE QQ#0 %CYCLE Q=QQ+Q; LINE=FROMAR2(Q-3) P=Q; DECLARE PROC Q=Q+1 QQ=FROMAR4(Q) %REPEAT ! Q=PP+8; QQ=FROMAR4(Q) %WHILE QQ#0 %CYCLE; ! THROUGH ARRAYS Q=Q+QQ-1 LINE=FROMAR2(Q-2) P=Q; DECLARE ARRAYS ARRAYS=1 Q=Q+2 QQ=FROMAR4(Q) %REPEAT ! LINE=SAVELINE %IF KK>=0 %OR ARRAYS#0 %OR LEVEL=2 %START Q=STACKBASE(LEVEL) DUMP(ST,WSPR,Q&X'FFFF',0,Q>>16) %FINISHELSESTART STACKBASE(LEVEL)=STACKBASE(LEVEL-1) %FINISH %END %ROUTINE DECLARE LABS !*********************************************************************** !* P IS TO HEAD OF LINKED LIST OF LABELS IN THIS BLOCK * !* THIS ROUTINE DECLARES ALL THE LABELS SO THAT A %GOTO CAN * !* BE CLASSIFIED AS INTERNAL OR EXTERNAL IMMEDIATELY * !*********************************************************************** %INTEGER Q,QQ QQ=FROMAR4(P) %WHILE QQ#0 %CYCLE Q=P+QQ K=FROMAR2(Q); P=Q+2; ! K IS NAME PTYPE=6; SNDISP=0 KFORM=0; J=0; ACC=4 TEST NST STORE TAG(K,0) QQ=FROMAR4(P) %REPEAT %END %ROUTINE DECLARE SWITCHES !*********************************************************************** !* P IS TO HEAD OF LINKED LIST AS FOR LABELS * !* THIS ROUTINE RESERVES SPACE IN THE SST FOR THE SWITCH AND * !* DECLARES THE NAME BUT NO CODE IS GENERERATED * !*********************************************************************** %INTEGER I,Q,N,MARK,QQ QQ=FROMAR4(P) %WHILE QQ#0 %CYCLE Q=P+QQ LINE=FROMAR2(Q-3) P=Q+2 K=FROMAR2(Q); N=1 MARK=P+4+FROMAR2(P+4) N=N+1 %AND MARK=MARK+1+FROMAR2(MARK+1) %WHILE A(MARK)=1 J=1; SNDISP=N; KFORM=0 ACC=4; PTYPE=1<<4!6; ! LABEL ARRAY TEST NST STORE TAG(K,SSTL) PD4(4,SSTL,N); ! bound on front PSWITCH(SSTL+4,1,N,4) SSTL=SSTL+4+4*N QQ=FROMAR4(P) %REPEAT %END %ROUTINE DECLARE PROC !*********************************************************************** !* P TO TYPE OF PROCEDURE * !* 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(%SHORTINTEGERNAME OPHEAD, %INTEGERNAME NP) %ROUTINESPEC CVALLIST(%SHORTINTEGERNAME OPHEAD, %INTEGER MODE) %ROUTINESPEC CCOMMENT %ROUTINESPEC CTYPELIST(%SHORTINTEGERNAME OPHEAD, %INTEGER MODE) %ROUTINESPEC CHECK FPS(%SHORTINTEGERNAME OPHEAD, %INTEGER MODE) %INTEGER PNAME,TYPEP,INC,I,N,CELL,NP,LINK,PSIMPLE,THUNKS,EPNAME,EXTRN %SHORTINTEGER OPHEAD,RTHEAD OPHEAD=0; NP=0 TYPEP=4096+A(P)&3 PNAME=FROMAR2(P+7) P=P+9; INC=1; ! TO ALT OF FPP CFPARAMS(OPHEAD,NP) P=P+29; ! PAST 7 HOLES TO VALUE LIST CVALLIST(OPHEAD,0) CTYPELIST(OPHEAD,0) P=P+1 %UNTIL A(P)=2 P=P+1 P=P+5 %WHILE A(P)=1; ! SKIP OLABEL (IF ANY) EXTRN=A(P+1) CHECK FPS(OPHEAD,0) J=15; I=0 %IF EXTRN<=2 %THENSTART J=14 %IF A(P+2)=1 %THEN EPNAME=FROMAR2(P+3) %ELSE EPNAME=PNAME CXREF(STRING(ADDR(LETT(WORD(EPNAME)))),I) %FINISH PUSH123(OPHEAD,I,NP<<16!(INC-64),THUNKS<<1!PSIMPLE) LINE=LINE+1 K=PNAME; SNDISP=LINE; ACC=INC PTYPE=TYPEP; TEST NST STORE TAG(K,OPHEAD) %RETURN %ROUTINE CFPARAMS(%SHORTINTEGERNAME OPHEAD, %INTEGERNAME NP) %WHILE A(P)=1 %CYCLE P=P+INC; NP=NP+1 K=FROMAR2(P); ! NAME %IF FIND(K,OPHEAD)>=0 %THEN FAULT(7,K) %ELSE INSERT ATEND(OPHEAD,256,K,0) ! TYPE=?NAME P=P+2; INC=2; ! P TO REST OF FPP %REPEAT %END %ROUTINE CVALLIST(%SHORTINTEGERNAME 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 %THENSTART; ! IF THERE IS A VALUE LIST LINE=LINE+1 P=P+1 %UNTIL A(P)=2 %OR MODE#0; ! PAST COMMENTS N=FROMAR2(P+1); P=P+3 %CYCLE I=1,1,N; ! DOWN THE NAELIST K=FROMAR2(P) CELL=FIND(K,OPHEAD) %IF CELL>0 %THEN REPLACE1(CELL,0) %ELSE FAULT(8,K) ! K NOT IN FPP P=P+2 %REPEAT %FINISHELSE P=P+1 %END %ROUTINE CTYPELIST(%SHORTINTEGERNAME 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=FROMAR2(P) CELL=FIND(K,OPHEAD) %IF CELL<0 %OR FROM1(CELL)&X'F0FF'#0 %THEN FAULT(9,K) %ELSESTART I=FROM1(CELL) REPLACE1(CELL,PTYPE!I) %IF PTYPE>=4096 %AND MODE=0 %START CCOMMENT REPLACE2(CELL,RTHEAD<<16!FROM2(CELL)) %FINISH %IF PTYPE<5 %AND I#0 %THEN ACCP=4 %ELSE ACCP=ACC REPLACE3(CELL,ACCP) %FINISH P=P+3 %REPEAT %IF PTYPE>=4096 %AND MODE=0 %START; ! SKIP OVER FUNNY COMMENT %IF A(P)=2 %THEN P=P+1 %ELSE P=P+1+FROMAR2(P+1) %AND LINE=LINE+1 %FINISH %REPEAT %END %ROUTINE CHECK FPS(%SHORTINTEGERNAME OPHEAD, %INTEGER MODE) !*********************************************************************** !* PASS DOWN THE LIST AGAIN CHECKING EVERYTHING HAS BEEN GIVEN * !* A VALID TYPE AND ALSO ASSIGNING PARAMETER DISPLACEMENTS * !*********************************************************************** INC=64; PSIMPLE=1; THUNKS=0 LINK=OPHEAD %WHILE LINK>0 %CYCLE FROM123(LINK,PTYPE,J,I) UNPACK %IF TYPE=6 %AND NAM=0 %THENSTART REPLACE1(LINK,PTYPE+256) NAM=1 WARN(3,J) %FINISH %IF 257<=PTYPE<=259 %AND MODE=0 %AND EXTRN=1 %THEN REPLACE1(LINK,PTYPE+256) %AND NAM=2 FAULT(10,J) %IF PTYPE=0 %OR PTYPE=256 %OR (ROUT=1 %AND NAM=0) PSIMPLE=0 %IF NAM=1 %OR ARR=1 %OR ROUT=1 %OR TYPE>=5 %OR TYPE=2 J=0 J=1 %IF NAM=1 %AND (ARR=0 %OR TYPE=6) %AND ROUT=0 %AND TYPE#5 THUNKS=THUNKS!J 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 NNP=0; PP=P; THUNKS=0; PSIMPLE=0 PTYPEP=PTYPE; ACCP=ACC LINEP=LINE; RTHEAD=0 P=P+3 %WHILE A(P+2)=1; ! FIND END OF DECLIST P=P+3 %IF A(P)=1 %THENSTART; ! THERE IS A COMMENT INC=3 CFPARAMS(RTHEAD,NNP) P=P+1 CVALLIST(RTHEAD,1) LINE=LINEP CTYPELIST(RTHEAD,1) LINE=LINEP CHECKFPS(RTHEAD,1) %FINISHELSE INC=64 PUSH123(RTHEAD,0,NNP<<16!(INC-64),THUNKS<<1!PSIMPLE) P=PP; PTYPE=PTYPEP; ACC=ACCP %END %ROUTINE CFP !*********************************************************************** !* SETS PTYPE AND ACC FOR EACH ALT OF FORMAL PARAMETER * !*********************************************************************** %SWITCH ALT(1:6) ->ALT(A(P)) ALT(1): ! %LABEL PTYPE=6; ->LABEL97 ALT(2): ! %SWITCH PTYPE=22; ->LABEL97 ALT(3): ! %STRING PTYPE=5; ACC=8; P=P+1; ->LABEL99 ALT(4): !(TYPE')(%ARRAY) ARR=1; ROUT=0; NAM=0 TYPE=A(P+1); P=P+2; ACC=16 TYPE=2 %IF TYPE=4 PACK(PTYPE); ->LABEL99 ALT(5): ! (TYPE')(PROCEDURE) ROUT=1; NAM=0; ARR=0; ACC=4 TYPE=A(P+1)&3; P=P+2 PACK(PTYPE); ->LABEL99 ALT(6): ! (TYPE) PTYPE=A(P+1) ACC=BYTES(PTYPE) P=P+2; ->LABEL99 LABEL97:ACC=4 P=P+1 LABEL99:%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.PERMIT#0 FOR PARAMS WHICH * !* MUST NOT BE SET TO UNASSIGNED * !* P POINTS TO THE DECLIST ON ENTRY AND IS UPDATED. * !*********************************************************************** %INTEGER INC,ROUND,NIN TYPE=A(P+1) ROUT=0; NAM=0; ARR=0 P=P+7 PACK(PTYPE); J=0; NIN=N INC=4 %IF ROUT=0 %AND ARR=0 %THEN INC=BYTES(TYPE) %IF INC=16 %THEN ROUND=4 %ELSE ROUND=INC N=(N+ROUND-1)&(-ROUND) %UNTIL A(P-1)=2 %CYCLE; ! DOWN THE NAMELIST K=FROMAR2(P); TEST NST SNDISP=0; KFORM=0 STORE TAG(K,N) N=N+INC P=P+3 %REPEAT BULKM(0,N-NIN,RBASE,NIN,0,UNASSPAT&255) %IF UNASS=1 %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 * !*********************************************************************** %INTEGER DVDISP,PP,DVF,ELSIZE,TOTSIZE,L,PTYPEP,ARRP,NN,ND,II,JJ,QQ,CDV SET LINE TYPE=A(P+1) TYPE=2 %IF TYPE=4 NAM=0; ROUT=0; ADFLAG=1 P=P+8 ARRP=1; ARR=ARRP; PACK(PTYPEP) ELSIZE=BYTES(TYPE) START:NN=1; ! FIND NO OF NAMES IN NAMELIST PP=P; CDV=0 P=P+3 %AND NN=NN+1 %WHILE A(P+2)=1 P=P+3; ! 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+8; ! CLAIM SPACE FOR THE D-V FAULT(37,0) %IF ND>12; ! TOO MANY DIMENSIONS ! DUMP(LA,-2,ELSIZE,0,0) REGISTER(NEST)=1 DUMP(ST,NEST,DVDISP+8,0,RBASE) DUMP(ST,NEST,DVDISP+20,0,RBASE); ! also as stride 1 DUMP(LA,NEST,ND,0,0) %UNLESS ND=ELSIZE DUMP(ST,NEST,DVDISP,0,RBASE) FREE AND FORGET(NEST) ! %CYCLE II=1,1,ND P=P+1 QQ=12*II+DVDISP TYPE=1; PTYPE=1 ! ASSIGN(2, RBASE<<16!QQ); ! ASSIGN LOWER BOUND TO DVITEM CSEXP(-1,1) REGISTER(NEST)=1 DUMP(ST,NEST,QQ,0,RBASE) REGISTER(NEST)=0 CSEXP(-1,1); ! GET UPPER BOUND TO REG REGISTER(NEST)=1 DUMP(ST,NEST,QQ+4,0,RBASE); ! STUFF INTO DV DUMP(ISUB,NEST,QQ,0,RBASE); ! SUBTRACT LOWER BOUND DUMP(IADD,NEST,PLABS(1)+60,0,CODER) ! A NEST,=F'1' DUMP(MH,NEST,QQ-2,0,RBASE); ! multiply by size or lower stride %IF II=ND %THEN DUMP(ST,NEST,DVDISP+4,0,RBASE) %ELSE DUMP(ST,NEST,QQ+20,0,RBASE) ! STORE RANGE FREE AND FORGET(NEST) %REPEAT P=P+1 DUMP(LA,2,DVDISP,0,RBASE) RUN TIME: ! ALLOCATE SPACE AT RUN TIME ! R2 POINTS TO D-V DVF=0; ! NOT VECTORS PIX RX(ST,2,0,GLAREG,36); ! PUT POINTER INTO GLA ->DECL CONSTDV: ! ONE DIMENSION - CONSTANT !BOUNDS DVF=1; P=P+1; CDV=1 DVDISP=DOPE VECTOR(ELSIZE,L,TOTSIZE,II); ! AND GENERATE A D-V ND=J ! II=DVDISP-GRINF(2) %UNLESS GRUSE(2)=17 %AND II>=0 %THENSTART PIX RX(LGR,2,0,GLAREG,12); ! LOAD R2,POINTER TO SST FORGET(2) II=DVDISP %FINISH ! REGISTER(2)=1 DUMP(LA,2,II,0,2) %UNLESS II=0 REGISTER(2)=0 ->RUNTIME DECL: ! MAKE DECLN - BOTH WAYS PTYPE=PTYPEP+100*DVF; ! ARR=2 FOR VECTORS =3 FOR !FORMAT J=ND %CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST %IF ND=1 %THEN JJ=11 %ELSE JJ=12 PPJ(0,JJ); FORGET(4) SNDISP=0 ! ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD KFORM=0 K=FROMAR2(3*JJJ+PP); TEST NST STORE TAG(K,N) REGISTER(1)=1; ! MUST LOCK REGISTERS CONTAINING REGISTER(2)=1; ! ARRAYHEAD IN CASE 4K MULTIPLE REGISTER(3)=1; ! NEEDED TO STORE ARRAYHEAD DUMPM(STM,0,3,RBASE,N) %CYCLE II=0,1,3 FREE AND FORGET(II); ! NOW FORGET REGISTERS %REPEAT N=N+16 %REPEAT %IF CDV#0 %THEN SET USE(2,17,DVDISP) P=P+1; ! PAST REST OF ARRAYLIST N=(N+3)&(-4) %IF A(P-1)=1 %THEN P=P+2 %AND ->START ADFLAG=0 %END %INTEGERFN DOPE VECTOR(%INTEGER ELSIZE, %INTEGERNAME A00,SIZE,MULT) !*********************************************************************** !* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE * !* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT* !* EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE * !* P IS TO ALT (MUST BE 1!) OF P * !*********************************************************************** %INTEGER I,K,ND,M0 %INTEGERARRAY DV(0:38); ! ENOUGH FOR 12 DIMENSIONS ND=0; A00=0; M0=ELSIZE; SIZE=1 %UNTIL A(P)=2 %CYCLE CBPAIR(I,J) K=3*ND+3 DV(K)=I; DV(K+1)=J DV(K+2)=M0; M0=M0*(J-I+1) A00=A00-I*DV(K+2) ND=ND+1 %REPEAT SIZE=M0 P=P+1 DV(0)=ND DV(1)=(SIZE+7)&(-8) DV(2)=ELSIZE K=12*ND+12 I=SSTL PDBYTES(4,SSTL,K,ADDR(DV(0))) %IF INHCODE=0 SSTL=SSTL+K %IF ND=2 %THEN MULT=DV(8) %ELSE MULT=ELSIZE J=ND; ! DIMENSIONALITY FOR DECLN %RESULT=I %END %ROUTINE TEST NST !*********************************************************************** !* SEE IF NAME 'K' HAS BEEN DECLARED BEFORE AT THIS LEVEL * !*********************************************************************** FNAME=K FAULT(7,FNAME) %IF FROM1(TAGS(FNAME))>>8&15=LEVEL %END %ROUTINE RT JUMP(%INTEGER CODE,R1,LINK) !*********************************************************************** !* PLANTS A 'BAL' TO THE APPROPIATE ENTRY ADDRESS IN ASL(LINK) * !* THE CODING ASSUMES I,J&OLDI ARE SET UP FOR THE CALLED ROUTINE * !*********************************************************************** %INTEGER DP,AD,WKREG %SHORTINTEGER HEAD FINDREG(GR1,WKREG) AD=ADDR(ASLIST(LINK)) DP=INTEGER(AD) %IF DP=0 %START; ! label not allocated DP=GLABEL; GLABEL=GLABEL-1 INTEGER(AD)=DP %FINISH PJUMP(CODE,DP,R1,WKREG) %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 * !*********************************************************************** %SHORTINTEGER OPHEAD %INTEGER KP,BIT %ROUTINESPEC DTABLE(%INTEGER LEVEL) BIT=1<=0 %IF A(P)=1 %AND KKK>=-1 %THEN FAULT(47,0) CCSTATE=-1 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) I=I>>24 %IF I&2=0 %THENSTART FAULT(12,KP) %FINISH %REPEAT ! %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK) RETURN WSP(JJ,KK) %REPEAT %CYCLE J=1,1,4 CLEAR LIST(AVL WSP(J,LEVEL)) ! RELEASE TEMPORARY LOCATIONS %REPEAT ! DTABLE(LEVEL) %unless kkk=-3; ! OUTPUT DIAGNOSTIC TABLES ! ! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED ! DESTROY SIDE CHAINS FOR ROUTINES,FORMATS AND SWITCHES ! ->SKIP %IF DECMADE=0 %CYCLE JJ=0,1,NNAMES %IF NTYPE(JJ)&BIT#0 %THENSTART NTYPE(JJ)=NTYPE(JJ)!!BIT; ! FIND A LOCAL NAME KK=FROM1(TAGS(JJ)) ABORT %UNLESS KK>>8&63=LEVEL COPY TAG(JJ); ! AND EXAMINE IT POP(TAGS(JJ),KK,KK); ! LET NAME REVERT TO PREVIOUS !USE %IF ROUT=1 %THENSTART POP(K,KK,KK) %WHILE K>0 %CYCLE OPHEAD=FROM2(K)>>16 %IF FROM1(K)>=4096 %THEN CLEAR LIST(OPHEAD) POP(K,KK,KK) %REPEAT %FINISH %FINISH %REPEAT SKIP: ! ! NOW CLAIM THE STACK FRAME BY FILING THE LA 11,0(11) IN THE BLOCK ENTRY ! CODING. IF MORE THAN 4095 BYTES OF LOCAL VARIABLES ARE NEEDED THEN ! THE WHOLE INSTRUCTION MUST BE OVERWRITTEN ! NMAX=(NMAX+7)&(-8) %IF KKK=2 %THENRETURN JJ=SET(RLEVEL) %IF KKK>=4096 %OR KKK=1 %THENSTART %IF 4096>NMAX %THENSTART PSETOPD(JJ,0,x'41bb') PSETOPD(JJ,1,NMAX) %ELSE PSETOPD(JJ,0,X'5ABC') PSETOPD(JJ,1,8+NMAX>>12<<2) %FINISH %FINISH ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! %IF KKK>=4096 %THENSTART; ! PROCEDURE END JJ=KKK&7 %IF JJ#0 %THENSTART %IF JJ=2 %THEN KP=0 %ELSE KP=1 DUMP(LGR+HOPCODE(JJ),KP,8,0,RBASE); ! LOAD RESULT %IF UNASS#0 %THEN DUMP(ICP+HOPCODE(JJ),KP,PLABS(1)+48,0,CODER) %AND %C CCSTATE=-1 %AND PPJ(8,5) %FINISH PIX RS(LM,4,15,RBASE,16); ! LM 4,15,OLD REGS PRR(BCR,15,15); ! BR 15 PPROCEND %FINISH %IF KKK<=0 %THENSTART; ! BEGIN BLOCK EXIT JJ=STACKBASE(LEVEL-1) %IF JJ#STACKBASE(LEVEL) %THEN DUMP(LGR,WSPR,JJ&X'FFFF',0,JJ>>16) JJ=FROM2(LEVELINF)&X'FFF'; ! DISP OF SAVE AREA %IF DIAGS1=1 %and kkk#-3 %START; ! RESTORE DIAGS POINTERS DUMP(LGR,0,JJ+4,0,RBASE) PIX RX(ST,0,0,RBASE,0) FORGET(0) %FINISH %FINISH ! ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE ! ! %UNLESS LEVEL>2 %OR (LEVEL=2 %AND CPRMODE=2) %THENSTART %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %AND PPROCEND %ELSE FAULT(14,0) %ANDSTOP %FINISH LEVEL=LEVEL-1 %IF KKK>=4096 %THENSTART RLEVEL=RLEVEL-1 RBASE=11-RLEVEL REGISTER(10-RLEVEL)=0 %FINISH ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! POP123(LEVELINF,JJ,N,DECMADE) NMAX=N>>16 %IF KKK>=4096 N=N&X'7FFF' %IF KKK=2 %THEN CEND(KKK); ! ROUND AGAIN FOR 'ENDOFPROGRAM' ! ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN ! %TRUSTEDPROGRAM IS IN OPERATION. ! %IF KKK>=4096 %AND (RLEVEL#1 %OR CPRMODE#2) %THEN ENTER LAB(JROUND(LEVEL+1),0,LEVEL) ->LABEL99 %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.* !*********************************************************************** %CONSTBYTEINTEGERARRAY DTYPE(0:7)=x'51'(2),x'62',x'51'(*); %STRING (11) RT NAME %STRING (11) LOCAL NAME %INTEGER DPTR,LNUM,ML,KK,JJ,Q %INTEGERARRAY DD(0:300); ! BUFFER FOR SEGMENT OF SST DD(0)=L(LEVEL)<<16; !stmnt(line no) ML=M(LEVEL); ! ROUTINE NAME(=0 FOR %BEGIN) LNUM=LETT(ML); ! LENGTH OF THE NAME %WHILE DHEADS(LEVEL)#0 %CYCLE POP123(DHEADS(LEVEL),Q,JJ,KK) %IF Q=1 %START; !code area forward ref PSETOPD(JJ,0,MVI<<8!(DTPTR>>8&255)) PSETOPD(JJ,1,RBASE<<12) PSETOPD(JJ,2,MVI<<8!(DTPTR&255)) PSETOPD(JJ,3,RBASE<<12!1) %ELSE PD4(Q,JJ,KK!DTPTR) %FINISH %REPEAT DD(1)=LEVEL<<18; ! RT WORD TO TABLE jj=level-1 jj=jj-1 %while flag(jj)=-3 PUSH123(DHEADS(jj),6,DTPTR+4,DD(1)) DD(2)=RLEVEL<<16 DPTR=4 %IF LNUM=0 %THENSTART JJ=LEVEL-1 JJ=JJ-1 %WHILE L(LEVEL)=L(JJ) %AND JJ>1 DD(3)=0 %FINISHELSESTART Q=ADDR(LETT(ML)) RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST LNUM=BYTEINTEGER(ADDR(RTNAME)) DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS %FINISH DD(DPTR)=0; ! no on events in algol DPTR=DPTR+1 ->SKIP %IF DECMADE=0 %CYCLE JJ=0,1,NNAMES; ! THROUGH DECLARATIONS %IF NTYPE(JJ)&BIT#0 %START %IF FROM1(TAGS(JJ))&X'C000'=0 %THEN WARN(2,JJ) COPY TAG(JJ); ! GET DETAILS %IF LINENOS#0 %AND ARR=0 %AND ROUT=0 %AND DPTR<297 %AND NAM=0 %AND %C (1<=TYPE<=3 %OR TYPE=5) %START NAM=1 %IF TYPE=5 %IF I=0 %THEN I=1 %ELSE I=0 Q=ADDR(LETT(WORD(JJ))); ! ADDRESS OF NAME DD(DPTR)=NAM<<28!DTYPE(TYPE)<<20!I<<18!K LOCAL NAME<-STRING(Q); ! TEXT OF NAME FROM DICTIONARY LNUM=BYTE INTEGER(ADDR(LOCAL NAME)) STRING(ADDR(DD(DPTR))+4)=LOCAL NAME ! MOVE IN NAME DPTR=DPTR+(LNUM+8)>>2 %FINISH %FINISH %REPEAT SKIP: DD(DPTR)=-1; ! 'END OF SEGMENT' MARK DPTR=DPTR<<2+4 %IF DIAGS1=1 %THENSTART PDBYTES(6,DTPTR,DPTR,ADDR(DD(0))); ! ADD TO SHARABLE SYM TABS DTPTR=DTPTR+DPTR %FINISH %END; ! OF ROUTINE DTABLE LABEL99:%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,W2,W3,BASED,AT,WK,J PUSH123(LEVELINF,0,NMAX<<16!N,DECMADE) %IF LEVEL>1 %THEN REMOVE LABS LEVEL=LEVEL+1 DHEADS(LEVEL)=0 NMDECS(LEVEL)=0; DECMADE=0 %IF KK>=0 %THENSTART RLEVEL=RLEVEL+1; RBASE=11-RLEVEL FAULT(35,0) %IF RBASE=3 %OR REGISTER(RBASE)#0 FORGET(RBASE); REGISTER(RBASE)=-1 %FINISH FAULT(34,0) %IF LEVEL=MAX LEVELS FAULT(105,0) %IF LEVEL>MAX LEVELS %IF KK<0 %THENSTART; ! BEGIN BLOCKS STACKBASE(LEVEL)=RBASE<<16!N N=N+8; W2=N-4 %FINISH %IF KK>=0 %THENSTART; ! ROUTINE ENTRY J=FROM1(JJ) %IF J=0 %AND LEVEL>2 %START; ! REPLACE 'NOT USED' BIT REPLACE1(TAGS(KK),FROM1(TAGS(KK))&X'FFFF3FFF') J=GLABEL GLABEL=GLABEL-1 REPLACE1(JJ,J) %FINISH PLABEL(J) PIX RX(ST,15,0,11,60); ! SAVE LINK -- ST 15,60(11) W2=0 %FINISH %IF KK>=0 %OR LEVEL=2 %THEN STACKBASE(LEVEL)=RBASE<<16!4 PRR(LR,RBASE,WSPR) %UNLESS KK<0 %IF KK<0 %THEN W3=0 %ELSE W3=WORD(KK) L(LEVEL)=LINE; M(LEVEL)=W3 FLAG(LEVEL)=PTYPE; ! CURRENT BLOCK TYPE MARKER %IF KK>=0 %THENSTART SET(RLEVEL)=PMARKER(2) N=64; NMAX=N FORGETM(16); ! START NEW RT W CLEAN SLATE CCSTATE=-1 %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 DIAGS1#0 %AND LINE>0 %and ptype#-3 %START %IF KK<0 %THEN PIX RX(LGR,0,0,RBASE,0) %AND DUMP(ST,0,W2,0,RBASE) W1=PMARKER(4) PUSH123(DHEADS(LEVEL),1,W1,0) FORGET(0); ! NEEDED FOR %BEGIN BLOCKS %FINISH MONE=1; SET LINE; ! NOW UPDATE LINE NUMBER %IF KK>=0 %AND CHECKSP#0 %START; ! CHECK FOR STACK O'FLOW PIX RX(LGR,2,0,GLAREG,28); ! load addr (top of stk) PIX RX(ICP,11,0,2,0) PPJ(2,8) PSS(MVC,8,RBASE,8,CODER,PLABS(1)+48); ! unass pat (why?) %FINISH %END; ! OF ROUTINE RHEAD %ROUTINE REMOVE LABS !*********************************************************************** !* WORKS DOWN THE CURRENT LABEL LIST REMOVING ALL ENTRIES * !* THAT HAVE STREAM3 (LABEL NO) SET TO ZERO. THIS IS SET WHEN * !* AN INTERNAL LABEL IS USED AS THEY ARE USED ONCE ONLY * !*********************************************************************** %SHORTINTEGER HEAD %INTEGER S1,S2,LAB HEAD=0 %WHILE LABEL(LEVEL)#0 %CYCLE POP123(LABEL(LEVEL),S1,S2,LAB) PUSH123(HEAD,S1,S2,LAB) %IF LAB&X'FFFF'#X'FFFF' %REPEAT LABEL(LEVEL)=HEAD %END %ROUTINE CLABEL !*********************************************************************** !* P POINTS TO IN * !*********************************************************************** %INTEGER LNAME,T,USE LNAME=FROMAR2(P) %IF LEVEL>1 %THENSTART; ! LABELS BEFORE 1ST BEGIN T=TAGS(LNAME); USE=FROM1(T) COPY TAG(LNAME) %UNLESS TYPE=6 %AND ARR=0=NAM %AND K=0 %THEN FAULT(2,LNAME) REPLACE1(T,USE); ! STOP LABEL BEING MARKED 'USED' ENTER LAB(LNAME,0,OLDI) %FINISH P=P+6 %END %ROUTINE COLABEL !*********************************************************************** !* P POINTS TO ALT OF P * !*********************************************************************** P=P+1 %AND CLABEL %WHILE A(P)=1 P=P+1 %END %ROUTINE CBLK(%INTEGER BLKTYPE) !*********************************************************************** !* SUCK IN A BLOCK OCCURRING IN IF..THEN ETC * !*********************************************************************** %INTEGER I,OLDLEV PTYPE=BLKTYPE OLDLEV=LEVEL; RHEAD(-1) MAKE DECS(P,-1) %UNTIL LEVEL=OLDLEV %CYCLE; ! TILL CORRESPONDING END I=NEXTP; NEXTP=NEXTP+FROMAR2(NEXTP) LINE=FROMAR2(I+2) CSS(I+4) RECODE %IF DCOMP#0 %REPEAT P=I+5; ! 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 P=P+1 %WHILE A(P)=1; ! PAST ANY COMMENTS P=P+1; COLABEL LINE=LINE+1 SET LINE CSTMNT %CYCLE I=NEXTP; NEXTP=NEXTP+FROMAR2(NEXTP) LINE=FROMAR2(I+2) P=I+4 P=P+1 %AND CLABEL %WHILE A(P)=9 I=P-4 %IF LEVEL=OLDLEVEL %AND A(P)=2 %THENEXIT CSS(P) RECODE %IF DCOMP#0 %REPEAT P=I+5; ! 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,FPL,FP,FCMPLX,FBP FBP=P+2+FROMAR2(P+2) FORLISTE=A(FBP); ! =2 IF ONE ELEMENT LIST %IF FORLISTE=2 %THENSTART FBP=FBP+1 FBP=FBP+7 %WHILE A(FBP)=1 FBP=FBP+1 %FINISH FORNAME=FROMAR2(P+4) FP=P+4; P=FP+1 COPYTAG(FORNAME) FCMPLX=ROUT!NAM!ARR FAULT(25,FORNAME) %UNLESS 1<=TYPE<=2 %AND ARR=ROUT=0 %AND A(P+1)=3 FORTYPE=TYPE; P=P+1 %IF A(P)#3 %THEN SKIP APP %AND P=P-1 PRIVLABEL=PRIVLABEL-1; FPL=PRIVLABEL %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 %INTEGER CNSTSTEP,STEPVAL,COPCODE,CXTRA,JFLAG %SHORTINTEGER OPHEAD,NOPS %SWITCH FALTNO(1:3) OPHEAD=0; CNSTSTEP=0 CONTROLRP=FORTYPE<<16!FCMPLX<<8!2 PUSH(OPHEAD,31,0) PUSH(OPHEAD,CONTROLRP,FP) NOPS=1; ETORP(OPHEAD,NOPS,FORTYPE) JFLAG=B'11'; ! SHORT & MERGE JFLAG=B'10' %IF FORLISTE=2 %AND ((A(FBP)=1 %AND FROMAR4(FBP+25)>500) %OR (A(FBP)=2 %AND %C 4#A(FBP+1)#1)) ! NOT SHORT IF BODY IS INCLUDED ! AND BODY=BEGIN,FOR OR IF FALT=A(P); 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+4)=2 %AND A(P+5)=1 %AND A(P+8)!A(P+9)#0 %AND A(P+10)=2 %THENSTART CNSTSTEP=1; STEPVAL=FROMAR4(P+6) %IF A(P+3)=2 %THEN STEPVAL=-STEPVAL P=P+11 STEPRP=1<<16!1 STEPTMP=STEPVAL %FINISHELSESTART GET WSP(STEPTMP,FORTYPE); ! TEMPORARY FOR STEP STEPRP=FORTYPE<<16!RBASE<<8!9; ! REVERSE POLISH DESCRPTR %FINISH PP=P; EXPOP(OPHEAD,-1,NOPS,FORTYPE!16) P=PP; CLEAR LIST(OPHEAD) ! ! EVALUATE STEP AND ASSIGN TO TEMPORARY ! STEPP=P %IF CNSTSTEP=0 %THENSTART PUSH(OPHEAD,31,0) PUSH(OPHEAD,STEPRP,STEPTMP) NOPS=1; ETORP(OPHEAD,NOPS,FORTYPE) PP=P; EXPOP(OPHEAD,-1,NOPS,FORTYPE!16) P=PP; CLEAR LIST(OPHEAD) %FINISH PRIVLABEL=PRIVLABEL-1; QQ=PRIVLABEL ENTER LAB(QQ,0,LEVEL); ! LABEL FOR REPEATING ! ! EVALUATE (V-C)*SIGN(D) ! COPCODE=27; CXTRA=5; ! '<=' %IF STEPVAL<0 %THEN CXTRA=2; ! '>=' %IF CNSTSTEP=0 %THENSTART PUSH(OPHEAD,19,0); ! MULTIPLY PUSH(OPHEAD,14,0); ! SIGN PUSH(OPHEAD,STEPRP,STEPTMP) COPCODE=16; ! '-' %FINISH PUSH(OPHEAD,COPCODE,CXTRA) NOPS=3; ETORP(OPHEAD,NOPS,FORTYPE) PUSH(OPHEAD,CONTROLRP,FP) NOPS=NOPS+1 PP=P; EXPOP(OPHEAD,-1,NOPS,FORTYPE) P=PP; CLEAR LIST(OPHEAD) PRIVLABEL=PRIVLABEL-1; FEXITPL=PRIVLABEL %IF COPCODE=16 %START %IF CCSTATE&X'FFFF'#NEST+HOPCODE(TYPE) %THEN PRR(LTR+HOPCODE(TYPE),NEST,NEST) %IF CNSTSTEP#0 %AND STEPVAL<0 %THEN MASK=4 %ELSE MASK=2 %FINISH ENTER JUMP(MASK,FEXITPL,JFLAG) INTO FOR ! ! INCREMENT CONTROL BY STEP ! P=STEPP; NOPS=1 PUSH(OPHEAD,31,0); ! ASSIGN INCREMENTED VAL TO CNTRL PUSH(OPHEAD,CONTROLRP,FP) PUSH(OPHEAD,15,0); ! ADD INCREMENT TO CNTRL PUSH(OPHEAD,CONTROLRP,FP) %IF CNSTSTEP=0 %THEN PUSH(OPHEAD,30,0); ! ASSN STEP TO TMP PUSH(OPHEAD,STEPRP,STEPTMP) %IF CNSTSTEP=0 %THEN ETORP(OPHEAD,NOPS,FORTYPE); ! EVALUATE VARIABLE STEP EXPOP(OPHEAD,-1,NOPS,FORTYPE!16) P=PP; CLEAR LIST(OPHEAD) ENTER JUMP(15,QQ,0) ENTER LAB(FEXITPL,B'111',LEVEL) P=PP; %RETURN FALTNO(2): ! WHILE PRIVLABEL=PRIVLABEL-1; QQ=PRIVLABEL ENTER LAB(QQ,0,LEVEL) PP=P; EXPOP(OPHEAD,-1,NOPS,FORTYPE!16) CLEAR LIST(OPHEAD) P=PP; CCOND PRIVLABEL=PRIVLABEL-1; FEXITPL=PRIVLABEL ENTER JUMP(MASK,FEXITPL,JFLAG) 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 EXPOP(OPHEAD,-1,NOPS,FORTYPE!16) P=PP; CLEAR LIST(OPHEAD) INTO FOR FORGETM(16) %END %ROUTINE INTOFOR %IF FORLISTE#2 %THENSTART ENTERJUMP(31,FPL,1) FORGETM(16) %FINISHELSESTART P=P+1 C FOR BODY %FINISH %END %ROUTINE C FORBODY !*********************************************************************** !* A FOR BODY IS NORMALLY ENTERED BY A BAL ON GR15 * !*********************************************************************** %INTEGER RAD,FBALT,I,PL %IF FORLISTE#2 %THENSTART PRIVLABEL=PRIVLABEL-1; PL=PRIVLABEL ENTER JUMP(15,PL,B'10') ENTER LAB(FPL,0,LEVEL) FORGETM(16) GET WSP(RAD,1); ! 1 WORD TO SAVE RERURN ADDR DUMP(ST,15,RAD,0,RBASE) %FINISH PTYPE=-3; I=P RHEAD(-1) STACKBASE(LEVEL)=STACKBASE(LEVEL-1); ! NO DECS WITHOUT BEGIN COLABEL FBALT=A(P); P=P+1 %IF FBALT=1 %THENSTART; ! %BEGIN CBLK(-2) %FINISHELSESTART CSTMNT %FINISH CEND(FLAG(LEVEL)) %IF FORLISTE#2 %THENSTART DUMP(LGR,15,RAD,0,RBASE) PRR(BCR,15,15) 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 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 PRIVLABEL=PRIVLABEL-1; PL1=PRIVLABEL 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 ENTER LAB(PL1,B'11',LEVEL) %ANDRETURN; ! MERGE %IF SALT=2 %THEN FAULT(47,0); ! ELSE CANNOT FOLLOW %FOR PRIVLABEL=PRIVLABEL-1; PL2=PRIVLABEL ENTER JUMP(15,PL2,B'10') ENTER LAB(PL1,B'111',LEVEL); ! REPLACE P=P+1; COLABEL SALT=A(P); P=P+1 %IF SALT#1 %THEN CSTMNT %ELSESTART 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 %SWITCH ALT(1:3) %SHORTINTEGER OPHEAD,NOPS %INTEGER TYPEP,LPALT,LPNAM,STOREOP,JJ,KK,LP ->ALT(A(P)) ALT(1): ! ASSIGNMENT OPHEAD=0; NOPS=0 COPY TAG(FROMAR2(P+1)) TYPEP=TYPE; STOREOP=31; ! ALLOW MVC ON SINGLE LPLS LPALT=A(P+3) %IF (LPALT=1 %AND TYPE#3) %OR (LPALT=2 %AND TYPE>=3) %THEN FAULT(202,0) ! ! 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+3)=A(P+2); A(P+2)=A(P+1); P=P+2 AGN: LPNAM=FROMAR2(P) COPY TAG(LPNAM) FAULT(29,LPNAM) %UNLESS TYPE=TYPEP %IF ARR=1 %THENSTART CNAME(1,-1) PUSH(OPHEAD,32,LPNAM) POP(RDHEAD,I,J) PUSH(OPHEAD,I,J) %IF I&255=9 %AND J<0 %START I=I>>8&255 REGISTER(I)=1 SET USE(I,1,OPHEAD) %FINISH %FINISHELSESTART PUSH(OPHEAD,STOREOP,0) JJ=PTYPE<<16!2; KK=P %IF ROUT=1 %AND A(P+2)=3 %START %CYCLE LP=LEVEL,-1,1 %IF WORD(LPNAM)=M(LP) %START JJ=(PTYPE&7)<<16!(I-1)<<8!9 KK=8; %EXIT %FINISH %REPEAT %IF LEVEL=1 %THEN FAULT(29,LPNAM) %FINISH PUSH(OPHEAD,JJ,KK) P=P+2; SKIP APP %FINISH STOREOP=30; NOPS=NOPS+1 %IF A(P)=1 %THEN P=P+1 %AND ->AGN P=P+1 ETORP(OPHEAD,NOPS,TYPEP) LP=P EXPOP(OPHEAD,-1,NOPS,TYPEP!16) P=LP CLEAR LIST(OPHEAD) %RETURN ALT(2): ! PROCEDURE CALL P=P+1 CNAME(0,0) %RETURN ALT(3): ! %GOTO P=P+1; JJ=0 CDE(JJ,0) %END %ROUTINE GOTOLAB(%INTEGERNAME REPORT, %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! * !*********************************************************************** %INTEGER LNAM,SB,B,D,PL,REG,OP,PP,F,LB LNAM=FROMAR2(P); P=P+2; ! LNAM =LABEL(SWITCH)NAME PP=P COPYTAG(LNAM) %IF A(P)=2 %THEN F=22 %AND ->ERROR %IF ARR=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(OLDI) LB=L(OLDI); ! BLOCKNO OF CURRENT BLK B=I; D=K ! ->SWITCH %IF ARR=1; ! SWITCHES %IF A(P)=1 %THEN F=4 %AND ->ERROR P=P+1 %IF NAM=1 %THENSTART; ! LABEL BY NAME PROTECT ST(CALL THUNKS,0,B,D) REPORT=1 %RETURN %FINISH %IF K#0 %THENMONITORANDSTOP; ! LABEL BY VALUE ! ! IF JUMPING OUT OF A BLOCK IT MAY BE NECESSARY TO RESET BLOCK NO ! AND/OR THE TOP OF STACK POINTER ! %IF LB#L(LEVEL) %AND DIAGS1#0 %START DUMP(LA,-1,L(LEVEL),0,0) DUMP(STH,NEST,20,0,13) FORGET(NEST) %FINISH ! %IF SB#STACKBASE(LEVEL) %OR MODE#0 %START; ! JUMP OUT OF BLOCK DUMP(LGR,WSPR,SB&X'FFFF',0,SB>>16) %FINISH ENTER JUMP(15,LNAM,0) %RETURN ERROR:FAULT(F,LNAM) P=PP; SKIP APP; %RETURN ! SWITCH: ! GOTO SWITCH REPORT=1; P=P+1; ! SWITCHES CAN BE NO-OPS %IF NAM=1 %THENSTART CSEXP(1,1) %UNLESS MODE=3 PROTECT ST(CALL THUNKS,0,B,D); ! CAN RETURN %FINISHELSESTART %IF MODE=2 %THEN REGISTER(14)=1 %IF MODE=3 %THEN NEST=1 %ELSE CSEXP(-2,1) REGISTER(NEST)=1 PRIVLABEL=PRIVLABEL-1; PL=PRIVLABEL FINDREG(GR1,REG) FORGET(REG) DUMP(LGR,REG,12,0,GLAREG); ! POINTER TO SST REGISTER(REG)=1 PRR(LTR,NEST,NEST) %IF MODE=2 %THEN PRR(BCR,12,14) %ELSE ENTER JUMP(12,PL,1) DUMP(ICP,NEST,D,0,REG) %IF MODE=2 %THEN PRR(BCR,2,14) %ELSE ENTER JUMP(2,PL,1) PIX RS(SLL,NEST,0,0,2); ! SLL NEST,2 DUMP(LGR,REG,D,NEST,REG) %IF MODE=2 %THEN OP=BC %ELSE OP=BAS DUMP(OP,14,0,REG,CODER); ! OFF TO SWITCH FREE AND FORGET(NEST) FREE AND FORGET(REG) %IF MODE=2 %THEN REGISTER(14)=0 ENTER LAB(PL,0,LEVEL) %FINISH %IF MODE#3 %THENSTART %IF A(P)=1 %THEN F=18 %AND ->ERROR P=P+1 %FINISH %END %ROUTINE CSDE(%INTEGERNAME REPORT, %INTEGER MODE) !*********************************************************************** !* COMPILE A SIMPLE DESIGNATIONAL EXPRESSION * !* P:=,'('')' * !* REPORT SET NON ZERO FOR SWITCHES WHICH MAY BE A NO-OP * !* MODE AS FOR ROUTINE GOTOLAB * !*********************************************************************** %INTEGER PP,PLUSALT,OPALT PP=P; P=P+1 %IF MODE#5 %THENSTART %IF A(PP)=2 %THEN CDE(REPORT,MODE) %ELSE GOTOLAB(REPORT,MODE) %FINISHELSESTART PLUSALT=A(P+1); OPALT=A(P+2) ->ERROR %UNLESS PLUSALT=3 %AND OPALT#2; ! NOT INTEGER CONSTANT P=P+3; ! POINTS TO OPERAND %IF OPALT=3 %THEN CDE(REPORT,5) %ELSE GOTOLAB(REPORT,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(%INTEGERNAME REPORT, %INTEGER MODE) !*********************************************************************** !* COMPILE A DESIGNATIONAL EXPRSSION * !* P:-%IF%THEN%ELSE, * !* MODE AS FOR ROUTINE GOTOLAB * !*********************************************************************** %INTEGER R,I,PL1,PL2 %IF A(P)=2 %THEN P=P+1 %AND CSDE(REPORT,MODE) %ANDRETURN P=P+1; CCOND PRIVLABEL=PRIVLABEL-1; PL1=PRIVLABEL ENTER JUMP(MASK,PL1,B'11'); ! ROUND FIRST SDE ON FALSE R=0; CSDE(R,MODE) REPORT=REPORT!R PRIVLABEL=PRIVLABEL-1; PL2=PRIVLABEL %IF R#0 %THEN ENTER JUMP(15,PL2,B'11') ENTER LAB(PL1,B'110',LEVEL); ! UNCONDITIONAL AND REPLACE CDE(REPORT,MODE) ENTER LAB(PL2,B'11',LEVEL); ! CONDITIONAL AND MERGE %END %ROUTINE NAMEXP(%INTEGER REG,MODE) !*********************************************************************** !* EVALUATE AN EXPRESSION CONSITING OF JUST A NAME. * !* USED IN PREFERENCE TO CNAME WHEN TYPE CONVERSION REQD * !*********************************************************************** %SHORTINTEGER OPHEAD %INTEGER ENAME OPHEAD=0; ENAME=FROM AR2(P) REDUCETAG %IF MODE=3 %AND TYPE#3 %THEN FAULT(24,ENAME) %IF MODE<3 %AND TYPE=3 %THEN FAULT(42,ENAME) PUSH(OPHEAD,PTYPE<<16!2,P) EXPOP(OPHEAD,REG,1,MODE) CLEAR LIST(OPHEAD) %END %ROUTINE CCOND !*********************************************************************** !* COMPILES A CONDITION INDEXED BY P AND LEAVES MASK SET UP * !* READY FOR A BRANCH IF FALSE OPERATION * !*********************************************************************** %INTEGER PP %SHORTINTEGER EXPHEAD,NOPS EXPHEAD=0; NOPS=0 PP=P ETORP(EXPHEAD,NOPS,4) PP=P EXPOP(EXPHEAD,-1,NOPS,3) P=PP %IF NEST>=0 %THENSTART PRR(LTR,NEST,NEST) %UNLESS CCSTATE&X'FFFF'=NEST MASK=8 %FINISH %END %ROUTINE CSEXP(%INTEGER REG,MODE) !*********************************************************************** !* COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE' * !* MODE=1 FOR %INTEGER, =2 REAL, =3 BOOL,=0 INTEGER %IF POSSIBLE * !* MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')* !*********************************************************************** %SHORTINTEGER EXPHEAD,NOPS %BYTEINTEGER ADDREXP %INTEGER PP,BDISP EXPHEAD=0; ADDREXP=0 NOPS=0; ADISP=0 ADDREXP=MODE>>2&1 ETORP(EXPHEAD,NOPS,MODE) %IF EXPHEAD=0 %THEN NEST=0 %ANDRETURN; ! EXPR CONSTANT ONLY ! BDISP=ADISP PP=P EXPOP(EXPHEAD,REG,NOPS,MODE&7) P=PP ADISP=BDISP CLEAR LIST(EXPHEAD) %END %ROUTINE ETORP(%SHORTINTEGERNAME HEAD,NOPS, %INTEGER MODE) !*********************************************************************** !* CONVERT EXPRESSION TO REVERSE POLISH * !*********************************************************************** %INTEGER TYPEP,TMODE %SHORTINTEGER BHEAD,EHEAD1,EHEAD2 ABORT %UNLESS 1<=A(P)<=2 %IF A(P)=2 %THENSTART P=P+1 TORP(HEAD,NOPS,MODE) %FINISHELSESTART P=P+1; BHEAD=0 %IF MODE>=3 %THEN TMODE=3 %ELSE TMODE=0 ETORP(BHEAD,NOPS,4) EHEAD1=0 TORP(EHEAD1,NOPS,TMODE) TYPEP=PTYPE; EHEAD2=0 ETORP(EHEAD2,NOPS,TMODE) PTYPE=2 %UNLESS TYPEP=1 %IF TMODE=3 %THEN PTYPE=3 PUSH123(HEAD,PTYPE<<16!4,BHEAD<<16!EHEAD1,EHEAD2) %FINISH %END %ROUTINE TORP(%SHORTINTEGERNAME 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) %SHORTINTEGER ORHEAD,RPHEAD,PASSHEAD,SAVEHEAD %BYTEINTEGER REAL,BOOL,OPSEEN,COMPLEX %INTEGER OPERATOR,OPPREC,OPND,C,D,PP,RPTYPE,RPINF,XTRA %CONSTSHORTINTEGERARRAY OPINF(1:12)=X'519'(2),X'30F', X'310',X'413',X'415',X'414', 0,X'416',X'312',X'217',X'111' ! OPINF IS THE PRECEDENCE<<8!EXPOP SWITCH VALUE OF ALT OF P *XC_ORHEAD(48),ORHEAD PP=P %IF MODE=3 %OR MODE=4 %THEN BOOL=8 P=P+1 %IF BOOL=0 LABEL2:P=P+1; ! PAST HOLE C=A(P) %IF 2=C %AND BOOL=0 %THENSTART; ! INITIAL '-' NOPS=NOPS+1; OPSEEN=1 PUSH(ORHEAD,11,3) %FINISH %IF BOOL#0 %AND C=1 %START NOPS=NOPS+1; OPSEEN=1 PUSH(ORHEAD,10,5) %FINISH LABEL1:OPND=A(P+1); P=P+2 COMPLEX=0; XTRA=0 ->OPERAND(BOOL+OPND); ! SWITCH ON OPERAND OPERAND(1): ! NAME OPERAND(10): ! BOOLEAN NAME REDUCE TAG; C=FROMAR2(P) %IF ROUT=1 %OR NAM=1 %THEN COMPLEX=1 %IF ADFLAG#0 %AND OLDI=LEVEL %AND SNDISP#M'FP' %THEN FAULT(27,C) %IF TYPE=2 %THEN REAL=1 RPTYPE=2; RPINF=P %IF BOOL=0 %THENSTART %IF PTYPE=7 %THEN PTYPE=1 %AND UNPACK %IF TYPE>=3 %THENSTART FAULT(42,C) RPTYPE=0; PTYPE=1 %FINISH %FINISHELSESTART %IF PTYPE=7 %THEN PTYPE=3 %AND UNPACK %IF TYPE#3 %THENSTART FAULT(24,C) RPTYPE=0; PTYPE=3 %FINISH %FINISH P=P+2 FFLAG=0 SKIP APP; P=P+1 %IF FFLAG#0 %THEN COMPLEX=1 INS: INSERT ATEND(RPHEAD,PTYPE<<16!COMPLEX<<8!RPTYPE,RPINF,XTRA) ->LABEL50 OPERAND(2): ! CONSTANT C=A(P); RPTYPE=1 %IF C=2 %THENSTART; ! REAL CONSTANT PTYPE=2; CVALUE=FROMAR8(P+1) RPINF=INTEGER(ADDR(CVALUE)) XTRA=INTEGER(ADDR(CVALUE)+4) P=P+10 REAL=1 %FINISHELSESTART D=FROMAR4(P+1) %IF D>>12=0 %THEN RPTYPE=0 RPINF=D P=P+6; PTYPE=1 %FINISH; ->INS OPERAND(9): ! (EXPR)(COMP)(EXPR) PASSHEAD=0 ETORP(PASSHEAD,NOPS,0) C=A(P); P=P+1 SAVEHEAD=0 ETORP(SAVEHEAD,NOPS,0) ! ! OPTIMISE SIMPLE CONDITIONS HERE ! %IF MODE=4 %AND OPSEEN=0 %AND A(P)=2 %THEN D=27 %ELSE D=26 INSERT ATEND(SAVEHEAD,D,C,0); ! COMPARAISON & COMPARATOR CONCAT(PASSHEAD,SAVEHEAD) CONCAT(RPHEAD,PASSHEAD) P=P+1; ->LABEL50 OPERAND(11): ! BOOLEAN CONSTANT C=A(P); P=P+2; ! 0=FALSE -1=TRUE PTYPE=3; RPTYPE=1 RPINF=C-2; ->INS OPERAND(3): ! SUB EXPRESSION OPERAND(12): ! SUB EXPRESSION PASSHEAD=0 ETORP(PASSHEAD,NOPS,3*(BOOL>>3)) CONCAT(RPHEAD,PASSHEAD) REAL=1 %IF TYPE=2 P=P+1 LABEL50: ! DEAL WITH OPERATOR ->LABEL60 %IF A(P-1)=2; ! EXPR FINISHED OPERATOR=A(P) ! OPPREC=OPINF(OPERATOR+BOOL) OPERATOR=OPPREC&63 %IF OPERATOR=21 %THEN REAL=1; ! '/' IS ALWAYS REAL OPPREC=OPPREC>>8 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<=FROM2(ORHEAD) %CYCLE POP(ORHEAD,C,D); ! UNLOAD STACK INSERT ATEND(RPHEAD,C,0,0) %REPEAT ! ! THE CURRENT OPERATOR CAN NOW BE STORED ! PUSH(ORHEAD,OPERATOR,OPPREC) ->LABEL1 %IF BOOL=0; ->LABEL2 LABEL60: ! END OF EXPRESSION CONCAT(RPHEAD,ORHEAD); ! EMPTY REMAINING OPERATORS %IF BOOL#0 %THEN PTYPE=3 %ELSE PTYPE=1+REAL CONCAT(RPHEAD,HEAD) HEAD=RPHEAD; ! HEAD BACK TO TOP OF LIST UNPACK %END %ROUTINE EXPOP(%INTEGER INHEAD,REG,NOPS,MODE) !*********************************************************************** !* GENERATE CODE FOR THE EXPRESSION CONTAINED IN TRIPLES IN * !* THE LIST HEADED BY INHEAD. THERE WILL BE 'NOPS' OPERATORS * !* ALL THE MACHINE DEPENDENT PART OF EXPRESSION EVALUATION * !* IS CONTAINED HEREIN. * !*********************************************************************** %SHORTINTEGER FPHEAD %INTEGERARRAY OPERAND(1:2) %BYTEINTEGER ADDREXP,RDFORM %RECORD (RD) %NAME OPND1,OPND2 %INTEGER C,D,KK,JJ,OPCODE,COMM,XTRA %INTEGER NEWCC,PP,PT,JJJ,LOADREG %INTEGER SPECREG; SPECREG=REG %ROUTINESPEC FLOAT(%INTEGER OP) %ROUTINESPEC TYPE CHK(%INTEGER MODE) %ROUTINESPEC FIX(%INTEGER OP,MODE) %ROUTINESPEC CTOP(%INTEGERNAME A) %ROUTINESPEC CHOOSE(%INTEGERNAME I) %INTEGERFNSPEC FINDR %ROUTINESPEC CLAIM PAIR(%INTEGERNAME REG) %ROUTINESPEC PUT %ROUTINESPEC STARSTAR %ROUTINESPEC REXP(%INTEGER D1,D2,D3) %ROUTINESPEC UNRESERVE(%INTEGER XB) %ROUTINESPEC LOAD PAIR(%INTEGER I) %ROUTINESPEC LOAD(%INTEGER OP,REG,MODE) %CONSTSHORTINTEGERARRAY MCINST(10:32)=X'297',X'193', X'80',X'90',X'81',X'11A',X'19B',X'217', X'216',X'1C',X'9D',X'9D',X'214',X'296',X'89', X'84',X'19',X'19',X'9C',X'89',X'90',X'90',X'90' %CONSTBYTEINTEGERARRAY FCOMP(1:14)=8,10,2,7,12,4,7, 8,12,4,7,10,2,7 %SWITCH SW(10:32) %IF INHEAD=0 %THEN NEST=0 %ANDRETURN FPHEAD=0; RDFORM=MODE&16 NEWCC=0 ADDREXP=MODE>>2&1 LABEL1:FROM12(INHEAD,C,XTRA) JJ=C&255; D=INHEAD MLINK(INHEAD) ->OPERATOR %IF JJ>=10 PUSH(FPHEAD,D,0) LABEL2: ->LABEL1 %UNLESS INHEAD=0 %OR MODE=100 ->FINISH OPERATOR: %IF JJ<15 %THEN KK=1 %ELSE KK=2; ! UNARY OR BINARY %CYCLE KK=KK,-1,1 POP(FPHEAD,C,D); ! EXTRACT OPERANDS OPERAND(KK)=C %REPEAT PTYPE=FROM1(C)>>16 UNPACK; ! SET TYPE ETC. OPCODE=MCINST(JJ) COMM=OPCODE>>7&1; ! BIT SET IF OPERATOR UNCOMMUTVE NEWCC=OPCODE>>8; ! 0=CC UNKNOWN- 1= CC SRITHMETIC ! 2= CC LOGICAL AFTER OPERATION OPCODE=OPCODE&63; ! OPCODE FOR INTEGER RR INST %IF COMM=0 %THEN CHOOSE(COMM) OPND1==RECORD(ADDR(ASLIST(OPERAND(COMM)))) OPND2==OPND1 %IF JJ>=15 %THEN OPND2==RECORD(ADDR(ASLIST(OPERAND(3-COMM)))) %IF OPND1_FLAG<2>OPND2_FLAG %THEN CTOP(JJ) ->LABEL101 %IF JJ=0; ! CTOP CARRIED OUT %IF JJ=15 %OR JJ=16 %OR JJ=19 %OR 26<=JJ<=27 %OR 30<=JJ<=31 %THEN TYPE CHK((JJ+2)>>5) ->SW(JJ) SW(10): ! \ LOAD(1,-1,2) PIX RX(X,OPND1_XB,0,CODER,PLABS(1)+44) LABEL100:SET USE(HOPCODE(TYPE)+OPND1_XB,1,OPERAND(COMM)) LABEL101:PUSH(FPHEAD,OPERAND(COMM),0) %IF NEWCC#0 %THEN CCSTATE=NEWCC<<16!HOPCODE(TYPE)!OPND1_XB ->LABEL2; ! SAVE CONDITION CODE STATE SW(11): ! NEGATE LOAD(1,-1,2) PUT; ->LABEL100 SW(12): ! ARRAY BOUND CHECK %IF OPND1_PTYPE&7=2 %THEN FIX(1,0) LOAD(1,-1,2) REGISTER(OPND1_XB)=2 C=XTRA>>16; XTRA=XTRA&X'FFFF'; ! TOP HALF = BOUND NO COPY TAG(XTRA) LOAD DV(D,I,K,TAGS(XTRA)) PIX RX(ICP,OPND1_XB,0,D,12*C); ! CHECK LOWER BOUND PPJ(4,6); ! FAULT IF LOW PIX RX(ICP,OPND1_XB,0,D,12*C+4); ! CHECK UPPER BOUBD PPJ(2,6); ! FAULT IF HIGH REGISTER(OPND1_XB)=1 TYPE=1; ->LABEL100 SW(13): ! ENTIER %IF OPND1_PTYPE&7=1 %THEN FLOAT(1) FIX(1,1); ->LABEL100 SW(14): ! SIGN FINDREG(GR1,D) LOAD(1,-1,2) PRR(LTR+HOPCODE(TYPE),OPND1_XB,OPND1_XB) REGISTER(OPND1_XB+HOPCODE(TYPE))=0 PRR(5,D,0) PIX RS(SLL,D,0,0,2); ! SLL D,2 PIX RS(SRL,D,0,0,30); !SRL D,30 PRR(AR,D,D); ! AR D,D DUMP(LH,D,PLABS(1)+88,CODER,D); ! LH D REGISTER(D)=1; TYPE=1 OPND1_PTYPE=1; OPND1_XB=D OPND1_FLAG=9; OPND1_D=-2 ->LABEL100 SW(15): ! ADD LABEL151:LOAD(COMM,-1,0) LOAD(3-COMM,-1,1) LOAD(COMM,-1,2); ! IN CASE RT CALL PUT; ->LABEL100 %UNLESS JJ=17 PIX RX(X,OPND1_XB,0,CODER,PLABS(1)+44) ->LABEL100 SW(16): ! SUBTRACT ->LABEL151 %UNLESS TYPE=1 %AND OPND2_FLAG=0 %AND OPND2_D=1 LOAD(1,-1,2) PRR(6,OPND1_XB,0); ! BCTR NEWCC=0; ->LABEL100; ! BCTR DOES NOT SET CC SW(17): ! EXCLUSIVE OR SW(18): ! OR SW(22): ! AND ->LABEL151 %IF TYPE=3 FAULT(24,0) F25: JJ=15; OPCODE=X'1A'; ->LABEL151; ! CHANGE OPN TO + F26: FAULT(26,0); ->F25 SW(23): ! %IMPLIES LOAD(1,-1,2) PIX RX(X,OPND1_XB,0,CODER,PLABS(1)+44) FORGET(OPND1_XB) ->LABEL151 SW(24): ! SLL SW(19): ! MULT ->LABEL151 %IF TYPE=2 LOAD PAIR(1); ! 1ST OPERAND TO ODD MEMBER ! 2ND OPERAND TESTED ALSO PUT D=OPND1_XB+CHECKSP REGISTER(D)=0; FORGET(D) %IF CHECKSP#0 %THENSTART PIX RS(SLDA,OPND1_XB,0,0,32) CCSTATE=-1 %FINISHELSE OPND1_XB=OPND1_XB+1 ->LABEL100 SW(20): ! INTEGER DIVISION ->F26 %UNLESS OPND1_PTYPE&7=1=OPND2_PTYPE&7 LOAD PAIR(0); ! 1ST OPERAND TO EVEN REG PIX RS(SRDA,OPND1_XB,0,0,32); ! SRDA CCSTATE=-1 PUT; D=OPND1_XB REGISTER(D)=0; FORGET(D) OPND1_XB=D+1; ->LABEL100 SW(21): ! NORMAL DIVISION TYPE CHK(2); ->LABEL151 SW(25): ! EXP %IF OPND2_PTYPE&7=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(1) %IF OPND2_PTYPE&7=1 %THEN STARSTAR %AND ->LABEL100 PROTECT ST(REXP,0,0,0); ->LABEL100 SW(26): ! COMPARISON TO BOOLEAN CONVERSION SW(27): ! COMPARISONS PTYPE=OPND1_PTYPE; UNPACK LOAD(COMM,-1,0) LOAD(3-COMM,-1,0) %IF JJ=26 %THENSTART FINDREG(GR0,LOADREG) PRR(SLR,LOADREG,LOADREG); ! SR LOADREG,LOADREG FORGET(LOADREG); CCSTATE=-1 REGISTER(LOADREG)=2 %FINISHELSE LOADREG=-1 ->Z1 %IF OPND1_FLAG=0=OPND1_D ->Z2 %IF OPND2_FLAG=0=OPND2_D LOAD(3-COMM,-1,1) LOAD(COMM,-1,2) CCSTATE=-1 PUT Z4: D=FCOMP(XTRA+7*(COMM-1))!!15 %IF LOADREG=-1 %THENSTART MASK=D NEST=-1 %RETURN %FINISH SET LOCAL BASE FINDREG(GR1,C) PJUMP(BC,GLABEL,D,C) PRR(6,LOADREG,0); ! BCTR SET LOADREG TO FALSE PLABEL(GLABEL) GLABEL=GLABEL-1 OPND1_PTYPE=3; OPND1_XB=LOADREG OPND1_FLAG=9; OPND1_D=-2 TYPE=3 REGISTER(LOADREG)=1 ->LABEL100 Z1: C=3-COMM; ->Z3 Z2: C=COMM Z3: LOAD(C,-1,2) D=FROM1(OPERAND(C))>>8&15 C=HOPCODE(TYPE)+D REGISTER(C)=0 %IF REGISTER(C)>0 ->Z4 %IF 1<<16!C=CCSTATE; ! CONDITION CODE ALREADY SET PRR(HOPCODE(TYPE)+X'12',D,D); ! LTR OR LTDR ON REG D CCSTATE=1<<16!C; ->Z4 SW(28): ! SPECIAL MH FOR ARRAY ACCESS %IF OPND1_PTYPE&7=2 %THEN FIX(1,0) %IF OPND1_FLAG=2 %AND OPND2_FLAG=0 %AND OPND2_D<=255 %THENSTART D=OPND1_D; D=TAGS(A(D)) FIND USE(C,1,9,OPND2_D<<24!D) %IF C>0 %THENSTART OPND1_FLAG=9; OPND1_XB=C; OPND1_D=-2; ->LABEL101 %FINISH %FINISH LOAD(1,-1,2); ! LOAD TO ANY REGISTER ->LABEL2801 %IF OPND2_FLAG=0; ! CONSTANT SO OPTIMISE LOAD(2,-1,3); ! LOAD DV POINTER DUMP(MH,OPND1_XB,OPND2_D,0,OPND2_XB) UNRESERVE(OPND2_XB) SET USE(OPND1_XB,1,OPERAND(COMM)) ->LABEL100 LABEL2801:D=OPND2_D; C=OPND1_XB PIX RS(SLL,C,0,0,2!D>>3) REGISTER(C)=0 %IF GRUSE(C)#3 %OR D>255 %THEN ->LABEL100 SET USE(C,9,D<<24!GRINF(C)); ->LABEL101 SW(29): ! ->LAB MASKS AND LAB AS OPND2 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,-1,0); ! DEAL WITH NASTY RH SIDES LOAD(2,-1,4); ! GET ADDRESS FOR LHS ! %IF OPND1_FLAG#0 %AND OPND2_XB<16 %AND 0<=OPND2_D<=4095 %C ! %AND OPND2_PTYPE=OPND1_PTYPE %AND JJ=31 %C ! %THEN %START ! LOAD(1, -1, 3) ! STILL TRYING TO LEAVE RHS ! %IF OPND2_PTYPE=OPND1_PTYPE %AND 0<=OPND1_D<=4095 %C ! %AND 16>OPND1_XB %START ! PMVC(BYTES(TYPE), OPND2_XB, OPND2_D, OPND1_XB, OPND1_D) ! UNRESERVE(OPND1_XB) ! JJJ=-1 ! ->NOTE ASSMENT(CAPACITY OK) ! ->NASS1 ! %FINISH ! %FINISH ! ! ALL ATTEMPTS AT SHORT CUTTING HAVE FAILED SO ASSIGN NORMALLY ! IF LHS ALREADY IN A REGISTER IT IS BEST TO USE THAT REGISTER ! FOR ASSIGNMENT(UNLESS RHS ALREADY IN A DIFFERENT REGISTER). ! THIS SAVES A REGISTER WHEN COMPILING 'K=0 %IF K<0' ETC. ! IT IS RATHER A TEDIOUS SEARCH SO IT IS OMITTED IN NON OPTIMISING MODE ! JJJ=-1 ! %IF CHECKSP=0 %AND OPND1_D>=0 %AND PT<3 %AND D=2 %C ! %THEN %START ! C=TAGS(A(PP)); ! TAGS OF LHS ! FIND USE(KK,PT,3,C) ! %IF KK>=0 %AND REGISTER(KK)=0 %THEN JJJ=KK&15 ! %FINISH LOAD(1,JJJ,2); ! RHS TO REGISTER PTYPE=OPND2_PTYPE; UNPACK; ! SET TYPE FOR LHS JJJ=HOPCODE(TYPE)+X'50'; ! CODE FOR DUMP DUMP(JJJ,OPND1_XB,OPND2_D,OPND2_XB>>4,OPND2_XB&15) JJJ=OPND1_XB !NASS1: UNRESERVE(OPND2_XB) PTYPE=PT; UNPACK; ! ORIGINAL PTYPE COMM=1; ! ASSGN TO NAME ONLY %IF D=2 %AND 1<=TYPE<=3 %AND ARR=0=NAM %AND A(PP+2)=3 %THEN %C NOTE ASSMENT(JJJ,2,FROMAR2(PP)) ->LABEL100 %IF INHEAD#0 ->LABEL101; ! NORMAL EXIT FREES REG USED SW(32): ! ARRAY ASSNMT XTRA=ARRNAME LOAD(1,-1,0); ! RHS COPYTAG(XTRA) D=TYPE %IF D=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(1) %IF D=1 %AND OPND1_PTYPE=2 %THEN FIX(1,0) LOAD(2,-2,2); ! INDEX EXPRSN TO REG LOAD ABASE(XTRA,C) REGISTER(C)=2 LOAD(1,-1,2) %IF OPND2_D>0 %OR OPND2_XB=0 %THENSTART FINDREG(GR1,KK) LOAD(2,KK,2) %FINISH JJJ=X'50'+HOPCODE(D) DUMP(JJJ,OPND1_XB,0,OPND2_XB,C) REGISTER(C)=0 REGISTER(OPND2_XB)=0 COMM=1; ->LABEL101 FINISH: POP(FPHEAD,C,D) OPERAND(1)=C OPND1==RECORD(ADDR(ASLIST(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) %IF RDFORM=0 PTYPE=OPND1_PTYPE NEST=-1 FROM12(OPERAND(1),C,D) PUSH(RDHEAD,C,D) UNPACK %IF OPND1_FLAG=9 %AND OPND1_D<0 %THENSTART NEST=OPND1_XB %IF TYPE=2 %THEN NEST=NEST+16 %IF GRUSE(NEST)=1 %THEN GRINF(NEST)=RDHEAD NEST=OPND1_XB %IF NEST=0 %AND ADDREXP=1 %THENSTART LOAD(1,FINDR,2); FORGET(0); NEST=OPND1_XB %FINISH D=NEST+HOPCODE(TYPE) REGISTER(D)=0 %IF REGISTER(D)>0 %FINISH %RETURN ! %INTEGERFN FINDR %INTEGER I,J %IF REG>=0 %THENSTART I=REG; ->LABEL1 %IF REGISTER(REG)=0 %FINISH %IF ADDREXP=1 %THEN J=GR1 %ELSE J=GR0 FIND REG(J,I) LABEL1:REGISTER(I)=1 %RESULT=I %END %ROUTINE CHOOSE(%INTEGERNAME CHOICE) %BYTEINTEGER X1,X2,F1,F2 %RECORD (RD) %NAME OPND1,OPND2 OPND1==RECORD(ADDR(ASLIST(OPERAND(1)))) OPND2==RECORD(ADDR(ASLIST(OPERAND(2)))) F1=OPND1_FLAG; F2=OPND2_FLAG X1=OPND1_XB; X2=OPND2_XB ->CHOS1 %IF F1=4 ->CHOS2 %IF F2=4 ->CHOS1 %IF F1=2 %AND X1=1 ->CHOS2 %IF F2=2 %AND X2=1 ->CHOS0 %IF F1>=7 %AND OPND1_D<0 ->CHOS2 %IF F2=0 %AND OPND2_D>3 %AND OPCODE#X'19' ->CHOS2 %IF OPND2_PTYPE>OPND1_PTYPE ->CHOS2 %IF F2>F1 CHOS1:CHOICE=1; ->LABEL99 CHOS0:->CHOS1 %UNLESS F2>7 %AND OPND2_D<0 %AND X2=REG CHOS2:CHOICE=2 LABEL99:%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 * !* MODE=3 LEAVE IN STORE IF SUITABLE FOR CLC INSTRUCTIONS * !*********************************************************************** %INTEGER I,J,K,VALUE,B,C,D %SHORTINTEGER HEAD1,HEAD2 %RECORD (RD) %NAME OPND %SWITCH SW(0:4) OPND==RECORD(ADDR(ASLIST(OPERAND(OP)))) PTYPE=OPND_PTYPE; UNPACK %IF REG<0 %THEN REG=REG-ADDREXP ->RD FORM %IF OPND_FLAG>=7 ->SW(OPND_FLAG) SW(0): ! CONSTANT < 4096 ->LABEL99 %UNLESS MODE>0 VALUE=OPND_D FIND USE(I,1,2,VALUE) ->NOT FOUND %IF I<0 %IF REG<0 %THENSTART ->RF %IF REGISTER(I)=0 REG=FINDR %FINISH PRR(LR,REG,I) %UNLESS REG=I REGISTER(REG)=1 %IF REGISTER(REG)=0 SG: SET USE(REG,2,VALUE) %UNLESS REGISTER(REG)<0 LABEL1:OPND_PTYPE=1 LABEL2:OPND_FLAG=9 OPND_XB=REG OPND_D=-2 ->LABEL99 RF: REGISTER(I)=1 REG=I; ->LABEL1 NOT FOUND: ->GLA COPY %IF MODE&1#0 %AND VALUE#0 REG=FINDR %IF REG<0 DUMP(LA,REG,VALUE,0,0); ->SG GLA COPY: TYPE=1 SW(1): ! LONG CONSTANT STORE CONST(BASE,DISP,BYTES(TYPE),ADDR(OPND_D)) ->PICK UP %IF MODE=2 INDEX=0; ->RESET RD PICKUP:DUMP(HOPCODE(TYPE)+X'58',REG,DISP,0,BASE) MODE=0; ->LABEL21; ! ENSURE THAT USE IS CHANGED SW(2): ! NAME ->LOAD %IF MODE=2 ->STORE %IF MODE=4 ->LOAD %IF OPND_XB&127#0 ->LOAD %IF MODE=0 %AND ARR>0 ->DONT LOAD %IF MODE=3 ->LABEL99 %IF MODE=0 DONT LOAD: P=OPND_D CNAME(5,REG) ->LABEL21 %IF NEST>=0 RESETRD: REGISTER(BASE)=2 %IF BASE>0 %AND REGISTER(BASE)=0 REGISTER(INDEX)=2 %IF INDEX>0 %AND REGISTER(INDEX)=0 OPND_PTYPE=TYPE OPND_FLAG=9 OPND_XB=INDEX<<4!BASE OPND_D=DISP; ->LABEL99 STORE:P=OPND_D CNAME(1,0); ->RESET RD LOAD: P=OPND_D CNAME(2,REG) LABEL21:REG=NEST %IF REG<0 PTYPE=TYPE; K=HOPCODE(TYPE)+REG REGISTER(K)=1 %IF REGISTER(K)>=0; ! CLAIM THE REGISTER ->LABEL24 %IF MODE>=1; ! DONT CHANGE GRUSE SET USE(K,1,OPERAND(OP)) LABEL24:OPND_PTYPE=PTYPE; ->LABEL2 SW(3): ! DOPE VECTOR ITEM ! XB HAS BASE OF ARRAYHEAD D IS HEADDISP<<16!ITEM DISP. XTRA HAS TAGS ->LABEL99 %IF MODE=0 LOAD DV(BASE,OPND_XB,OPND_D>>16,OPND_XTRA) INDEX=0; DISP=OPND_D&X'FFFF' ->RESET RD; ! NOT CALLED WITH MODE=2 SW(4): ! CONDITIONAL EXPRSSN C=OPND_PTYPE&7 HEAD1=OPND_D>>16; HEAD2=OPND_D&X'FFFF' SAVEIRS(15) EXPOP(HEAD1,-1,2,3) %IF NEST>=0 %THENSTART PRR(LTR,NEST,NEST) %UNLESS CCSTATE&X'FFFF'=NEST MASK=8 %FINISH PRIVLABEL=PRIVLABEL-1; J=PRIVLABEL ENTER JUMP(MASK,J,B'11') CLEAR LIST(HEAD1) EXPOP(HEAD2,REG,2,C) %IF REG>=0 %THEN D=REG %ELSE D=NEST REGISTER(D+HOPCODE(C))=1 PRIVLABEL=PRIVLABEL-1 ENTER JUMP(15,PRIVLABEL,B'11') REGISTER(D+HOPCODE(C))=0 CLEAR LIST(HEAD2) HEAD1=OPND_XTRA ENTER LAB(J,B'111',LEVEL) J=PRIVLABEL EXPOP(HEAD1,D,2,C) ENTER LAB(J,B'11',LEVEL) CLEAR LIST(HEAD2) OPND_PTYPE=C; REGISTER(D+HOPCODE(C))=1 SET USE(HOPCODE(C)+D,1,OPERAND(OP)) REG=D; ->LABEL2 RDFORM: ->LABEL99 %IF MODE=3 %OR MODE=4 ->PROTECT %IF MODE=0 ->LABEL99 %IF MODE=1 B=OPND_XB ->RDR %IF OPND_D<0 %IF REG<0 %AND TYPE=1 %THEN REG=FINDR; ! IN CASE OF SPECREG DUMP(HOPCODE(TYPE)+X'58',REG,OPND_D,B>>4,B&15) MODE=0; ! ENSURE USE IS CHANGED UNRESERVE(B); ->LABEL21 PROTECT: BASE=OPND_XB; INDEX=BASE>>4 BASE=BASE&15; DISP=OPND_D; ! SAFEGUARD FROM OVERWRITING ->RESET RD %IF OPND_D>=0 K=HOPCODE(TYPE)+BASE REGISTER(K)=1 %IF REGISTER(K)>=0; ! CLAIM THE REGISTER %IF GRUSE(K)=1 %THEN GRINF(K)=OPERAND(OP) %ELSE SET USE(K,1,OPERAND(OP)) ->LABEL99 RDR: ->LABEL99 %IF REG<0 %OR REG=B K=HOPCODE(TYPE)+B J=HOPCODE(TYPE)+X'18' PRR(J,REG,B) SET USE(HOPCODE(TYPE)+REG,GRUSE(K),GRINF(K)) REGISTER(HOPCODE(TYPE)+B)=0; OPND_XB=REG LABEL99:%END %ROUTINE UNRESERVE(%INTEGER XB) %INTEGER B B=XB&15 REGISTER(B)=0 %IF REGISTER(B)=2 XB=XB>>4 REGISTER(XB)=0 %IF REGISTER(XB)=2 %END %ROUTINE PUT !*********************************************************************** !* THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC * !* OPERATION DEFINED BY OPND1,OPND2 & OPCODE * !* OPCODE IS IN INTEGER RR FORM * !*********************************************************************** %INTEGER K,CODE,X,B,D PTYPE=OPND2_PTYPE; UNPACK CODE=OPCODE %IF TYPE=2 %THEN CODE=CODE+16 ->RROP %IF OPND2_D<0 X=OPND2_XB>>4; B=OPND2_XB&15 D=OPND2_D; CODE=CODE+64 DUMP(CODE,OPND1_XB,D,X,B) UNRESERVE(OPND2_XB) ->LABEL99 RROP: PRR(CODE,OPND1_XB,OPND2_XB) K=HOPCODE(TYPE)+OPND2_XB REGISTER(K)=0 %UNLESS REGISTER(K)<0 %OR OPND1_XB=OPND2_XB LABEL99:K=HOPCODE(TYPE)+OPND1_XB %IF OPCODE=X'19' %THENSTART REGISTER(K)=0 %IF REGISTER(K)>0 %FINISHELSE SET USE(K,1,OPERAND(COMM)) %END %ROUTINE LOAD PAIR(%INTEGER ODDEVEN) !*********************************************************************** !* THIS ROUTINE LOADS OPERAND 1 INTO AN EVEN-ODD PAIR * !* THE PAIR IS CLAIMED AS LATE AS POSSIBLE. * !* ODDEVEN=0 IF EVEN REG TO BE LOADED,=1 FOR ODD REG * !*********************************************************************** %INTEGER PAIR,TOTHER LOAD(COMM,-1,0); ! IN STORE UNLESS RT ETC LOAD(3-COMM,-1,0) ->IN STORE %UNLESS OPND1_FLAG=9 %AND OPND1_D<0 TOTHER=OPND1_XB!!1 ->INSTORE %UNLESS REGISTER(TOTHER)=0 REGISTER(TOTHER)=1; PAIR=TOTHER&14 ->FIN %IF ODDEVEN+PAIR#TOTHER LOAD(COMM,TOTHER,2); REGISTER(TOTHER!!1)=1; ->FIN INSTORE: CLAIM PAIR(PAIR) LOAD(COMM,PAIR+ODDEVEN,2) FIN: OPND1_XB=PAIR; ! ALWAYS LH MEMBER LOAD(3-COMM,-1,1) %END %ROUTINE CLAIM PAIR(%INTEGERNAME REG) %INTEGER I,J,K %CYCLE I=0,1,2 %CYCLE K=6,-2,-2 J=K&15 ->FOUND %IF REGISTER(J)=REGISTER(J+1)=0 %AND (I>0 %OR GRUSE(J)=0=GRUSE(J+1)) %REPEAT SAVE IRS(4) %IF I=1 %REPEAT ABORT FOUND:REGISTER(J)=1 REGISTER(J+1)=1 REG=J %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 %SWITCH SW(10:28) NEWCC=0; !COMPILE TIME OPS CAN NOT SET CC OP=FLAG TYPEP=OPND1_PTYPE!OPND2_PTYPE ->LABEL99 %IF OP>28 %OR TYPEP>=3 %IF OPND1_PTYPE=2 %THENSTART 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 ->LABEL99 SW(11): ! NEGATE %IF TYPEP=1 %THEN VAL1=-VAL1 %AND ->INT END RVAL1=-RVAL1; ->REAL END SW(13): ! ENTIER ->LABEL99 %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 ->LABEL99 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 ->LABEL99 %IF RVAL2=0; ! AVOID DIV BY ZERO RVAL1=RVAL1/RVAL2; ->REAL END SW(20): ! '%DIV' DIVISION ->LABEL99 %IF VAL2=0 %OR TYPEP#1 VAL1=VAL1//VAL2; ->INT END SW(25): ! EXP ->LABEL99 %IF RVAL1<=0 %IF TYPEP=1 %AND 32>VAL2>0 %THEN VAL1=VAL1****VAL2 %AND ->INT END %IF OPND2_PTYPE=1 %AND 63>IMOD(VAL2) %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): LABEL99:%END %ROUTINE FLOAT(%INTEGER OP) !*********************************************************************** !* PLANT CODE TO CONERT OPERAND1 FROM FIXED TO FLOATING * !*********************************************************************** %INTEGER P1,P2,K,C %RECORD (RD) %NAME OPND1 C=PLABS(1)+40; ! ADDR OF FIX/FLOAT CNSTS OPND1==RECORD(ADDR(ASLIST(OPERAND(OP)))) %IF OPND1_FLAG<=1 %THENSTART CVALUE=OPND1_D OPND1_D=INTEGER(ADDR(CVALUE)) OPND1_XTRA=INTEGER(ADDR(CVALUE)+4) OPND1_PTYPE=2; TYPE=2 OPND1_FLAG=1; %RETURN %FINISH P1=OPND1_XB P2=(P1+1)&15 %UNLESS OPND1_FLAG=9 %AND OPND1_D<0 %AND REGISTER(P1)>=0=REGISTER(P2) %AND %C GRUSE(P2)>1 %START FIND SEQ(P1,P2) LOAD(OP,P1,2) %FINISH PRR(LPR,P2,P1); ! LPR P2,P1 PIX RX(AND,P1,CODER,0,C+16); ! N P1,=X'80000000' PIX RX(O,P1,CODER,0,C); ! O P1,=X'4E000000' PIX RS(STM,P1,P2,WSPR,0); ! STM P1,P2,0(11) CLAIM(FR0,K) PRR(SDR,K,K); ! SDR K,K PIX RX(AD,K,0,11,0); ! AD K,0(11) FREE AND FORGET(P1) FORGET(P2) CCSTATE=-1 SET USE(K+16,1,OPERAND(OP)) OPND1_PTYPE=2; OPND1_XB=K 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 * !*********************************************************************** %IF MODE#2 %AND OPND1_PTYPE&7=1=OPND2_PTYPE&7 %THENRETURN %IF MODE=1 %THENSTART %IF OPND2_PTYPE&7=1 %AND OPND1_PTYPE&7=2 %THEN FIX(COMM,0) %ANDRETURN %FINISHELSESTART %IF OPND2_PTYPE&7=1 %THEN FLOAT(3-COMM) %FINISH %IF OPND1_PTYPE&7=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 R0,WSP,CAREA %RECORD (RD) %NAME OPND CAREA=PLABS(1); ! ADDRESS OF CONSTANT AREA OPND==RECORD(ADDR(ASLIST(OPERAND(OP)))) %IF OPND_FLAG=1 %THENSTART INTEGER(ADDR(CVALUE))=OPND_D INTEGER(ADDR(CVALUE)+4)=OPND_XTRA %IF MOD(CVALUE)0 %CYCLE FROM123(LIST,I,J,K) %IF C1=I %AND C2=J %THENRESULT=K MLINK(LIST) %REPEAT %RESULT=-1 %END %ROUTINE STORE CONST(%INTEGERNAME B,D, %INTEGER L,AD) !*********************************************************************** !* PUT THE CONSTANT OF LENGTH 'L' AT ADDRESS 'AD' INTO THE GLA * !* 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 * !*********************************************************************** %INTEGER I,J,K %SHORTINTEGERNAME LIST D=CONST FIND(L,AD) %IF D=-1 %THENSTART; ! FIRST USE OF CNST I=0; J=0 %CYCLE K=0,1,L-1 BYTEINTEGER(ADDR(I)+K)=BYTEINTEGER(AD+K) %REPEAT PGLA(L,L,AD) D=GLACA-L; B=GLAREG %IF L=4 %THEN LIST==CONSTL4 %ELSE LIST==CONSTL8 PUSH123(LIST,I,J,D) %FINISHELSESTART; ! CONST ALREADY IN %IF D<0 %THENSTART B=CODER; D=D&X'FFFF' %FINISHELSE B=GLAREG %FINISH %END %ROUTINE REDUCE ENV(%SHORTINTEGERNAME HEAD) !*********************************************************************** !* HEAD HAS AN ENVIRONMENT - THIS ROUTINE REMOVES ANYTHING * !* INCOMPATIBLE WITH THE CURRENT REGISTER STATE * !*********************************************************************** %SHORTINTEGER NEWHEAD; %INTEGER I,J,K,REG,USE NEWHEAD=0 %WHILE HEAD#0 %CYCLE POP123(HEAD,I,J,K) REG=K>>8; USE=K&255 %IF USE=GRUSE(REG) %AND I=GRINF(REG) %THEN PUSH123(NEWHEAD,I,J,K) %REPEAT HEAD=NEWHEAD %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 = USE BITS<<8 ! Put label no * !* S2 = ENVIRONMENT LIST << 16 ! UNFILLED JUMPS LIST * !* S3 = LAB NO - RESET TO ZERO WHEN USED FOR INTERNAL LABELS * !* usebits 2**0 set for used * !* 2**1 set for referenced * !*********************************************************************** %INTEGER CELL,S1 %SHORTINTEGERNAME ENVHEAD,JUMPHEAD MONE=1 %IF LAB<=NNAMES CELL=LABEL(LEVL) %WHILE CELL>0 %CYCLE %EXITIF SHORTINTEGER(ADDR(ASLIST(CELL))+10)=LAB CELL=SHORTINTEGER(ADDR(ASLIST(CELL))+14) %REPEAT %IF CELL<=0 %THENSTART; ! LABEL NOT KNOWN %IF FLAGS&1=0 %THENSTART; ! UNCONDITIONAL ENTRY PUSH123(LABEL(LEVL),GLABEL!x'02000000',0,LEVEL<<16!LAB) PLABEL(GLABEL) GLABEL=GLABEL-1 FORGETM(16) CCSTATE=-1 %FINISH %RETURN %FINISH ! ! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS ! ENVHEAD==SHORT INTEGER(ADDR(ASLIST(CELL+4))) JUMPHEAD==SHORT INTEGER(ADDR(ASLIST(CELL+6))) S1=FROM1(CELL) %IF S1&x'02000000'#0 %THENSTART FAULT(2,LAB); ! LABEL SET TWICE %FINISHELSESTART CCSTATE=-1 REPLACE1(CELL,X'2000000'!S1) PLABEL(S1&x'ffffff') REPLACE3(CELL,LEVEL<<16!LAB) %FINISH ! ! SORT OUT ENVIRONMENTS - AS DIRECTED BY FLAGS ! %IF FLAGS&2=0 %THENSTART FORGETM(16) CLEAR LIST(ENVHEAD) %FINISHELSESTART REMEMBER %IF FLAGS&4=0 RESTORE(ENVHEAD) ENVHEAD=0 MERGE INFO %IF FLAGS&4=0 %FINISH %IF LAB>NNAMES %THEN REPLACE3(CELL,FROM3(CELL)&X'FFFF0000'!X'FFFF') %END %ROUTINE ENTER JUMP(%INTEGER MASK,LAB,FLAGS) !*********************************************************************** !* IF LAB HAS BEEN ENCOUNTERED THEN PLANT A *BC 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=KREG<<24! ADDR OF JUMP * !* S2=BREG<<24! (ADDRESS IN BASE(BREG) REGISTER) * !* S3=LEVEL OF JUMP * !* * !* FLAGS BITS SIGNIFY AS FOLLOWS * !* 2**0 =1 JUMP IS KNOWN TO BE SHORT * !* 2**1 =1 ENVIRONMENT MERGEING REQUIRED * !*********************************************************************** %INTEGER AT,CELL,BREG,BBASE,KREG,LABADDR,I,LEVL,OPCODE %SHORTINTEGER ENVHEAD %SHORTINTEGERNAME OLDENV ENVHEAD=0; AT=CA; KREG=0; LEVL=LEVEL BREG=12; BBASE=0; ENVHEAD=0 OPCODE=BC; ! BC %IF MASK>15 %THEN OPCODE=BAS %AND MASK=MASK&15 %IF LAB=0 %THEN FAULT(2,0) %ANDRETURN %IF LAB<=NNAMES %THENSTART LEVL=FROM1(TAGS(LAB))>>8&63 FLAGS=FLAGS&X'FD'; ! NO MERGE %FINISH %IF LAB<21000 %THEN FLAGS=FLAGS&X'FE'; ! SF OR USER LAB=LONG CELL=LABEL(LEVL) %WHILE CELL#0 %CYCLE %EXITIF SHORTINTEGER(ADDR(ASLIST(CELL))+10)=LAB CELL=SHORTINTEGER(ADDR(ASLIST(CELL))+14) %REPEAT ->FIRSTREF %IF CELL<=0 LABADDR=FROM1(CELL) ->NOT YET SET %IF LABADDR&x'02000000'=0 REPLACE1(CELL,LABADDR!X'1000000'); ! FLAG LABEL AS USED FAULT(12,LAB) %IF FROM3(CELL)>>16>LEVEL ->CODE FIRSTREF: ! FIRST REFERENCE TO A NEW LABEL %IF FLAGS&1#0 %THEN SET LOCAL BASE %IF LAB>NNAMES %AND FLAGS&2#0 %THEN GET ENV(ENV HEAD) LABADDR=GLABEL GLABEL=GLABEL-1 PUSH123(LABEL(LEVL),X'1000000'!LABADDR,ENVHEAD<<16,LAB) CELL=LABEL(LEVL) ->CODE NOT YET SET: ! LABEL REFERENCED BEFORE %IF LAB>NNAMES %AND FLAGS&2#0 %THENSTART OLDENV==SHORT INTEGER(ADDR(ASLIST(CELL+4))) REDUCE ENV(OLD ENV) %FINISH CODE: ! ACTUALLY PLANT THE JUMP FIND REG(GR1,KREG) PJUMP(OPCODE,LABADDR&x'ffffff',MASK,KREG) FORGET(KREG) %END %ROUTINE MERGE INFO !*********************************************************************** !* MERGE CURRENT STATUS OF GENERAL AND FLOATING POINT REGISTERS * !* WITH THE VALUES AT START OF CONDITIONAL CLAUSE. THIS PERMITS * !* THE COMPILER TO REMEMBER UNCHANGED REGISTERS BUT NOT THOSE * !* WHOSE VALUES DEPEND ON A PARTICULAR RUN TIME ROUTE BEING TAKEN* !*********************************************************************** %CYCLE I=0,1,22 FORGET(I) %UNLESS SGRUSE(I)=GRUSE(I) %AND SGRINF(I)=GRINF(I) %REPEAT %END %ROUTINE REMEMBER *L_1,SGRUSE; *L_2,GRUSE; *MVC_0(92,1),0(2) *L_1,SGRINF; *L_2,GRINF; *MVC_0(92,1),0(2) %END %ROUTINE SET LOCAL BASE !*********************************************************************** !* FIND OR SET A REGISTER FOR BRANCHING A SMALL DISTANCE FORWARD * !*********************************************************************** %INTEGER I LABEL2:%END; ! OF ROUTINE SET LOCAL BASE %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=%INTEGERFN ROUND(%REAL VALUE) * !* 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(%INTEGER FNO,%REAL VALUE) * !* 16=%ROUTINE STOP * !* 17=%ROUTINE INSYMBOL(%INTEGER CH,%STRING STR,%INTEGERNAME SYM)* !* 18=%ROUTINE OUTSYMBOL(%INTEGER CH,%STRING STR,%INTEGER SYM) * !* 19=%ROUTINE INREAL(%INTEGER CH,%LONGREALNAME NUMBER) * !* 20=%ROUTINE OUTREAL(%INTEGER CHANNEL,%LONGREAL NUMBER) * !* 21=%ROUTINE ININTEGER(%INTEGER CH,%INTEGERNAME INT) * !* 22=%ROUTINE OUTTERMINATOR(%INTEGER CHANNEL) * !* 23=%ROUTINE OUTINTEGER(%INTEGER CHANNEL,VALUE) * !* 24=%ROUTINE OUTSTRING(%INTEGER CHANNEL,%STRING STRING) * !* 25=%INTEGERFN LENGTH(%STRING(255) S) * !* 26=%REALFN CPUTIME * !* AND 27-39 ARE THE IMP IO ROUTINES :- * !* SELECTINPUT,SELECTPOUTPUT,NEWLINE,SPACE,NEWLINES,SPACES, * !* NEXTSYMBOL PRINTSYMBOL,READSYMBOL,READ,NEWPAGE,PRINT, * !* AND PRINTSTRING. READ IS A FUNCTION AS IS ALGOLS WONT * !: 40=%INTEGERFN CODE(%STRING(1) CHAR) * !* 41=%LONGREALFN READ1900 * !* 42=%ROUTINE PRINT1900(%LONGREAL X,%INTEGERM,N) * !* 43=%ROUTINE OUTPUT(%LONGREAL X) * !* 44=%BOOLEANFN READ BOOLEAN * !* 45=%ROUTINE WRITE BOOLEAN(%BOOLEAN BOOL) * !* 46=%ROUTINE WRITE TEXT(%STRINGNAME TEXT) * !* 47=%ROUTINE COPYTEXT(%STRINGNAME TEXT) * !* 48=%INTEGERFN READCH * !* 49=%INTEGERFN NEXTCH * !* 50=%ROUTINE PRINTCH(%INTEGER CH) * !* 51=%ROUTINE SKIP CH * !* 52=%ROUTINE MONITOR * !*********************************************************************** %SWITCH ADHOC(1:7) %CONSTINTEGERARRAY SNINFO(0:52)= %C X'11010024',X'11020024',X'11030024',X'11050024', X'80010000',X'80010000'(3), X'80010000'(3),X'80000000', X'80000000'(3),X'80030000', X'10040001',X'80060000',X'800A0000',X'800E0000', X'80030000',X'801B0000',X'80110000',X'80130000', X'80160000',X'80110000',X'80000000',X'80190000', X'80190000',X'80000000'(2),X'80190000', X'80190000',X'80000000',X'80190000',X'801E0000', X'80000000'(2),X'80200000',X'80110000',X'11060024', X'80000000',X'80200000',X'80010000',X'80000000', X'80240000',X'80110000'(2),X'80000000', X'80000000',X'80190000',X'80000000',X'10070001' ! ! 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 (THUNKS&PSIMPLE)<<12!NO OF PARAMS<<8! bytes of parms ! THE REMAINDER ARE THE TYPE OF EACH PARAM ! %CONSTSHORTINTEGERARRAY SNPARAMS(0:37)=0, x'108',2, x'20c',1,2, X'310',1,5,X'201', X'310',1,5,1, X'120c',1,X'202', X'104',5, X'1208',1,1, X'208',1,5, X'1104',1, X'1208',1,X'201',X'1104',X'201', x'310',2,1,1, x'104', 3 %CONSTSTRING (15) %ARRAY SNXREFS(0:52)="S#ABS","S#IABS", "S#SIGN","S#INTPT","S#INT","S#ISQRT","S#ISIN", "S#ICOS","S#AARCTAN","S#ILOG","S#IEXP", "S#MAXREAL","S#MINREAL","S#MAXINT","S#EPSILON", "S#FAULT","S#STOP","S#INSYMBOL","S#OUTSYMBOL", "S#INREAL","S#OUTREAL","S#ININTEGER","S#OUTTERMINATOR", "S#OUTINTEGER","S#OUTSTRING","S#LENGTH","S#CPUTIME", "S#ASELIN","S#ASELOU","S#ALGNWL","S#ALGSPC", "S#ALGNLS","S#ALGSPS","S#ANXTSY","S#APRSYM", "S#ARDSYM","S#ALREAD","S#ALGPTH","S#PRINT", "S#PRSTNG","S#AICODE","S#READ1900","S#PRINT1900", "S#OUTPUT" ,"S#READBOOL","S#WRITEBOOLEAN","S#WRITETEXT", "S#COPYTEXT","S#ALRDCH","S#ALNXCH","S#ALPRCH", "S#ALSKCH","S#ALGMON" ! %BYTEINTEGER ERRNO,FLAG,POINTER %SHORTINTEGER OPHEAD %INTEGER PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,XTRA,B,D,SNINF,P0 ! SNNAME=FROMAR2(P) SNNO=K; ! INDEX INTO SNINFO TESTAPP(NAPS); ! COUNT ACTUAL PARAMETERS PIN=P; P=P+2 SNPTYPE=TSNAME(SNNO) SNINF=SNINFO(SNNO) XTRA=SNINF&X'FFFF' POINTER<-SNINF>>16 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 %THEN POINTER=0 %IF SNNO=40 %THEN POINTER=16 %FINISH ! %IF FLAG&X'80'#0 %THENSTART CXREF(SNXREFS(SNNO),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>>8&15)<<16!P0&255,P0>>12) K=OPHEAD; JJ=1; D=64 P0=P0>>8&15 %WHILE JJ<=P0 %CYCLE PTYPE=SNPARAMS(POINTER+JJ) UNPACK %IF PTYPE=2 %OR PTYPE=5 %THEN ACC=8 %ELSE ACC=4 INSERTATEND(OPHEAD,PTYPE,SNNAME,NAM<<16!D) D=D+ACC JJ=JJ+1 %REPEAT I=9; J=14 OLDI=0; PTYPE=SNPTYPE+4096 REPLACETAG(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(LA,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+3); P=P+4 ->ERREXIT %UNLESS 2<=D<=3 %IF D=2 %THEN NAMEXP(REG,B) %ELSE CSEXP(REG,B) REG=NEST %IF REG<0 PRR(LPR+HOPCODE(B),REG,REG) FORGET(REG+HOPCODE(B)) ->OKEXIT ADHOC(3): ! SIGN ADHOC(5): ! ENTIER ->ERREXIT %UNLESS A(P)=2 D=A(P+3); P=P+4; B=REG ->ERREXIT %UNLESS 2<=D<=3 %IF D=2 %THEN NAMEXP(-1,2) %ELSE CSEXP(-1,2) REGISTER(NEST!16)=1 ->ENTIER %IF POINTER=5 PRR(LTDR,NEST,NEST) %IF REG<=0 %THEN FINDREG(GR1,REG) PRR(5,REG,0); ! BALR REG,0 TO GET CC PIX RS(SLL,REG,0,0,2) PIX RS(SRL,REG,0,0,30) PRR(AR,REG,REG) DUMP(LH,REG,PLABS(1)+88,CODER,REG) FORGET(REG) %IF B=0 %THEN PRR(LR,0,REG) %AND FORGET(0) %AND REG=0 REGISTER(NEST!16)=0 NEST=REG; ->OKEXIT ADHOC(4): ! STOP PIX RX(BC,15,0,12,PLABS(3)); ->OKEXIT ENTIER:OPHEAD=0 PUSH(OPHEAD,13,0) PUSH(OPHEAD,2<<16!NEST<<8!9,-2) P0=P; EXPOP(OPHEAD,REG,1,1) P=P0; CLEAR LIST(OPHEAD) ->OKEXIT ADHOC(6): ! CODE ->ERREXIT %UNLESS A(P)=2 %AND A(P+3)=1 B=A(P+5) %IF A(P+4)=2 %THENSTART %IF B='E' %AND A(P+6)='L' %THEN B=NL %AND ->COD %IF B='S'=A(P+6) %THEN B='%' %AND ->COD %FINISH ->ERREXIT %UNLESS A(P+4)=1 %IF B='_' %THEN B=' ' %IF B='\' %THEN B=10 P=P-1 COD: DUMP(LA,REG,B,0,0) P=P+7 ->OKEXIT ADHOC(7): ! MONITOR PRR(SR,0,0); PRR(SR,1,1); ! SR 0,0 SR 1,1 PPJ(0,2) OKEXIT: ! NORMAL EXIT P=P+1 PTYPE=SNPTYPE; UNPACK %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,B,D) !*********************************************************************** !* A THUNKS CONSISTS OF 1 WORD AT D(B) WHICH POINTS TO 4 WORDS * !* JUST LIKE A ROUTINE PARAMETER WHICH HAS NO PARAMETERS * !* THE TOP BIT OF THE WORD IS SET IN CHECKING MODE IF A STORE * !* INTO THE NAME IS NOT ALLOWED. %IF Z#0 THEN THIS IS CHECKED * !*********************************************************************** PIX RS(STM,4,14,11,16) DUMP(LGR,15,D,0,B); ! HEAD POINTER TO R15 %IF Z#0 %AND CHECKS#0 %THEN PRR(LTR,15,15) %AND PPJ(4,9) PIX RS(LM,12,15,15,0); ! LOAD UP HEADERR PIX RS(LM,4,10,15,16); ! AND ENVIRONMENT PRR(BASR,15,14); ! AND ENTER FORGETM(8) SET USE(15,12,CA) %END %ROUTINE LOAD DV(%INTEGERNAME REG, %INTEGER B,D,TN) !*********************************************************************** !* FIND A REGISTER AND LOAD IT WITH POINTER TO D.V. B,D FOR * !* ARRAYHEAD TN=TAGS(NAME). NECESSARY TO PASS B&D ALSO IN CASE * !* OF ARRAYNAMES IN RECORDS WHEN TN<0. NO CHECK IS MADE THAT NAME* !* IS CORRECTLY DEFINED * !*********************************************************************** %INTEGER R FIND USE(R,1,10,TN) %IF R<=0 %THENSTART; ! REGISTER MUST BE SET FIND REG(ADDREG,R) DUMP(LGR,R,D+8,0,B) SET USE(R,10,TN) %FINISH REG=R %END %ROUTINE LOAD ABASE(%INTEGER NAM, %INTEGERNAME BREG) !*********************************************************************** !* LOAD UP A BASE REGISTER FOR ARRAY 'NAM' * !*********************************************************************** %INTEGER REG,NAMINF NAMINF=TAGS(NAM) FIND USE(REG,1,8,NAMINF); ! BASE ALREADY LOADED? %IF REG<=0 %THENSTART FINDREG(GR1,REG) COPY TAG(NAM) DUMP(LGR,REG,K,0,I); ! LOAD PITH ADDR(A(0,0,...)) SET USE(REG,8,NAMINF) %FINISH BREG=REG %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 * !*********************************************************************** %SHORTINTEGER HEAD1,HEAD2,HEAD3,NOPS %INTEGER OPTYPE,PTYPEP,KK,RR,PP,JJ,JJJ,TYPEP,ARRNAME,KKK,Q,ELSIZE,NAMINF,PARAMS PP=P; TYPEP=TYPE JJ=J; PTYPEP=PTYPE ELSIZE=BYTES(TYPE) ARRNAME=FROMAR2(P); ! NAME OF ENTITY NAMINF=TAGS(ARRNAME) PARAMS=A(P+2) 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 %THENSTART; ! 0 DIMENSIONS = NOT KNOWN REPLACE1(TCELL,FROM1(TCELL)!Q) ! DIMSN IS BOTTOM 4 BITS OF TAG JJ=Q %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. ! HEAD1=0; HEAD2=0; HEAD3=0; NOPS=0 OPTYPE=0; JJJ=0 ! ! NOW PROCESS THE SUBSCRIPTS CALLINR ETORP TO CONVERT THE EXPRESSIONS ! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS. IF THE FIRST ! SUBSCRIPT IS A CONSTANT AND THE ITEM LENGTH IS KNOWN AT COMPLIE TIME ! THE OPERATION CAN BE SUPPRESSED AND THE CONSTANT TRANSFERRED TO THE ! DISPLACEMENT FIELD OF THE FINAL INSTRUCTION. THIS SAVES 8 BYTES. ! P=PP+3 %CYCLE KK=1,1,JJ; ! THROUGH THE SUBSCRIPTS %IF CHECKS#0 %THEN PUSH(HEAD2,12,KK<<16!ARRNAME) ETORP(HEAD2,NOPS,1); ! SUBSCRIPT TO REVERSE POLISH P=P+1 ! ! TWO DIMENSION ARRAYS HAVE THE MULTIPLIER IN WORD 4 OF HEAD ! ALL OTHER MULTIPLIERS ARE DOPE VECTOR ITEMS (OPTYPE=3) ! %IF JJ=1 %THEN OPTYPE=0 %AND RR=ELSIZE %ELSEIF JJ=2 %THEN %C OPTYPE=9 %AND RR=DP+14 %ELSESTART OPTYPE=3; RR=(12*KK+10)!(DP<<16) %FINISH ! ! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS ! %IF KK>1 %THENSTART NOPS=NOPS+2 PUSH(HEAD3,15,0) %IF HEAD1#0; ! 15=ADD %FINISH ! ! N.B. THE FIRST SUFFIX CAN BE OPTIMISED OUT OF EXISTENCE IF IT IS ! A SHORT CONSTANT AND THE CORRESPONDING ADDITION MUST THEN BE OMITTED ! PUSH(HEAD3,28,0); ! MH PUSH123(HEAD3,21<<16!BS<<8!OPTYPE,RR,NAMINF) ! MULTIPLIER JJJ=1; ! SBSCRPTS XCEPT 1ST NORMAL MODE CONCAT(HEAD1,HEAD2); ! OPERANDS TO MAIN LIST CONCAT(HEAD1,HEAD3); ! OPERATORS LINKED ON %REPEAT ! ! ADD OPERATORS TO THE BACK OF OPERANDS AND EVALUATE ! PP=P EXPOP(HEAD1,-1,NOPS,5); ! EVALUATE THE REVERSE POLISH !LIST P=PP DISP=0; INDEX=NEST ! ! REGISTER INDEX AND DSIPLACEMENT NOW DEFINE THE ARRAY RELATIVE POSITION ! OF REQUIRED ELEMENT. ALL THAT REMAINS IS TO SET UP OR FIND A SUITABLE ! BASE REGISTER TO POINT TO A(0). ! CLEAR LIST(HEAD1); ! RETURN SPACE %IF Z#1 %THENSTART REGISTER(INDEX)=1 %IF INDEX#0 %AND REGISTER(INDEX)=0 LOAD ABASE(ARRNAME,BASE) REGISTER(INDEX)=0 %IF INDEX#0 %AND REGISTER(INDEX)>0 %FINISHELSE REGISTER(INDEX)=2 %FINISHELSESTART FAULT(18,ARRNAME) DISP=0; BASE=0; INDEX=0 P=P+2; SKIP APP %IF Z=1 %THEN PUSH(RDHEAD,1<<16!265,-2) %FINISH ACC=ELSIZE PTYPE=PTYPEP; UNPACK; 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 * !* -2 MEANS CHOOSE ANY REGISTER EXCEPT GR0 * !* IF A REGISTER IS CHOSEN THEN NEST IS SET WITH CHOICE * !*********************************************************************** %INTEGER JJ,JJJ,KK,RR,LEVELP,DISPP,REGP,NAMEP %SWITCH SW,MOD(0:7) FNAME=FROMAR2(P) LABEL2:COPYTAG(FNAME) ->LABEL3 %UNLESS I=-1; FAULT(16,FNAME) I=LEVEL; J=0; K=FNAME SNDISP=0; KFORM=0 PTYPE=7; STORE TAG(K,N) K=N; N=N+4; ->LABEL2 LABEL3:JJ=J; JJ=0 %IF JJ=15 NAMEP=TAGS(FNAME) LEVELP=I; DISPP=K ->LABEL502 %IF TYPE=7 ->LABEL500 %IF Z=0 %AND ROUT#1 ->ARRHEAD %IF Z=12 ->RTNAME %IF Z=13 ->RTCALL %IF ROUT=1 ->SW(TYPE) LABEL500: FAULT(17,FNAME) %UNLESS TYPE=7; ->LABEL502 SW(6): SW(0): SW(4): !RECORD FORMAT NAME LABEL501:FAULT(5,FNAME) SW(7): LABEL502:P=P+2; ! NAME NOT SET NEST=0; BASE=I; DISP=K; INDEX=0 PTYPE=1; UNPACK SKIP APP; ->LABEL1 ARRHEAD: ! SET BASE & DISP FOR ARRAYHEAD BASE=I; INDEX=0; DISP=K DISP=0 %IF ARR=0 %UNLESS 0<=DISP<=4095 %THEN ADJUST INDEX(0,BASE,DISP) ->LABEL91 RTNAME: ! LOAD ADDR FOR RT-TYPE %IF PTYPE=SNPT %THEN CSNAME(Z,REG) %AND ->LABEL6 ->LABEL500 %UNLESS ROUT=1 DISP=FROM1(K) %IF NAM&1#0 %THENSTART BASE=I; JJJ=X'58' %FINISHELSESTART %IF J=14 %THEN BASE=GLAREG %ELSE RTDES(0,K) JJJ=X'41' %FINISH DUMP(JJJ,REG,DISP,0,BASE) NEST=REG %IF REG>=0; ->LABEL91 ! ! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL ! RTCALL: ! FIRST CHECK %IF TYPE=0 %AND Z#0 %THEN FAULT(23,FNAME) %AND ->LABEL502 ! RT NAME IN EXPRSN %IF PTYPE=SNPT %THEN CSNAME(Z,REG) %AND ->LABEL1 FROM12(K,RR,JJ) KK=K; K=JJ>>16; I=LEVELP PROTECT ST(CRCALL,KK,RR,0); ! DEAL WITH PARAMS ->LABEL1 %IF PTYPE=X'1000' %OR PTYPE=X'1100' %UNLESS Z=0 %OR Z=2 %OR Z=5 %THENSTART; ! FUNCTIONS BASE=0; INDEX=0; DISP=0; ! ALREADY FAULTED %FINISH %IF TYPE=2 %THEN REGP=0 %AND JJ=16 %ELSE REGP=1 %AND JJ=1 NAMEP=0; ->SWOP SW(5): ! TYPE=STRING ->LABEL501 %UNLESS Z=2; ! ONLY FETCH ALLOWED NAM=0 SW(1): ! TYPE =INTEGER SW(2): ! TYPE=REAL SW(3): ! BOOLEAN ->LABEL600 %IF ARR=0 CANAME(Z,I,K) NAM=0; ->LABEL601 ! ! GENERAL FETCHING & STORING !SECTION LABEL600:BASE=I; INDEX=0; DISP=K LABEL601:%IF TYPE=2 %THEN JJJ=X'68' %ELSE JJJ=X'58' KK=Z; KK=2 %IF Z=5 NAMEP=0 %UNLESS INDEX=0 %AND DISP=DISPP %AND BASE=LEVELP ->MOD(NAM<<2!KK&3) MOD(1): ! SCALAR STORE ->LABEL9 MOD(6): ! SCALARNAME FETCH PROTECT ST(CALL THUNKS,0,BASE,DISP) INDEX=0; BASE=1; DISP=0; NAMEP=0 MOD(2): ! SCALAR FETCH ->GENFETCH %IF NAMEP=0 ! HAVE A SIMPLE NAME SO LOOK AT REGISTER POINTED AT BY REGP TO SEE ! IF THE LOAD (&UNASSIGNED CHECK) CAN BE AVOIDED FIND USE(JJ,TYPE&3,3,NAMEP) ->GENFETCH %IF JJ<0; REGP=JJ&15 ! HAVE FOUND VARIABLE IN REGISTER. MANOEVRE IT TO REQUIRED REGISTER SWOP: %IF REG<0 %THENSTART %IF REGISTER(JJ)=0 %THENSTART NEST=REGP; ->LABEL9 %FINISH; ! CAN USE IT AS FOUND %IF JJ>=16 %THEN FIND REG(FR0,REG) %ELSE FINDREG(GR0,REG) %FINISH ! MOVE TO NEW REGISTER ALLOWING FOR ALL TYPES AND ADDRESSES %IF REG#REGP %THENSTART PRR((JJ>>4+1)<<4+8,REG,REGP); ! LR OR LDR KK=GRUSE(JJ) JJ=JJ&16!REG FORGET(JJ); ! REMEMBER ORIGINAL REGISTER %IF NAMEP>0 %AND REGISTER(JJ)>=0 %THEN SET USE(JJ,KK,NAMEP) %FINISH NEST=REG; ->LABEL9 GENFETCH:->DELAY %IF Z=5 %AND UNASS=0 DUMP(JJJ,REG,DISP,INDEX,BASE) REG=NEST %IF REG<0 %IF UNASS=1 %AND Z#3 %THENSTART PIX RX(JJJ+1,REG,0,CODER,PLABS(1)+48) CCSTATE=-1 PPJ(8,5) %FINISH; ! BE UNASS VAR USED %IF NAMEP=0 %THEN JJJ=1 %ELSE JJJ=3 SET USE(HOPCODE(TYPE)+REG,JJJ,NAMEP) ->LABEL9 DELAY:NEST=-1; ->LABEL9 MOD(7): ! SCALAR NAME FETCH POINTER JJJ=X'58'; ->GENADDR MOD(3): ! SCALAR FETCH ADDR JJJ=X'41' GENADDR:DUMP(JJJ,REG,DISP,INDEX,BASE) REG=NEST %IF REG<0 %IF NAMEP=0 %THEN JJJ=0 %ELSE JJJ=7 SET USE(REG,JJJ,NAMEP); ->LABEL9 MOD(5): ! SCALAR NAME STORE PROTECT ST(CALL THUNKS,1,BASE,DISP) INDEX=0; BASE=1; DISP=0 LABEL9:->LABEL1 %UNLESS ARR=0=ROUT LABEL91:P=P+2 ->LABEL6 %IF A(P)=3 FAULT(19,FNAME) SKIP APP; ->LABEL1 LABEL6:P=P+1 LABEL1:%END %ROUTINE GTHUNKS(%INTEGER PTYPEP,PNAME, %INTEGERNAME SADR) !*********************************************************************** !* GENERATE A THUNKS FOR THE ACTUAL PARAMETER INDEXED BY P * !* PTYPEP IF THE FORMAL PARAMETER TYPE. * !* THUNKS RUN ON AN OPEN STACK WHICH MUST BE PROTECTED IF * !* A FUNCTION OR A FURTHER THUNKS IS CALLED * !*********************************************************************** %INTEGER TYPEP,APALT,D,TOPREG %SWITCH PARTYPE(0:7) ! ! FIRST CHECK FOR THUNKS PASSED ON AS THUNKS. IF FOUND THEN IT IS ! SUFFICIENT TO COPY THE THUNKS POINTER ! SADR=GLABEL; GLABEL=GLABEL-1; APALT=A(P); FPTR=72 PLABEL(SADR) TYPEP=PTYPEP&7; TOPREG=15 %IF APALT=2 %AND A(P+3)=3 %START; ! NAME,NO APP COPYTAG(FROMAR2(P+1)) %IF ROUT=0=ARR %AND TYPE=TYPEP %START %IF NAM=1 %THEN SADR=0 %AND FPTR=0 %ANDRETURN ! REPORT SPECIAL CASE ! ! A SIMPLE LOCAL NAME DOES NOT REQUIRE A PROPER THUNKS ! A LITTLE TIME CAN BE SAVED IN THIS COMMON CASE ! %IF TYPEP<=3 %START DUMP(LA,1,K,0,I); ! ADDR OF LOCAL TO GR1 TOPREG=14; ->THUNKSEND %FINISH %FINISH %FINISH ! ! A PROPER THUNKS IS NEEDED ! PIX RX(ST,15,0,11,60); ! STACK RETURN ADDRESS FORGETM(16) ->PARTYPE(TYPEP) PARTYPE(0): PARTYPE(4): PARTYPE(5): PARTYPE(7): ERROR: FAULT(22,PNAME) FPTR=0; %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 %THENSTART; ! ACTUAL= COPYTAG(FROMAR2(P+1)) %IF ROUT=0 %AND TYPE=TYPEP %START P=P+1; CNAME(3,1) ->THUNKSEND %FINISH %FINISH P=P+1 %IF APALT=2 %THEN NAMEXP(-1,TYPEP) %ELSE CSEXP(-1,TYPEP) GET WSP(D,BYTES(TYPEP)>>2); ! 1 OR 2 WORDS REGISTER(NEST)=1 DUMP(ST+HOPCODE(TYPE),NEST,D,0,RBASE) REGISTER(NEST)=0 SADR=SADR!X'80000000' DUMP(LA,1,D,0,RBASE) THUNKSEND: ! EXIT SEQUENCE PIX RS(LM,4,TOPREG,11,16) PRR(BCR,15,15) FPTR=0; %RETURN PARTYPE(6): ! LABEL AND SWITCH %IF PTYPEP&255>16 %START ->ERROR %UNLESS APALT=2 %AND A(P+3)=3 MOVER(WSPR,64) P=P+1; D=0; GOTOLAB(D,3) MOVER(WSPR,-64) ->THUNKSEND %FINISH %IF APALT=3 %OR APALT=5 %THENSTART D=0; P=P+1; CDE(D,11-APALT<<1); ! MODE = 5 OR 3 ->THUNKSEND %UNLESS D=0 %RETURN %FINISH ->ERROR %UNLESS APALT=2 D=0 P=P+1; GOTOLAB(D,1) ->THUNKSEND %UNLESS D=0 %END %ROUTINE FETCH STRING(%INTEGER REG) !*********************************************************************** !* FETCH A STRING POINTER FOR PASSING.P TO ALT OF ACTUAL PARAM * !*********************************************************************** %INTEGER I %IF A(P)=1 %THENSTART I=FIND(P+1,CONSTL1) ABORT %IF I<0 DUMP(LA,REG,FROM1(I),0,CODER) %FINISHELSE P=P+1 %AND CNAME(2,REG) %END %ROUTINE RTDES(%INTEGER MODE,VALUE) !*********************************************************************** !* SET UP A 4 WORD ROUTINE DESCRIPTOR AND LEAVE 'BASE' & 'DISP' * !* DEFINING IT * !* MODE=0 :- VALUE IS NAME OF A PARAMETRIC PROCEDURE * !* MODE=1 :- VALUE IS THE ADDRESS OF A THUNKS * !*********************************************************************** %INTEGER REG GET WSP(DISP,4); ! GRAB A 4 WORD AREA %IF REGISTER(14)=0 %THEN REG=14 %ELSE FIND REG(GR1,REG) %IF MODE=0 %THEN RT JUMP(LA,REG,VALUE) %ELSE PJUMP(LA,VALUE,REG,REG) REGISTER(REG)=1 DUMPM(STM,12,13,RBASE,DISP) DUMP(ST,REG,DISP+8,0,RBASE) DUMP(ST,WSPR,DISP+12,0,RBASE) BASE=RBASE; FREE AND FORGET(REG) %END %ROUTINE PROTECT ST(%ROUTINE ACTION(%INTEGER I,J,K), %INTEGER P0,P1,P2) !*********************************************************************** !* MAKES SURE THE STACK IS IN GOOD ORDER BEFORE CALLING ACTION * !*********************************************************************** %INTEGER SAVEFPTR,MOVEFPTR SAVEFPTR=FPTR; MOVEFPTR=(FPTR+7)&(-8) SAVE IRS(RBASE+4) %IF FPTR>64 %THEN MOVER(WSPR,MOVEFPTR) FPTR=0 ACTION(P0,P1,P2) FPTR=SAVE FPTR %IF FPTR>64 %THEN MOVER(WSPR,-MOVE FPTR) %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 * !*********************************************************************** %INTEGER NPS PRINTSTRING("fprocs") NPS=FROM2(FORMALHEAD); ! the parameter check word %RESULT=1 %IF 0<=NPS#FROM2(ACTHEAD) %RESULT=0 %IF NPS<0; ! formal of a formal NPS=NPS>>16; ! no of params %WHILE NPS>0 %CYCLE MLINK(ACTHEAD) MLINK(FORMALHEAD) %RESULT=1 %IF FROM1(ACTHEAD)#FROM1(FORMALHEAD) NPS=NPS-1 %REPEAT %RESULT=0; ! CORRESPONDENCE COMPLETE %END %ROUTINE CRCALL(%INTEGER CLINK,RT CELL,DUMMY) !*********************************************************************** !* 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 KK,II,III,PXTRA,SCA,JJ,JJJ,NPARMS,PT,LP,KKK,PSIZE,PSIMPLE,RTNAME,R1,R2,TL,MOVEPTR, PP,THNKS,PNAM,NP,ALT %INTEGERARRAY PLIST(0:FROM2(CLINK)>>16) ! R1=4; R2=14 LP=I; JJJ=J; KKK=CLINK; TL=OLDI RTNAME=FROMAR2(P); PT=PTYPE ! ! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED ! TEST APP(NPARMS) P=P+2 %IF K#NPARMS %THENSTART FAULT(19,RTNAME); ! WRONG NO OF PARAMETERS GIVEN SKIP APP %RETURN %FINISH ! PSIMPLE=FROM3(CLINK) THNKS=PSIMPLE>>1 PSIMPLE=PSIMPLE&1 P=P+1 ->ENTRY SEQ %IF NPARMS=0; ! NO PARAMETERS TO BE PLANTED ! ! A ROUTINE IS DEEMED TO HAVE SIMPLE PARAMETERS IF THEY CAN BE LOADED ! INTO GRS 0 UP AND PLANTED IN THE SAME 'STM' THAT STORES THE REGISTERS ! THIS IS CHECKED AT ROUTINESPEC TIME. ONLY THE REGISTERS NEED BE ! LOOKED AT HERE. ! II=0 %WHILE PSIMPLE=1 %AND II4 %FINISH PP=P-2 %IF THNKS#0 %THENSTART; ! AT LEAST 1 THUNKS REQD KKK=CLINK; III=PP; NP=0 MLINK(CLINK) PRIVLABEL=PRIVLABEL-1 PLIST(0)=PRIVLABEL ENTER JUMP(15,PRIVLABEL,B'11'); ! SAVE ENVIRONMENT %WHILE CLINK#0 %CYCLE FROM123(CLINK,PTYPE,TL,PSIZE) NP=NP+1; P=PP+2 PP=P+FROMAR2(P); P=P+2 %IF PSIZE&X'F0000'#0 %THEN GTHUNKS(PTYPE,TL&4095,PLIST(NP)) MLINK(CLINK) %REPEAT CLINK=KKK; PP=III ENTER LAB(PLIST(0),B'111',LEVEL); ! RESTORE ENVIRONMENT %FINISH NP=0 ! NEXT PARM:MLINK(CLINK) NP=NP+1 P=PP+1 ->ENTRY SEQ %IF CLINK=0 FROM123(CLINK,PTYPE,PNAM,II) FPTR=II&X'FFFF' PSIZE=II>>16 PXTRA=PNAM>>16 PNAM=PNAM&X'FFF' P=PP+2; PP=P+FROMAR2(P) P=P+2; UNPACK II=TYPE ALT=A(P); ! SYNTACTIC ALTERNATIVE OF APP %IF PSIZE<=0 %AND ((ROUT!ARR#0 %AND ALT#2) %OR (TYPE=5 %AND ALT>2) %OR (NAM=2 %AND %C ALT#2) %OR (PTYPE&X'F0F0'#0 %AND TYPE<=2 %AND (ALT=1 %OR ALT>3)) %OR %C (PTYPE&X'F0FF'=3 %AND ALT&1=1) %OR (PTYPE&X'F0FF'<=2 %AND (ALT=1 %OR ALT>=4))) %THEN %C FAULT(22,PNAM) %AND ->NEXT PARM %IF PSIMPLE#0 %THENSTART R2=R2+1 %IF TYPE=5 %THEN FETCH STRING(R2) %ELSESTART P=P+1 %IF NAM=2 %THENSTART CNAME(3,R2) FAULT(22,PNAM) %UNLESS II=TYPE %AND NAM=0 %FINISHELSESTART %IF ALT#2 %THEN CSEXP(R2,TYPE) %ELSE NAMEXP(R2,TYPE) %FINISH %FINISH SET USE(R2,15,0) REGISTER(R2)=1 ->NEXT PARM %FINISH ! ! FOR RT TYPE PARAMS, PASS 1 WORD POINTING TO 4 WORDS SET ! UP AS CODE,GLA,EP ADDR & ENVIRONMENT ! %IF ROUT=1 %THENSTART II=PTYPE; P=P+1 CNAME(13,-1); ! SET UP 4 WDS & SET PTR FAULT(21,PNAM) %IF ROUT=1 %AND (II&15#PTYPE&15 %OR CHECK FPROCS(K,PXTRA)#0) ! TYPE SIMILAR P=P+1 STUFF: PIX RX(ST,NEST,0,WSPR,FPTR); ! STUFF OFF POINTER ->NEXT PARM %FINISH ! %IF NAM=2 %THENSTART P=P+1; CNAME(3,-1) FAULT(22,PNAM) %UNLESS II=TYPE %AND NAM=0 ->STUFF %FINISH ! %IF PSIZE>0 %THENSTART; ! A THUNKS HAS BEEN SET %IF PLIST(NP)=0 %THENSTART; ! NAME PASSED BY NAME COPY TAG(FROMAR2(P+1)) DUMP(LGR,-1,K,0,I) %FINISHELSESTART RT DES(1,PLIST(NP)&X'FFFFFF') DUMP(LA,-1,DISP,0,BASE) %FINISH %IF PLIST(NP)<0 %THEN PIX RX(O,NEST,0,CODER,PLABS(1)+56) FREE AND FORGET(NEST) ->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 %THENSTART III=NAM; ! zero if arrays by value %IF A(P)=2 %AND A(P+3)=3 %THENSTART P=P+1; CNAME(12,-1) %IF ARR=1 %AND (II=TYPE %OR (III=0 {by value} %AND II#3#TYPE)) %START %IF PXTRA=0 %THEN PXTRA=J %AND REPLACE2(CLINK,PXTRA<<16!PNAM) %IF J=0 %THENSTART; ! ACTUAL UNKNOWN DIMENS J=PXTRA; II=TAGS(FNAME) REPLACE1(II,FROM1(II)!PXTRA) %FINISH FAULT(20,PNAM) %UNLESS J=PXTRA PSS(MVC,16,WSPR,FPTR,BASE,DISP) ->NEXT PARM %FINISH %FINISH FAULT(22,PNAM) ->NEXT PARM %FINISH ! %IF TYPE=5 %THENSTART; ! STRINGS FETCH STRING(-1) FAULT(22,PNAM) %UNLESS TYPE=5 ->STUFF %FINISH ! ! %IF TYPE=6 %THEN %START; ! LABEL BY VALUE ! %MONITOR %AND %STOP ! %FINISH %IF TYPE<=3 %THENSTART P=P+1 %IF ALT#2 %THEN CSEXP(-1,TYPE) %ELSE NAMEXP(-1,TYPE) DUMP(ST+HOPCODE(II),NEST,FPTR,0,WSPR) %FINISH ->NEXT PARM ENTRY SEQ: ! CODE FOR RT ENTRY %IF R2=14 %AND REGISTER(14)!GRUSE(14)=0 %THEN R2=13 ! ! SIMPLE PARAMETERS SHOULD BE IN GRS 0 UP AWAITING STORAGE. IF HOWEVER ! THERE WAS A FUNCTION CALL AMONG THE ACTUAL PARAMETERS SOME MAY HAVE ! BEEN STORED ALREADY. THIS CASE MUST BE CHECKED FOR, AND IF FOUND, ! ROUTINE SAVE IRS CALLED TO STORE ANY REMAINING PARAMETERS. ! JJ=0 %WHILE PSIMPLE#0 %AND JJ4095-MARGIN %IF R2>8&15; ! LEVEL OF DECLN FORGET(JJ) %UNLESS II>TL; ! NAME CAN NOT BE ALTERED %FINISH %FINISH %REPEAT R1=R1+1 %WHILE REGISTER(R1)=0 %AND GRUSE(R1)<=1 PSETOPD(SCA,0,X'9000'!R1<<4!R2) PSETOPD(SCA,1,WSPR<<12!R1<<2) %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) %ELSESTART SKIP EXP(1) SKIP SEXP(MODE) SKIP EXP(MODE) %FINISH %END %ROUTINE SKIP SEXP(%INTEGER MODE) !*********************************************************************** !* SKIPS OVER A BOOLEAN EXPRESSION * !* FFLAG IS SET IF THERE ARE ANY FUNCTIONS IN THE 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; P=P+1 %IF MODE=0 %UNTIL BOP#1 %CYCLE BOP=A(P+2); P=P+3; ! BOP =ALT OF P ->ALT(BOP+MODE<<2) ALT(1): ! ALT(6): ! J=ADDR(ASLIST(TAGS(A(P)))) FFLAG=1 %IF SNPT#SHORT INTEGER(J)>=X'1000' ! ROUT IN PTYPE P=P+2; SKIP APP; ->END ALT(2): ! J=A(P); ! CONSTANT TYPE %IF J=1 %THEN P=P+5; ! INTEGER CONSTANT %IF J=2 %THEN P=P+9; ! REAL CONSTANT ->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 %THENSTART %IF ALT=2 %THENSTART P=P+1+FROMAR2(P+1) P=FROMAR2(P+2)+P+2 %WHILE A(P)=1 %FINISHELSESTART P=P+1 %AND SKIP EXP(0) %WHILE A(P)=1 %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+2; ! P ON NAME AT ENTRY %IF A(P)=2 %THENSTART Q=1; P=P+1+FROMAR2(P+1) Q=Q+1 %AND P=P+2+FROMAR2(P+2) %WHILE A(P)=1 %FINISHELSESTART %WHILE A(P)=1 %CYCLE; ! NO (MORE) PARAMETERS P=P+1; Q=Q+1 SKIP EXP(0) %REPEAT %FINISH P=PP; NUM=Q %END %ROUTINE MOVE R(%INTEGER R,N) !*********************************************************************** !* ADVANCE OR RETARD ADDRESS IN REGISTER 'R' BY N BYTES * !*********************************************************************** %INTEGER CODE,BASE,D CODE=X'41'; BASE=R; D=N %IF N<0 %THENSTART; ! STORE CONST & USE SH CODE=X'5B'; N=IMOD(N) CCSTATE=-1 STORE CONST(BASE,D,4,ADDR(N)) %FINISH DUMP(CODE,R,D,0,BASE); ! LA OR SH -ZERO SORTED %END %ROUTINE BULK M(%INTEGER MODE,L,B1,D1,B2,D2) !*********************************************************************** !* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM * !* D1(B1) TO D2(B2) * !* IF MODE =0 SET L BYTES TO D2(0 OR X'80') * !* * !* L MAY BE GREATER THAN 4095 * !*********************************************************************** %ROUTINESPEC UPDATE(%INTEGERNAME WI,DI) %INTEGER I,J,W1,W2,OPCODE,CONST W1=B1; W2=B2 OPCODE=X'D2' %IF L+D1>4092 %THEN UPDATE(W1,D1) ! %IF MODE=0 %THENSTART; ! PROPAGATE CONSTANT J=L; W2=W1 CONST=D2; D2=D1 pix si(MVI,CONST,W1,D1) L=L-1; D1=D1+1 %FINISH ! ! END OF PREPARATION - CYCLE ROUND PLANTING MVC ! %WHILE L>0 %CYCLE %IF L>256 %THEN J=256 %ELSE J=L %IF D1>4092 %THENSTART I=D1; UPDATE(W1,D1) %IF W2=W1 %THEN D2=D2-I+D1; ! OVERLAPPING PROPAGATION W1=W2 %FINISH %IF D2>4092 %THEN UPDATE(W2,D2) PSS(OPCODE,J,W1,D1,W2,D2) D1=D1+J D2=D2+J L=L-J %REPEAT ! REGISTER(W1)=0 %IF REGISTER(W1)>0 REGISTER(W2)=0 %IF REGISTER(W2)>0 %RETURN %ROUTINE UPDATE(%INTEGERNAME WI,DI) %INTEGER WK,J WK=WI %IF REGISTER(WK)<0 %THEN FIND REG(GR1,WK) %IF DI<4092 %THEN J=DI %ELSE J=4092 DUMP(LA,WK,J,0,WI) FORGET(WK) DI=DI-J; WI=WK %END %END; ! OF ROUTINE BULK M %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=FROMAR4(P+2) KK=KK*BP P=P+6 %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 POP(AVL WSP(SIZE,LEVEL),J,K) %IF K<=0 %THENSTART; ! MUST CREATE TEMPORARY %IF SIZE=2 %THEN N=(N+7)&(-8); ! DBLE WRD BNDRY! K=N N=N+SIZE<<2 %FINISH PLACE=K PUSH(TWSPHEAD,K,SIZE) %END %ROUTINE RETURN WSP(%INTEGER PLACE,SIZE) PUSH(AVL WSP(SIZE,LEVEL),0,PLACE) %END %ROUTINE SETLINE !*********************************************************************** !* UPDATE THE STATEMENT NO * !*********************************************************************** %INTEGER K PLINESTART(LINE) %IF LINENOS=1 %THENSTART K=LINE&255 MONE=1 %IF K=0 pix si(MVI,K,RBASE,3) %IF MONE#0 %THEN pix si(MVI,LINE>>8,RBASE,2); ! MVI MONE=0 %FINISH %END ! !*********************************************************************** !* REGISTER ALLOCATING ROUTINES * !* THE REGISTERS ARE HELD ON A LIST FROM 0->22 COVERING * !* THE 16 GENERAL REGISTERS AND THE FOUR FLOATING REGISTERS. * !* A FLOATING REGISTER MAY BE DEFINED BY (TYPE=2,REG=0,2,4,6) OR * !* (TYPE =1,REG=16,18,20,22). BOTH ARE VALID. THE FREE LIST IS * !* SEARCHED IN DIFFERENT WAYS SO THAT THE MORE VOLATILE REGISTERS* !* I.E. GRS 0-3 AND GR15 ARE USED FOR SHORT-TERM PURPOSES AND * !* THE SAFE REGISTERS(GRS 4-14) ARE USED WHEN THE PURPOSE MAY * !* HAVE SOME LONG TERM VALUE. * !*********************************************************************** ! %ROUTINE FORGET(%INTEGER REG) CCSTATE=-1 %IF CCSTATE&255=REG %IF GRUSE(REG)=12 %THEN PDROP(REG) %IF REGISTER(REG)>=0 %THEN GRUSE(REG)=0 %AND GRINF(REG)=0 %END %ROUTINE FREE AND FORGET(%INTEGER REG) CCSTATE=-1 %IF CCSTATE&255=REG %IF REGISTER(REG)>=0 %THEN REGISTER(REG)=0 %AND FORGET(REG) %END %ROUTINE FORGETM(%INTEGER UPPER) !*********************************************************************** !* FORGETS A BLOCK OF REGISTERS DEFINED BY UPPER AND THE * !* GLOBAL ARRAY GRMAP * !* UPPER= 3 FOR GRS 0-3 * !* UPPER= 4 FOR GRS 0-3 AND 15 * !* UPPER= 8 FOR GRS 0-3 AND 15 PLUS ALL FRS * !* UPPER=14 FOR GRS 0-8,14,15 AND ALL FRS * !*********************************************************************** %INTEGER I,J,REG,U %CYCLE I=0,1,UPPER REG=GRMAP(I) FORGET(REG) %REPEAT %END %ROUTINE SAVE IRS(%INTEGER UPPER) !*********************************************************************** !* INSPECTS THE REGISTERS DEFINED BY UPPER AND THE GLOBAL * !* ARRAY 'GRMAP'. ANY INTERMEDIATE RESULTS IN THESE REGISTERS * !* ARE TRANSFERED TO CORE BY 'BOOT OUT' * !* UPPER=4 FOR GRS 1-3 & 15 (CORRUPTED BY PERM) * !* UPPER=8 FOR GRS 1-3 & 15 +FRS 0-6 (CORRUPTED BY FN CALL) * !*********************************************************************** %INTEGER I,REG %CYCLE I=0,1,UPPER REG=GRMAP(I) BOOT OUT(REG) %IF REGISTER(REG)=1 %REPEAT %END %ROUTINE SET USE(%INTEGER R,U,I) !*********************************************************************** !* NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I' * !*********************************************************************** CCSTATE=-1 %IF CCSTATE&255=R %IF U=12 %THEN PUSING(R) %IF REGISTER(R)>=0 %THEN %C GRUSE(R)=U %AND GRINF(R)=I %AND GRAT(R)=GRATCNT %AND GRATCNT=GRATCNT+1 %END %ROUTINE BOOT OUT(%INTEGER REG) !*********************************************************************** !* IF THE SPECIFIED REGISTER CONTAINS AN INTERMEDIATE RESULT * !* (USE=1) OR PARAMETER EN-ROUTE TO A ROUTINE (USE=15) THEN FREE * !* THE REGISTER BY TRANSFERRING ITS CONTENTS TO CORE * !*********************************************************************** %INTEGER J,USE,BASE %RECORD (RD) %NAME OPND %IF DCOMP#0 %START PRINTSTRING(" regs at boot out") PRINT USE %FINISH USE=GRUSE(REG) %IF USE=1 %OR USE=15 %THENSTART %IF USE=15 %THEN BASE=WSPR %AND J=REG<<2+64 %ELSESTART OPND==RECORD(ADDR(ASLIST(GRINF(REG)))) ABORT %UNLESS OPND_FLAG=9 %AND OPND_D<0 GET WSP(J,1+REG>>4) OPND_XB=RBASE; OPND_D=J; BASE=RBASE %FINISH DUMP(ST+REG&16,REG&15,J,0,BASE) FREE AND FORGET(REG) %FINISH %END %ROUTINE FINDREG(%INTEGER CONTROL, %INTEGERNAME REG) %INTEGER I,J,K,LAST,LAT,AND,AD %IF CONTROL=FR0 %THEN AND=31 %ELSE AND=15 AD=ADDR(CONTROL); LAT=GRATCNT %CYCLE J=0,1,2 LAST=-1 %CYCLE K=BYTE INTEGER(AD+2),SHORT INTEGER(AD),BYTE INTEGER(AD+3) I=K&AND BOOT OUT(I) %IF REGISTER(I)=1 %AND J=2 %IF REGISTER(I)=0 %THENSTART ->FOUND %IF GRUSE(I)<=1 %OR J>0 %IF GRAT(I)0 %THEN ->FOUND %REPEAT ABORT FOUND:REG=I&15 ! SAFE REG REQD %END %ROUTINE CLAIM(%INTEGER CONTROL, %INTEGERNAME REG) %INTEGER I FIND REG(CONTROL,I) %IF CONTROL=FR0 %THEN I=I+16 REGISTER(I)=1 REG=I&15 %END %ROUTINE FIND USE(%INTEGERNAME REG, %INTEGER TYPE,USE,INF) %INTEGER I,L,U,J,MASK L=1; U=16; MASK=15 %IF TYPE=2 %THEN L=16 %AND U=22 %AND MASK=31 %ELSE TYPE=1 %CYCLE J=L,TYPE,U I=J&MASK %IF GRUSE(I)=USE %AND (GRINF(I)=INF %OR INF=-1) %THEN %C GRAT(I)=GRATCNT %AND GRATCNT=GRATCNT+1 %AND REG=I %ANDRETURN %REPEAT REG=-1 %END %ROUTINE FIND SEQ(%INTEGERNAME ONE,TWO) !*********************************************************************** !* FINDS TWO REGISTERS FOR LM OR STM THAT ARE ADJACENT * !* ALLOWING FOR WRAP AROUND. NOT USED VERY MUCH SO IS FAIRLY * !* PRIMITIVE COMPARED TO 'FIND REG' * !*********************************************************************** %INTEGER J,P1,P2,K %CYCLE K=0,1,1 %CYCLE J=14,1,RBASE+31; ! TWO PASSES THROUGH GRS P1=J&15; P2=(J+1)&15 ->FOUND %IF REGISTER(P1)=0 %AND REGISTER(P2)=0 %AND (J>=30 %OR %C GRUSE(P1)<=1>=GRUSE(P2)) %REPEAT SAVEIRS(4) %REPEAT ABORT; ! ALMOST INCONCEIVABLE! FOUND:ONE=P1; TWO=P2 %END !******END OF REGISTER ALLOCATING ROUTINES******* ! ! !*********************************************************************** !* START OF TAG HANDLING ROUTINES * !* TAGS TAKE THE FORM * !* S1=PTYPE<<16!USEBITS<<14!LEVEL<<8!BASEREG<<4!DIMENSN * !* S2=SECONDARY DISP<<16!ITEM SIZE * !* S3=PRIMARY DISP<<16!FORM * !* WHERE:- * !* PTYPE=ROUT,NAM,ARR & TYPE PACKED INTO 16 BITS * !* USEBITS(L-R)= ANY USE,STORED,ADDRESSED,READ * !* LEVEL=TEXTUAL LEVEL OF DECLARATION * !* BASEREG & DIMENSN ARE OBVIOUS * !* * !* SNDARY DISP(SIGNED)= DISP OF A0 FROM LEVEL PTR * !* PRMY DISP= POSITION OF ITEM OR ITS POINTER IN STACK FRAME * !* FORM=POINTER TO FORMAT(RECORDS) OR VALUE (%CONSTS) * !*********************************************************************** ! %ROUTINE NOTE ASSMENT(%INTEGER REG,ASSOP,VAR) !*********************************************************************** !* NOTES THE ASSIGNMENT TO SCALAR 'VAR'. THIS INVOLVES REMOVING * !* OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE* !* ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-' * !*********************************************************************** %INTEGER I,J,K,L,U,AND,STEP,CCS K=TAGS(VAR); L=14; U=RBASE+15; AND=15; STEP=1 %IF TYPE=2 %THENSTART L=16; U=22; AND=31; STEP=2; REG=REG!16 %FINISH %IF CCSTATE&255=REG %THEN CCS=CCSTATE %ELSE CCS=0 %CYCLE I=L,STEP,U; J=I&AND FORGET(J) %IF K=GRINF(J)&X'FFFF' %AND REGISTER(J)=0 %AND (GRUSE(J)=3 %OR GRUSE(J)=9) %REPEAT ->LABEL99 %IF REG<0 %OR (GRUSE(REG)=2 %AND 0<=GRINF(REG)<=2) ->LABEL99 %IF REGISTER(REG)<0 SET USE(REG,3,K) CCSTATE=CCS %UNLESS CCS=0 LABEL99:%END %ROUTINE STORE TAG(%INTEGER KK,SLINK) %INTEGER Q Q=PTYPE<<16!LEVEL<<8!RBASE<<4!J SLINK=SLINK<<16!KFORM&X'FFFF' PUSH123(TAGS(KK),Q,INTEGER(ADDR(SNDISP)),SLINK) DECMADE=1 NTYPE(KK)=NTYPE(KK)!1<>16; USEBITS=KK>>14&3 OLDI=KK>>8&63; I=KK>>4&15; J=KK&15 INTEGER(ADDR(SNDISP))=INTEGER(ADDR(ASLIST(TCELL))+4) INTEGER(ADDR(K))=INTEGER(ADDR(ASLIST(TCELL))+8) 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(FROMAR2(P)) %IF PTYPE=SNPT %THENSTART 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 REPLACE 1(P,Q) REPLACE3(P,INTEGER(ADDR(K))) %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 'BC MASK,PERMENTRY(N)' * !* IF MASK=0 THEN PLANT A BAL ON REG 15 * !*********************************************************************** %INTEGER CODE CODE=BC %IF MASK=0 %THENSTART CCSTATE=-1 SAVE IRS(8) FAULT(202,0) %UNLESS REGISTER(15)=0 CODE=BAS; MASK=15 %FINISH %IF N>=10 %THEN PLABS(N)=PLABS(N)!X'80000000' PJUMP(CODE,PLABS(N)&x'ffffff',MASK,15) %IF CODE=BAS %THENSTART FORGETM(8) SET USE(15,12,CA) %IF CA>4000 %FINISH %END %ROUTINE ADJUST INDEX(%INTEGER MODE, %INTEGERNAME INDEX,DISP) !*********************************************************************** !* THIS IS THE GENERAL SOLUTION TO LACK OF ADDRESSABILITY. IT IS * !* CALLED WHEN DISP IS OUTSIDE THE RANGE 0->4095 AND MANIPULATES * !* INDEX ACCORDINGLY. FREQUENTLY INDEX=0 (NO INDEXING) WHEN THE * !* SOLUTION IS TRIVIAL. MODE=0 IF INDEX MUST BE COPIED BEFORE * !* BEING ADJUSTED. * !*********************************************************************** %INTEGER J,K,D,PN FIND REG(GR1,J); ! MAY NOT BE NEEDED %IF DISP>0 %THENSTART K=X'5A'; D=DISP %FINISHELSESTART K=X'5B'; D=4095-DISP %FINISH PN=D>>12; ABORT %IF PN>PTLAST %IF INDEX=0 %AND DISP>0 %THENSTART FIND USE(INDEX,1,11,PN); ! LOOK FOR 4K MULTIPLE ->LABEL98 %IF INDEX>0 SET USE(J,11,PN) INDEX=J; K=X'58' %FINISHELSESTART %IF MODE=0 %OR INDEX=0 %THENSTART %IF MODE=0 %THEN PRR(LR,J,INDEX) %ELSESTART PRR(SLR,J,J) CCSTATE=-1 %FINISH INDEX=J %FINISH FORGET(INDEX) %UNLESS GRUSE(INDEX)<=1 %FINISH PIX RX(K,INDEX,CODER,0,PN<<2+PLABS(0)) LABEL98:DISP=DISP&4095 %END %ROUTINE DUMP(%INTEGER CODE,REG,DIS,X,LEVEL) !*********************************************************************** !* OUTPUT A D(X,B) FORMAT INSTRN ADJUSTING FOR D>4095 * !* ALSO COOSING A REGISTER FOR R1 IF THIS IS NEGATIVE * !*********************************************************************** %INTEGER K %UNLESS 0<=DIS<=4095 %THEN ADJUST INDEX(REGISTER(X)+1,X,DIS) ->REG KNOWN %IF REG>=0 %IF REG=-1 %THEN K=GR0 %ELSE K=GR1 %IF 96<=CODE<=127 %THEN K=FR0 %IF REG<0 %THEN FIND REG(K,REG) %AND NEST=REG REGKNOWN: ->NORMAL %UNLESS CODE=X'41' %AND DIS=0; ! OPTIMISE LA ->ZERO %IF X=0=LEVEL ->SWOP %IF LEVEL=0 %OR X=0 ->NORMAL %IF X#REG#LEVEL PRR(AR,REG,X+LEVEL-REG); CCSTATE=1<<16!REG; ->LABEL99 ZERO: PRR(SLR,REG,REG); CCSTATE=1<<16!REG; ->LABEL99 SWOP: PRR(LR,REG,X+LEVEL) %UNLESS REG=X+LEVEL; ->LABEL99 NORMAL:PIX RX(CODE,REG,X,LEVEL,DIS) LABEL99:%END %ROUTINE DUMPSI(%INTEGER OPCODE,L,B,D) %IF D>4095 %THEN ADJUST INDEX(REGISTER(B)+1,B,D) pix si(OPCODE,L,B,D) %END %ROUTINE DUMPM(%INTEGER OPCODE,R1,R2,B,D) %IF D>4095 %THEN ADJUST INDEX(REGISTER(B)+1,B,D) PIX RX(OPCODE,R1,R2,B,D) %END %END %END %ENDOFFILE