! ! ALGOL 1.5 DATED NOV 76 ! 1) CONTAINS CORRECTION TO GIVE ERROR MESSAGE FOR THE ! %FOR..%DO %BEGIN...%END %ELSE %BEGIN CONSTRUCT WHICH IS INVALID ! 2) CHOPS RATHER THAN FAULTING LONG STRING CONSTANTS ! 3) CHECKS FOR BEGINS IN SYNTACTICALLY INCORRECT STATEMENTS TO ! REDUCE THE ERRONEOUS FAULT MESSAGES WHEN LEVELS MISMATCH ! 4) CONTAINS THE BINARY IO ROUTINE NAMES ! 5) STORES PLT DESCRIPTOR CORRECTLY IN EXTERNAL PROCEDURES ! ! ALGOL 1.6 DATED 1ST DEC 76 ! 1) CONTAINS CORRECTION TO READ1900 (MISTYPED AS INTEGERPROC) ! 2) CONTAINS CORRECT SPACE ALLOCATION SO THAT STORED VALUE ! OF STACKFRONT IN PROCEDURES IS NOT CORRUPTED ! 3) USES SYTEMROUTINE STOP TO STOP ! 4) AVOIDS TRYING TO ADD ACC INTO B ! ! ALGOL 1.7 DATED 1ST JAN 77 ! 1) HAS INCREASED SPACE IN EXPOP FOR TEMPORARY STACKED OPERANDS ! 2) REMOVES ABORT IN GOTOLAB FOR SWITCHES WITH NO LOCAL LABELS ! 3) AVOIDS STACK TWIST IF B&ACC CLAIMED THEN A MULTI DIMENSION ! ARRAY ELEMENT IF FETCHED ! ! ALGOL 1.8 DATED 1ST FEB 77 ! 1) CHANGE TO DEAL WITH ARRAYS WITH CONSTANT BOUNDS WHOSE SIZE ! IS >X1FFFF BYTES. ! 2) CHANGED TO ALLOW THE UNDOCUMENTED BUT FREQUENT '**' FOR ** ! 3) CHANGE TO GET LEVELS RIGHT IN SEPERATELY COMPILED PROCEDURES ! ! ALGOL 1.9 DATED 1ST MARCH 77 ! 1) CONTAINS CORRECTION TO BUILT IN FN CODE ! 2) RELAXES THE CHECK ON FORMAL PROCEDURES TO ALLOW CROSS LANGUAGE ! PROCEDURE PASSING (AS WELL AS CROSS CALLING) ! 3) AVOIDS CORRUPTING LINE NO OCCAISIONALLY AFTER PARAM NOT DESTN ! 4) CHANGES DA&SQ RTS TO SYSTEM ROUTINES AND ADDS RWNDSQ ! ! ALGOL 1.10 DATED 7TH MARCH 77 ! 1) CONTAINS CHECK ON PARAMETERS PASSED TO SEPARATELY COMPILED PROCS ! 2) CONTAINS A %PROGRAM (NAME) STATEMENT TO REDEFINE S#GO ! 3) HAS CHANGES TO DTABLE TO PASS NAME PARAMETERS FOR NDIAGS ! 4) HAS PARM FREE FORMAT TO ALLOW TEXT NOT SEQUENCE NOS IN 72-80 ! 5) HAS EXTRA CODE IN MAIN PROGRAM ENTRY SEQ TO ALLOW FOR EXTRA ! PARAMETER ON STACK IN K STANDALONE ! 6) CONTAINS PARTIAL KEYWORD VALIDATION IN LEXICAL SCAN TO AID ! RECOVERY FOR UNMATCHED SINGLE QUOTES ! 7) USES BOUNDED (L=1) DESCRIPTORS FOR PASSING SCALARS BY NAME ! IN PLACE OF BOUND INHIBITED (L=0) DESCRIPTORS. [FOR F1] ! ! ALGOL 2.0 DATED 1ST MAY 77 ! THIS HAS NO CHANGES BEING 1.10 LINKED WITH OMF PRODUCING LPUT ! ! ALGOL 2.1 DATED 1ST JUNE 77 ! 1) HAS CORRECTION TO CALL THUNKS FOR ACCESSING MULTI-DIMENSION ! ARRAYS WITH ESCAPE SUBROUTINES AS PARAMETERS.(J.JAMIESONS' FLT) ! ! 2) HAS EDITING CORRECTION TO CHANGES FOR 1.10.7(CALL THUNKS) ! 3) HAS INCHAR,OUTCHAR CLOSESTREAM &PAPERTHROW ADDED ! 4) HAS ALL INTINSICS TAGGED WITH S#(=ICL9CE) ! 5) HAS THE PARAMETERS OF FAULT CHANGED AS PER ALGOL 60M AND THE ! THE REFERENCE NAME CHANGED T0 "AFAULT" TO AVOID CONFUSION ! 6) HAS CPUTIME & NCODE CHANGED TO SYSTEM ROUTINE ! 7) HAS TOP BIT SET IN AREA WHEN DEFINING PRINCIPAL ENTRYPOINT ! 8) HAS PASSING CONSTANTS DIRECTLY AS NAME PARAMETERS RESTRICTED ! TO PARM(OPT) COMPILATIONS TO GET PARAM NOT DESTINATION. ! ! ALGOL 2.2 DATED 1ST AUGUST 77 ! 1) CHANGES TO SW(9) OF CSS TO FAULT DECLNS AFTER DUMMY STMNT ! 2) CHANGES TO BIP(1005) TO CHECK FOR %BEGIN & %END IN COMMENTS ! AND UPDATE LINE SO STMNT NO STAYS IN STEP WITH THOSE NUMBERS ! ASSIGNED(ACTUALLY WRONGLY!) BY THE LEXICAL SCANNER. ! 3) CHANGES TO DOWN LIST TO GIVE CORRECT STMNT NOS WHEN FAULTING ! INCONSISTENT EXTERNAL PROCEDURE HEADINGS ! 4) OMITS IRRELEVANT ERROR ROUTINES WHEN COMPILING WITHOUT FULL CHKS ! 5) HAS MINOR CHANGES TO 'FOR' STMNT TO IMPROVE CODE WHEN FINAL ! VALUE IS SCALAR PASSED BY NAME ! 6) HAS CHANGES TO REDUCE UNNECESSARY AUX STACK SAVING WHEN ! PASS 2 INDICATES NO LABEL OR SWITCH PARAMETERS SO THERE CAN ! BE NO EXPECTED JUMPING OUT OF BLOCKS ! 7) HAS CHANGE FOR JOBBER MODE SO THAT PARM STACK IS NOT NOT ! ASSUMED WHEN SOURCE FILE SIZE IS NOT KNOWN ! 8) HAS CHANGE TO FAULT TO ALLOW FOR BEGIN IN SYNTAXED STMNT WITHOUT ! GETTING REMAINING LINE NOS ONE OUT ! 9) HAS CHANGE TO REAL**REAL SUBROUTINE TO PREVENT OVERFLOW WHEN ! Y IS A SMALL NEGATIVE INTEGER ! 10)HAS ODD ALIGNMENT OF STACKFRAMES READY FOR PRECALL ! 11)INTRODUCES FN PTROFFSET TO PAVE THE WAY FOR CONTRACTION OF ! THE SIZE OF THE DISPLAY ! 12)CHANGES THE TABLE CSNAME TO ALLOW SUBSTITUTION PARAMETERS ! TO BE PASSED TO READ SYMBOL(ETC) ! 13)CHANGES TO THE STORING OF STRINGS IN WORKFILE TO SAVE SPACE ! 14)CHANGES TO RESET STACK TO STOP RESETTING DIAGPOINTER WITH ! ITS CURRENT VALUE WHEN JUMPING OUT OF A FOR BLOCK ! 15)ADDS A SMALL OPTIMISATION IN ROUTINE CSTMNT TO AVOID JUMPING ! AROUND A ONE INSTRUCTION JUMP IN 'IF'...'THEN' 'GOTO' L ! ALGOL 3.0 DATED NOV 77 ! 1) HAS CHANGES FOR ALGOL60M AS PER CHANGE PROPOSAL ! 2) HAS CHANGES TO ALLOW STRINGNAME PARAMETERS TO CODE ! 3) HAS CORRECTION TO GIVE CORRECT LINE NO WHEN A RUN TIME FAULT ! OCCURRS DURING EVALUATION OF AN ARRAY BOUND PAIR ! 4) HAS CHANGE TO STOP FAULT 25 WHEN FOR VARIABLE NOT SET ! 5) HAS CORRECTION IN DECLARE ARRAY TO AVOID MISSING OUT 2ND ELEMNT ! WHEN SCANNING FOR PARAMETRIC ARRAYS ! 6) HAS CHANGE TO REXP TO AVOID CORRUPTING B WHEN GOING OFF ! TO THE LOG-EXP SUBROUTINE ! 7) HAS CHANGE IN CEND TO PUT ARRAYS IN DIAG TABLES ! 8) HAS ON CONDITION IN ROUTINE CONST ! 9) ALLOWS @ AS ALT TO & IN CONST AS PER ICL MANUAL ! ! ALGOL 3.1 DATED MAR78 ! 1) TRAPS OVERFLOW IN CONST WITHOUT AN "%ON %EVENT" ! 2) REMOVES FAULT 202 FROMCUI AS THIS CASE CAN ARISE WITH ! A BIZARRELY ERRONEOUS PARAMETER LIST ! 3) TAKES MORE CARE IN RHEAD AGAINST DUPLICATE PROCEDURE BODIES ! ! ALGOL 4.0 DATED MAY 78 ! 1) HAS NEW INSTRNS AND ASSOCIATED CHANGES ! 2) HAS PROPER METHOD OF FORMING CONSTANT TABLE ! 3) FORMATS ASL ON THE FLY TO MINIMISE OVERHEADS ON SMALL PRGS ! 4) HAS JOBBER MODE BIT AND NEW AREA DETERMINING CODE ! 5) OVERLAYS THE WORKING ARRAYS TO REDUCE W-SET SIZE ! 6) HAS MEND IN CANAME FOR FIXING REAL ARRAY SUBSCRIPTS ! 7) AVOIDS H-W BUG ON 50S & 60S RE JUMPS TO CODE DESCRPTRS ! 8) REMOVES ROUNDING TO WORD BNDR FROM CLAIM AS AS NO ALGOL ARRAYS ! ARE LESS THAN WORD SIZED! ! 9) DEALS WITH BOOLEAN CONTROL VARIABLE IN FOR LOOPS ! 10)ALLOWS INCORRECT NAMES IN FORMAL PROC COMMENT WITHOUT ! GETTING ARRAY BOUND EXCEEDED ! 11)GIVES CORRECT STSMNT NO WHEN FAILING AFTER %F %THEN %BEGIN ! ...%END %ELSE BUM STATEMENT CONSTRUCT ! 12)ALLOWS @ AS CONSTANT BY ITSELF AS WELL AS AFTER DIGIT ! 13)ACCEPTS THE (EMAS ONLY) OPTION PARM(DYNAMIC) ! ALGOL 50 DATED MARCH 79 ! 1) HAS GENERALISATION TO I-RESULTS IN STACK FRAME(RPTYPE=7) ! FOR BETTER USE OF CONSTANTS AND ASSOCIATED CHANGES TO FN RESULTS ! 2) HAS CORECTION TO OPTIMISED **2 CODE TO SAVE ACC WHEN NEEDED ! 3) RELOCATES DESRCIPTORS TO CONSTS IN CTABLE CORRECTLY ! 4) HAS COMPILER ENVIRONMENT BIT AND TITLE SUPPRESSION ! 5) HAS CALL OF SIGNAL 9 (INSTEAD OF 0) IN JOBBER MODE ! 6) HAS EXTRA LINE TO RESET Q AFTER BUM SYNTAX STATEMENT ! 7) BETTER CODE IN COMPARE FOR SYNTAX FAULT AFTER HAVING GONE ! "DOWN" A TEXTUAL LEVEL ! ! ALGOL 51 DATED OCTOBER 79 ! 1) CHANGE TO SHORTCUTS IN COMPARE FOR LOWERCASE NAMES ! 2) FORGET OF ACCR IN EXPONETIATION ROUTINE ! 3) CHANGE TO AVOID ABORT ON UNDECLARED FOR VAR ! ! ALGOL 60 DATED JAN 80 ! 1) CHANGED ROUTINE PARAMETERS FOR GREATER COMPATABILITY WITH ICL ! 2) ADDITION OF <> FOR # AS COMPARATOR ! 3) ADDITION OF 'EQV' AS ALT TO 'EQUIV' IN BOOLEANS ! 4) RESETIING OF GLACABUF AFTER LAST OF GLA DUMPED IN CASE OF ! ANY LATE GLA PLUGS ! 5) SETING KFORM=0 IN DECLARING OWN ARRAYS ! 6) KEYWORDS ALLOWED IN LOWER CASE ! 7) CORRECTION IN COMPILING LPL FOR FN RESULT OUT OF SCOPE ! 8) RESTRICTING ASL SO 128K AUXSTACK ENOUGH FOR MAXDICT ! 9) SUBDIVISION OF FAILED TO ANALYSE ERRORS ! 10)FAULT 105 MESSAGE ADDED & DOUBLE USE REMOVED ! 11)EBCDIC BIT NOTED &USED FOR STRINGS ETC ! 12) HAS SEPARATOR AFTER BEGIN TO HELP WITH DUMMY STMTS ! 13) CLEARS NAMES AT START OF PASS 3 IN CASE OF PROGS WITH ! NO VARIABLES ! 14) FAULTS MISPLACED SWITCHES AND PROCEDURES ! 15)FURTHER ATTAEMPTS TO FAULT ELSES AFTER END OF FOR BLK ! 16)ADDS TWO NEW ROUTINES PUTARRAY & GETARRAY ! 17) HAS ROUTINE FAULTMK FOR VMEB DISPLAY FEATURE ! 18)HAS LINE INSTEAD OF STATEMENT NUMBERS ! STILL NEEDED:- BETTER CODE FOR REAL FORS WITH CONSTANT STEPS %MAINEP ICL9CEZALGOL; %TRUSTEDPROGRAM %BEGIN %CONSTINTEGER YES=1 %CONSTINTEGER NO=0 %CONSTINTEGER ALLOW CODELIST=YES %CONSTINTEGER INCLUDE HANDCODE=NO {GT} %CONSTINTEGER VMEB=NO; ! YES FOR ISSUING TO ICL %INTEGER I, J, K ! PRODUCED FROM ALGOLPS8 BY PSPROG2S ON 07/08/80 %CONSTINTEGERARRAY SYMBOL(1300: 2279)= 1305, 1305, 1001, 1018, 1305, 1313, 1311, 44, 1001, 1018, 999, 1313, 1000, 1324, 1318, 1001, 1044, 1356, 1320, 1003, 1324, 40, 1324, 41, 1349, 1343, 201, 198, 1454, 212, 200, 197, 206, 1010, 1038, 1313, 1011, 1349, 197, 204, 211, 197, 1324, 1349, 1010, 1038, 1313, 1011, 1349, 1356, 1354, 1039, 1313, 999, 1356, 1000, 1374, 1365, 1030, 1041, 1010, 1324, 1011, 1374, 1042, 1372, 40, 1010, 1763, 1011, 1779, 41, 1374, 1000, 1383, 1381, 44, 1010, 1324, 1011, 999, 1383, 1000, 1400, 1391, 1041, 1010, 1324, 1011, 1374, 1042, 1398, 40, 1010, 1763, 1011, 1779, 41, 1400, 1000, 1412, 1406, 212, 210, 213, 197, 1412, 198, 193, 204, 211, 197, 1435, 1417, 193, 206, 196, 1420, 207, 210, 1425, 201, 205, 208, 204, 1431, 197, 209, 213, 201, 214, 1435, 197, 209, 214, 1443, 1441, 206, 207, 212, 1471, 1443, 1471, 1447, 1447, 1435, 1447, 1454, 1452, 1412, 1435, 999, 1454, 1000, 1471, 1469, 201, 198, 1454, 212, 200, 197, 206, 1443, 197, 204, 211, 197, 1454, 1471, 1443, 1486, 1476, 1324, 1967, 1324, 1480, 1001, 1045, 1356, 1482, 1400, 1486, 40, 1454, 41, 1510, 1495, 201, 206, 212, 197, 199, 197, 210, 1500, 210, 197, 193, 204, 1508, 194, 207, 207, 204, 197, 193, 206, 1510, 1000, 1523, 1521, 59, 1601, 214, 193, 204, 213, 197, 1013, 1012, 1523, 1000, 1553, 1532, 204, 193, 194, 197, 204, 1026, 1300, 1541, 211, 215, 201, 212, 195, 200, 1043, 1300, 1550, 211, 212, 210, 201, 206, 199, 1028, 1300, 1553, 1486, 1553, 1578, 1562, 193, 210, 210, 193, 217, 1021, 1300, 1575, 208, 210, 207, 195, 197, 196, 213, 210, 197, 1022, 1300, 1623, 1578, 1017, 1300, 1586, 1584, 40, 1001, 1586, 41, 1586, 1000, 1593, 1591, 1593, 1001, 999, 1593, 1000, 1601, 1596, 44, 1601, 41, 1014, 58, 40, 1614, 1612, 195, 207, 205, 205, 197, 206, 212, 1005, 999, 1614, 1000, 1623, 1621, 59, 1601, 1013, 1523, 999, 1623, 1000, 1644, 1642, 59, 195, 207, 205, 205, 197, 206, 212, 1010, 40, 1001, 1586, 41, 1649, 1661, 1011, 1040, 1644, 1000, 1649, 1647, 58, 1649, 1000, 1661, 1659, 1644, 214, 193, 204, 213, 197, 1013, 1012, 1661, 1000, 1669, 1667, 1644, 1013, 1669, 1661, 1669, 1000, 1696, 1677, 204, 193, 194, 197, 204, 1718, 1685, 211, 215, 201, 212, 195, 200, 1718, 1693, 211, 212, 210, 201, 206, 199, 1718, 1696, 1486, 1696, 1718, 1704, 193, 210, 210, 193, 217, 1718, 1715, 208, 210, 207, 195, 197, 196, 213, 210, 197, 1718, 1718, 1017, 1718, 1722, 1722, 1001, 1722, 1729, 1727, 44, 1001, 999, 1729, 1000, 1737, 1733, 1001, 1383, 1737, 40, 1737, 41, 1754, 1752, 201, 198, 1454, 212, 200, 197, 206, 1729, 197, 204, 211, 197, 1737, 1754, 1729, 1763, 1761, 44, 1010, 1737, 1011, 999, 1763, 1000, 1779, 1766, 1008, 1770, 1001, 1356, 1035, 1773, 1324, 1035, 1776, 1454, 1035, 1779, 1737, 1035, 1788, 1786, 1593, 1010, 1763, 1011, 999, 1788, 1000, 1803, 1796, 1020, 1356, 58, 61, 1803, 1454, 1803, 1019, 1356, 58, 61, 1814, 1324, 1814, 1812, 1025, 1004, 1020, 1356, 58, 61, 999, 1814, 1000, 1825, 1823, 1025, 1004, 1019, 1356, 58, 61, 999, 1825, 1000, 1847, 1838, 211, 212, 197, 208, 1324, 213, 206, 212, 201, 204, 1324, 1845, 215, 200, 201, 204, 197, 1454, 1847, 1000, 1855, 1853, 44, 1324, 1825, 999, 1855, 1000, 1864, 1862, 44, 1324, 58, 1324, 999, 1864, 1000, 1876, 1868, 1017, 1300, 1876, 193, 210, 210, 193, 217, 1021, 1918, 1881, 1881, 1300, 1887, 1881, 1887, 1885, 44, 1876, 1887, 1000, 1897, 1890, 1897, 1897, 1041, 1324, 58, 1324, 1855, 1042, 1907, 1907, 1041, 1038, 1002, 58, 1038, 1002, 1907, 1042, 1918, 1916, 44, 1038, 1002, 58, 1038, 1002, 1907, 1918, 1000, 1923, 1923, 1300, 1897, 1923, 1929, 1927, 44, 1918, 1929, 1000, 1967, 1954, 208, 210, 207, 195, 197, 196, 213, 210, 197, 1022, 1033, 1010, 1001, 1018, 1578, 1015, 1510, 1614, 59, 1601, 1011, 2006, 2111, 1963, 193, 210, 210, 193, 217, 1021, 1024, 1876, 1967, 1017, 1023, 1300, 2006, 1970, 61, 1973, 62, 61, 1975, 62, 1978, 60, 62, 1981, 60, 61, 1983, 60, 1985, 35, 1988, 197, 209, 1991, 199, 197, 1994, 199, 212, 1997, 206, 197, 2000, 204, 197, 2003, 204, 212, 2006, 92, 61, 2015, 2013, 1029, 1001, 58, 1034, 2006, 2015, 1000, 2035, 2018, 2172, 2023, 198, 207, 210, 2035, 2033, 201, 198, 1454, 212, 200, 197, 206, 2006, 2088, 2035, 1040, 2050, 2050, 1010, 1004, 1356, 58, 61, 1324, 1825, 1011, 1847, 196, 207, 2006, 2078, 2070, 2053, 2172, 2058, 198, 207, 210, 2035, 2068, 201, 198, 1454, 212, 200, 197, 206, 2006, 2088, 2070, 1000, 2078, 2076, 1601, 2006, 2015, 1036, 2078, 1015, 2088, 2086, 194, 197, 199, 201, 206, 1015, 2088, 2050, 2106, 2096, 194, 197, 199, 201, 206, 2070, 2101, 198, 207, 210, 2035, 2104, 2172, 2151, 2106, 2151, 2111, 2109, 1001, 2111, 1000, 2151, 2120, 193, 204, 199, 207, 204, 2106, 1016, 2131, 197, 216, 212, 197, 210, 206, 193, 204, 2106, 1016, 2141, 198, 207, 210, 212, 210, 193, 206, 2106, 1016, 2147, 194, 197, 199, 201, 206, 2151, 1037, 1013, 2050, 2162, 2160, 197, 204, 211, 197, 1013, 2006, 2162, 2162, 1000, 2172, 2170, 194, 197, 199, 201, 206, 2070, 2172, 2050, 2186, 2177, 1025, 1004, 1788, 2180, 1001, 1356, 2186, 199, 207, 212, 207, 1737, 2280, 2190, 2015, 1006, 2198, 197, 206, 196, 1016, 1007, 2151, 1006, 2207, 195, 207, 205, 205, 197, 206, 212, 1005, 2211, 1486, 1929, 1006, 2219, 194, 197, 199, 201, 206, 2070, 1006, 2237, 211, 215, 201, 212, 195, 200, 1027, 1001, 1018, 1031, 58, 61, 1010, 1737, 1011, 1754, 1006, 2245, 207, 215, 206, 1032, 1486, 1864, 1006, 2251, 1029, 1001, 58, 1034, 2186, 2253, 59, 2261, 195, 207, 196, 197, 207, 206, 1006, 2270, 195, 207, 196, 197, 207, 198, 198, 1006, 2280, 208, 210, 207, 199, 210, 193, 205, 1001, 1006; %CONSTINTEGER SS= 2186 %CONSTINTEGER LAST SNAME=66; ! NO OF THE LAST SPECIAL NAME %OWNINTEGERARRAY SNNNO(0:LAST SNAME+1) %CONSTBYTEINTEGERARRAY TSNAME(0:LAST SNAME)=2,1(3),0,2(8),1,2,0(10),1,2, 0(6),1,0,0,2,0(3),1, 2,0,0,3,0(3),1,1,0(17); %CONSTINTEGERARRAY BYTES(0:4)=0,4,8,4,8 %CONSTINTEGERARRAY SIZECODE(0:5)=0,5,6,5,5,3; %OWNINTEGERARRAY FIXED GLA(0:13)=0, 0(3),-1,0,0(6),X'30000000',0; %CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48), 1(10),0(7),2(26),0(6),2(26),0(5),0(128) %CONSTINTEGERARRAY GRMAP(0:4)=0,1,3,5,7; %CONSTBYTEINTEGERARRAY ITOETAB(0 : 255) = %C X'00',X'01',X'02',X'03', X'37',X'2D',X'2E',X'2F', X'16',X'05',X'25',X'0B', X'0C',X'0D',X'0E',X'0F', X'10',X'11',X'12',X'13', X'3C',X'3D',X'32',X'26', X'18',X'19',X'3F',X'27', X'1C',X'1D',X'1E',X'1F', X'40',X'4F',X'7F',X'7B', X'5B',X'6C',X'50',X'7D', X'4D',X'5D',X'5C',X'4E', X'6B',X'60',X'4B',X'61', X'F0',X'F1',X'F2',X'F3', X'F4',X'F5',X'F6',X'F7', X'F8',X'F9',X'7A',X'5E', X'4C',X'7E',X'6E',X'6F', X'7C',X'C1',X'C2',X'C3', X'C4',X'C5',X'C6',X'C7', X'C8',X'C9',X'D1',X'D2', X'D3',X'D4',X'D5',X'D6', X'D7',X'D8',X'D9',X'E2', X'E3',X'E4',X'E5',X'E6', X'E7',X'E8',X'E9',X'4A', X'E0',X'5A',X'5F',X'6D', X'79',X'81',X'82',X'83', X'84',X'85',X'86',X'87', X'88',X'89',X'91',X'92', X'93',X'94',X'95',X'96', X'97',X'98',X'99',X'A2', X'A3',X'A4',X'A5',X'A6', X'A7',X'A8',X'A9',X'C0', X'6A',X'D0',X'A1',X'07', X'20',X'21',X'22',X'23', X'24',X'15',X'06',X'17', X'28',X'29',X'2A',X'2B', X'2C',X'09',X'0A',X'1B', X'30',X'31',X'1A',X'33', X'34',X'35',X'36',X'08', X'38',X'39',X'3A',X'3B', X'04',X'14',X'3E',X'E1', X'41',X'42',X'43',X'44', X'45',X'46',X'47',X'48', X'49',X'51',X'52',X'53', X'54',X'55',X'56',X'57', X'58',X'59',X'62',X'63', X'64',X'65',X'66',X'67', X'68',X'69',X'70',X'71', X'72',X'73',X'74',X'75', X'76',X'77',X'78',X'80', X'8A',X'8B',X'8C',X'8D', X'8E',X'8F',X'90',X'9A', X'9B',X'9C',X'9D',X'9E', X'9F',X'A0',X'AA',X'AB', X'AC',X'AD',X'AE',X'AF', X'B0',X'B1',X'B2',X'B3', X'B4',X'B5',X'B6',X'B7', X'B8',X'B9',X'BA',X'BB', X'BC',X'BD',X'BE',X'BF', X'CA',X'CB',X'CC',X'CD', X'CE',X'CF',X'DA',X'DB', X'DC',X'DD',X'DE',X'DF', X'EA',X'EB',X'EC',X'ED', X'EE',X'EF',X'FA',X'FB', X'FC',X'FD',X'FE',X'FF' %CONSTINTEGER MAXLEVELS=31 %CONSTINTEGER UNASSPAT=X'81818181' %CONSTINTEGER JOBBERBIT=X'40000000'; ! BIT FOR JOBBER MODE %CONSTINTEGER CEBIT=1; ! BIT FOR RUNNING UNDER COMPILER ENVIRONMENT %CONSTINTEGER MAXDICT=X'100'; ! BIT FOR MAXIMUM DICTIONARY ! ! THE PRINCIPAL OPCODES ARE HERE DEFINED AS THEIR MNEMONICS(AMENDED) ! %CONSTINTEGER LB=X'7A',SLB=X'52',STB=X'5A',ADB=X'20',CPB=X'26', %C MYB=X'2A',SBB=X'22',CPIB=X'2E' %CONSTINTEGER LD=X'78',LDA=X'72',INCA=X'14',STD=X'58',LDB=X'76', %C LDTB=X'74',LDRL=X'70',CYD=X'12',MODD=X'16' %CONSTINTEGER STLN=X'5C',ASF=X'6E',ST=X'48',RALN=X'6C',LXN=X'7E' %CONSTINTEGER LLN=X'7C',LSS=X'62',SLSS=X'42',MPSR=X'32',STSF=X'5E' %CONSTINTEGER LUH=X'6A',STUH=X'4A',LSD=X'64',SLSD=X'44',PRCL=X'18' %CONSTINTEGER LSQ=X'66',SLSQ=X'46',STXN=X'4C',LCT=X'30',STCT=X'36' %CONSTINTEGER JUNC=X'1A',JLK=X'1C',CALL=X'1E',EXIT=X'38',JCC=2, %C JAT=4,JAF=6,DEBJ=X'24',CPSR=X'34',ESEX=X'3A' %CONSTINTEGER IAD=X'E0',ICP=X'E6',USH=X'C8',ISB=X'E2',IRSB=X'E4' %CONSTINTEGER OR=X'8C',UCP=X'C6',IMY=X'EA',IMDV=X'AE',AND=X'8A' %CONSTINTEGER ISH=X'E8',NEQ=X'8E' %CONSTINTEGER RAD=X'F0',RSB=X'F2',RRSB=X'F4',FLT=X'A8',RRDV=X'BC', %C RSC=X'F8',FIX=X'B8',RMY=X'FA',RCP=X'F6' ! %CONSTINTEGER MVL=X'B0',MV=X'B2' %CONSTBYTEINTEGERARRAY OCODE(-1:47)=X'1E',X'1C',2(14),X'1A',4(16),6(16); ! JLK=1C,J=1A,JCC=2,JAT=4,JAF=6 ! ! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS ! %CONSTINTEGER ACCR=0,DR=1,LNB=2,XNB=3,PC=4,CTB=5,TOS=6,BREG=7 %CONSTBYTEINTEGERARRAY LDCODE(0:7)=0,X'78',X'7C',X'7E',0,48,0,X'7A'; ! %CONSTSTRING(4)DEFAULTMAINEP="S#GO" %CONSTSTRING(8)MDEP="S#NDIAG" %CONSTSTRING(8)SIGEP="S#SIGNAL"; ! EP FOR SIGNAL %CONSTSTRING(11)AUXSTEP="ICL9CEAUXST";! EP FOR AUX STACK %CONSTINTEGER LABBYNAME=1; ! BIT SET IN PASS2INF FOR LABS %CONSTINTEGER SWBYNAME=2; ! DITTO FOR SWITCHES AS PARAMS ! %CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE %INTEGER RPPTR, KYCHAR1, KYCHAR2, LEVELINF, RPBASE, ASLMAX, %C AUXST,CDCOUNT, FREE FORMAT, PASS2INF, P1SIZE, DICTBASE %INTEGER ASL, NNAMES, ARSIZE, CABUF, PPCURR, CREFHEAD, %C CONSTHOLE, CONSTPTR, CONSTBTM, CONSTLIMIT, ASL CUR BTM, %C LENGTH, NEXTP, N0, SNUM, RLEVEL, NMAX, USTPTR, PLABEL,%C LEVEL, CA, RR, TYPE, LASTNAME, STLIMIT, EBCDIC %INTEGER FAULTY, HIT, INHCODE, TTOPUT, LIST, ADFLAG, %C PARMLINE, PARMTRCE, PARMDIAG, PARMOPT, CTYPE, DCOMP, %C CPRMODE, PARMCHK, PARMARR, QFLAG, SMAP, PARMDYNAMIC %LONGREAL CVALUE, IMAX %INTEGER MASK, NEXT, N, ITEM, LOGEPDISP, EXPEPDISP, CODEPDISP,%C P, Q, R, STRLINK, LINE, S, T, U, V, NEST, FNAME, GLACA, %C GLACABUF, GLACURR, SSTL, QMAX, LASTLINE, LASTAT, SLINES, %C FILE ADDR, FILE PTR, FILE END, FILE SIZE, LASTEND, %C PARMBITS1, PARMBITS2, WKFILEAD, WKFILESEGS, GLARELOCS %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %RECORDFORMAT LISTF(%INTEGER S1,S2,S3,LINK) %BEGIN FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN PARMBITS1=COMREG(27) PARMBITS2=COMREG(28) WKFILEAD=COMREG(14) WKFILESEGS=INTEGER(WKFILEAD+8)>>18 %IF FILE ADDR=0 %THEN %START FILE SIZE=32000*(FILE ADDR+2) %FINISH %ELSE %START FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4) FILE END=FILE ADDR+INTEGER(FILE ADDR) FILE SIZE=INTEGER(FILE ADDR) %FINISH ARSIZE=WKFILESEGS<<16 NNAMES=511 %IF PARMBITS1&JOBBERBIT=0 %THEN %START %IF FILESIZE>32000 %THEN NNAMES=1023 %IF PARMBITS2&MAXDICT#0 %OR WKFILESEGS>2 %THEN NNAMES=2047 %FINISH %IF PARMBITS2&CEBIT=0 %OR PARMBITS1&JOBBERBIT#0 %START ! EMAS&JOBBER MODES PRINT HEADER NEWLINES(3); SPACES(5) PRINTSTRING( "EDINBURGH ALGOL 60M COMPILER ") PRINTSTRING( " VERSION 60") NEWLINES(3) %FINISH ASL=3*NNAMES %IF ASL>4095 %THEN ASL=4095 ASLMAX=ASL %END %RECORD(LISTF)%ARRAY ASLIST(0:ASL) %INTEGERARRAY SET, STACKBASE, RAL, FLAG, L, M, NMDECS, %C JROUND, NAMES(0:MAXLEVELS) %BYTEINTEGERARRAYFORMAT CCF(0:FILESIZE+7) %BYTEINTEGERARRAYNAME CC %INTEGERARRAYFORMAT AF(0:ARSIZE) %INTEGERARRAYNAME A,CCLINES %INTEGERARRAY WRD, TAGS(0:NNAMES) %SYSTEMROUTINESPEC LPUT(%INTEGER A, B, C, D) %ROUTINESPEC WARN(%INTEGER N,V) %ROUTINESPEC FAULT(%INTEGER N, VALUE) %ROUTINESPEC PRINT NAME(%INTEGER N) %ROUTINESPEC CLEARLIST(%INTEGERNAME HEAD) %ROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3) %ROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) %ROUTINESPEC POP(%INTEGERNAME C, %INTEGERNAME P, Q, R) %INTEGERFNSPEC MORE SPACE %ROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3) %INTEGERFNSPEC FIND(%INTEGER LAB, LIST) !%INTEGERFNSPEC FIND3(%INTEGER LAB, LIST) %ROUTINESPEC MLINK(%INTEGERNAME CELL) %STRING(31)MAINEP %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %IF VMEB=YES %THEN %START %SYSTEMROUTINESPEC FAULTMK(%INTEGER ONOFF) %FINISH %IF ALLOW CODELIST=YES %THEN %START %SYSTEMROUTINESPEC NCODE(%INTEGER A,B,C) %FINISH ! START OF COMPILATION CC==ARRAY(WKFILEAD+INTEGER(WKFILEAD+8)>>1, CCF) CCLINES==ARRAY(WKFILEAD+INTEGER(WKFILEAD+4), AF) A==ARRAY(ADDR(CC(0))+4096, AF) %BEGIN %ROUTINESPEC COMPARE %ROUTINESPEC PNAME(%INTEGER MODE) %INTEGERFNSPEC CONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT %ROUTINESPEC READ PRG %CONSTBYTEINTEGERARRAY ILETT(0:533)=3, 'A','B','S', 4,'I','A','B','S', 4,'S','I','G','N', 6,'E','N','T','I','E','R', 11,'C','L','O','S','E','S','T','R','E','A','M', 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', 6,'O','P','E','N','D','A', 6,'O','P','E','N','S','Q', 7,'C','L','O','S','E','D','A', 7,'C','L','O','S','E','S','Q', 5,'P','U','T','D','A', 5,'G','E','T','D','A', 5,'P','U','T','S','Q', 5,'G','E','T','S','Q', 6,'R','W','N','D','S','Q', 6,'I','N','C','H','A','R', 7,'O','U','T','C','H','A','R', 10,'P','A','P','E','R','T','H','R','O','W', 8,'P','U','T','A','R','R','A','Y', 8,'G','E','T','A','R','R','A','Y', 255 %CONSTBYTEINTEGERARRAY ITYPE(0:LAST SNAME+1)=0,130, 129(3),128,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(17); %INTEGER I, J, LL, DSIZE, SAVQ, ANALFAIL DSIZE=8*NNAMES %INTEGERARRAY NTYPE,DPOSN(0:NNAMES) %BYTEINTEGERARRAY LETT(0:DSIZE+20) CABUF=0; PPCURR=0; PASS2INF=0 LINE=1; RLEVEL=0; NMAX=0; USTPTR=0 LEVEL=0; CA=0; LASTAT=0 FAULTY=0; ADFLAG=0; STRLINK=0 DCOMP=0; CPRMODE=0 CONSTHOLE=0; CREFHEAD=0 NEXT=1 DICTBASE=ADDR(LETT(0)) LOGEPDISP=0; EXPEPDISP=0; CODEPDISP=0 IMAX=(-1)>>1; PLABEL=24999 SSTL=0; LASTLINE=1; SNUM=0; CDCOUNT=0; RPPTR=0 LETT(0)=0 N0=14; N=12 GLACA=N0<<2; GLACABUF=GLACA; GLARELOCS=0 GLACURR=0; PARMOPT=1; PARMARR=1 PARMLINE=1; PARMTRCE=1; PARMDIAG=1; INHCODE=0 LIST=1; PARMCHK=1 LEVELINF=0 I=PARMBITS1 EBCDIC=PARMBITS1>>22&1 STLIMIT=X'1F000' %IF I>>24&1#0 %THEN STLIMIT=COMREG(48) FREE FORMAT=I&X'80000'; ! FREE = NO SEQUENCE NOS QFLAG=I&1 LIST=0 %IF I&2#0 PARMLINE=0 %IF I&X'800000'#0 PARMDIAG=0 %IF I&4#0 PARMCHK=0 %IF I&16#0 PARMARR=0 %IF I&32#0 PARMDYNAMIC=I>>20&1; ! REFS ONTO DYNAMIC LISTHEAD %IF ALLOW CODELIST=YES %THEN DCOMP=I>>14&1;! PARM 'CODE' BIT TTOPUT=COMREG(40) SMAP=I>>7&1 PARMTRCE=0 %AND PARMDIAG=0 %IF I&64#0 %IF I&(1<<16)#0 %THEN %START PARMARR=0; PARMOPT=0 PARMLINE=0; PARMCHK=0; PARMDIAG=0 %FINISH MAINEP=DEFAULT MAINEP %IF QFLAG=0 %THEN KYCHAR1='%' %AND KYCHAR2=' ' %C %ELSE KYCHAR1='''' %AND KYCHAR2='''' %CYCLE I=0, 1, MAXLEVELS SET(I)=0; STACKBASE(I)=0; RAL(I)=0 FLAG(I)=0 L(I)=0; M(I)=0 JROUND(I)=0 NAMES(I)=-1 %REPEAT %IF INCLUDE HANDCODE=NO %START %CYCLE I=0, 1, NNAMES WRD(I)=0 TAGS(I)=0 NTYPE(I)=0 %REPEAT %FINISH %ELSE %START *LB_NNAMES *ADB_1 *MYB_4 *ADB_X'18000000' *LDA_WRD+4 *LDTB_%B *MVL_%L=%DR,0,0 *LDA_TAGS+4 *LDTB_%B *MVL_%L=%DR,0,0 *LDA_NTYPE+4 *LDTB_%B *MVL_%L=%DR,0,0 %FINISH ASL CUR BTM=ASL-240 CONST LIMIT=4*ASL CUR BTM-8 %CYCLE I=ASL CUR BTM,1,ASL-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(ASL CUR BTM)_LINK=0 ASLIST(0)_S1=-1 ASLIST(0)_S2=-1 ASLIST(0)_S3=-1 ASLIST(0)_LINK=0 K=0; LL=1; I=ILETT(0) %WHILE I<255 %CYCLE %CYCLE J=1, 1, I CC(J)=ILETT(J+K); ! COPY SPECIAL NAMES TO SOURCE %REPEAT; CC(J+1)=';' R=2; Q=1; PNAME(1); ! SPECIAL NAME TO DICTIONARY NTYPE(LASTNAME)<-ITYPE(LL)<<8 DPOSN(LASTNAME)=-1 SNNNO(LL)=LASTNAME LL=LL+1 K=K+I+1 I=ILETT(K) %REPEAT; ! AND COMPILED SNUM=LL-1 LASTAT=-2 LPUT(0, 1, 1, ADDR(LETT(1))) READPRG 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 ! ! MOVE CC DOWN ON TOP OF LINEARRAY AND THEN MAP A ONTO FREE WORKFILE ! LASTLINE=LINE I=(ADDR(CCLINES(LASTLINE+1))+15)&(-16) J=ADDR(CC(0)) %IF I>J %THEN FAULT(102,0) %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE K=0,1,LENGTH BYTEINTEGER(I+K)=CC(K) %REPEAT %FINISH %ELSE %START *LDTB_X'18000000'; *LDB_LENGTH *LDA_J; *CYD_0 *LDA_I *MV_%L=%DR %FINISH CC==ARRAY(I,CCF) NEWLINES(2) I=(ADDR(CC(LENGTH))+4095)>>12<<12 J=ADDR(CCLINES(0))+16*4096*WKFILESEGS %IF J>I %THEN I=J A==ARRAY(I, AF) ARSIZE=(WKFILEAD+WKFILESEGS<<18-I)>>2-512 SLINES=LINE Q=1; QMAX=1; LINE=1 %CYCLE R=0,1,7 A(R)=0 %REPEAT STACKBASE(1)=5; ! TO LINK GLOBAL PROCS R=8; LEVEL=1 %UNTIL Q>=LENGTH-6 %CYCLE SAVQ=Q; ! VERY EFFICIENT COMPARE DOES QMAX=Q; ! MINIMUM RESTTING Q MAY BE WRONG P=SS %WHILE CCLINES(LINE+1)<=Q %CYCLE; LINE=LINE+1; %REPEAT RR=R; A(R+1)=LINE R=R+2 ANALFAIL=0 COMPARE FAULT(102, 0) %IF R>ARSIZE %IF HIT=0 %THEN %START Q=SAVQ; ! ENSURE FAULT MSG IS RIGHT FAULT(100,ANALFAIL) R=RR %FINISH %ELSE %START A(RR)=R-RR %IF LEVEL=0 %THEN FAULT(14, 0) %AND %EXIT %FINISH %REPEAT !DEAL WITH END OF PROGRAM FAULT(15,0) %IF LEVEL>1 %OR JROUND(1)&255#0;! MISSING ENDS A(R)=0; R=R+1 A(R)=0; R=R+1 P1SIZE=R DICTBASE=ADDR(A(R)) R=R+(NEXT+7)>>2 RPPTR=(R+256)&(-256) RPBASE=RPPTR FAULT(102,0) %IF RPBASE>ARSIZE %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE I=0,1,NEXT BYTEINTEGER(DICTBASE+I)=LETT(I) %REPEAT %FINISH %ELSE %START *LDTB_X'18000000' *LDB_NEXT *LDA_LETT+4 *CYD_0 *LDA_DICTBASE *MV_%L=%DR %FINISH ->BEND ! ! THE ARRAY KEYCHK IS TO ALLOW ECMA KEYWORDS TO BE CHECKED. SINCE PASS 2 ! DOES A FULL CHECK THIS APPEARS UNNECESSARY BUT IT HELPS TO STOP THE ! LEXICAL SCANNER GETIING INTO TROUBLE WHEN SPARE SINGLE QUOTES ARE ! SCATTERED ABOUT THE SOURCE TEXT. ! FOR EACH INITIAL LETTER THERE IS A BITMASK. THE TOP 24 BITS INDICATE ! VALID SECOND LETTERS X'80000000'=A ETC AND THE BOTTOM 8 BIT INDICATE ! VALID KEYWORD LENGTHS 1=2LETTERS X'80'=9LETTERS ETC ! THE ARRAY IS BASE ON THE FOLLOWING ALGOL KEYWORDS:- ! ! AND,ALGOL,ARRAY,BOOLEAN,BEGIN,COMMENT,CODEON,CODEOFF,DO,DIV ! EQUIV,ELSE,EQ,END,EXTERNAL,FOR,FORTRAN,FALSE,GT,GE,GOTO,GO ! IF,IMPL,INTEGER,LABEL,LT,LE,NOT,NE,OR,OWN ! PROCEDURE,PROGRAM,POWER,REAL,SWITCH,STRING,STEP ! THEN,TRUE,TO,UNTIL,VALUE,WHILE ! %CONSTINTEGERARRAY KEYCHK('A':'Z')=%C X'0014400A',X'08020028',X'00020030',X'00820003', X'0014814F',X'8002002A',X'08021005',0, X'040C0025',0,0,X'88001009', 0,X'08020003',X'00004203',X'000240A8', 0,X'08000004',X'00001214',X'01024005', X'00040008',X'80000008',X'01000008',0, 0(2); %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'; %ROUTINE READ PRG %ROUTINESPEC GET LINE %INTEGER DEL %BYTEINTEGERARRAY BLINE(-20:161),TLINE(0:161) %CONSTINTEGER NBASICS=8 %CONSTINTEGER MAXSIZE=11 %CONSTINTEGERARRAY BASSYM(0:9)='<','[','>',']','(',123, ')',125,'-','_'; %INTEGERARRAY WORD(0:MAXSIZE+1) %INTEGER SIZE,LETTERFLAG,LL,LP,I,J,BLD0,BLD1 LL=0; LP=0 LENGTH=-4; DEL=0 %IF LIST#0 %THEN PRINTSTRING(" LINE ") %CYCLE K=-20,1,0 BLINE(K)=' ' %REPEAT BLD0=X'180000A1' BLD1=ADDR(BLINE(1)); ! BLD IS DECRPTR TO BLINE L2: LP=LP+1 %IF LP>LL %THEN %START GET LINE LP=1 %IF BLINE(1)=25 %THEN %RETURN %FINISH I=TLINE(LP) %IF 10#I<=31 %OR I>126 %THEN ->L2 %IF I='''' %AND QFLAG#0 %START ! ! QLAG=1 IFF PARM(BCD),IE USING 1900 OR D.I.N. REPRESENTATIONS ! LETTERFLAG=1 SIZE=0 %CYCLE LP=LP+1 %IF LP>LL %THEN GET LINE %AND LP=1 I=TLINE(LP) %EXIT %IF I='''' ;! ***END OF QUOTED WORD %IF 33<=I<=126 %START SIZE=SIZE+1 ;! ***LENGTH OF QUOTED WORD WORD(SIZE)=I %IF TRTAB(I)#2 %THEN LETTERFLAG=0 ! ! ***NOT ALL LETTERS-CANNOT BE KEYWORD ! CC(LENGTH+SIZE+4)=ULINED(I) %EXIT %IF SIZE>MAXSIZE %FINISH %ELSE %START %IF I=10 %THEN LINE=LINE+1 %AND %C CCLINES(LINE)=LENGTH+SIZE+6 %IF I=25 %THEN ->CODS %FINISH %REPEAT ! ! HAVE A KEYWORD OF SORTS IN WORD AND THE UNDERLINED VERSION OF SAME ! ALREADY PLACED IN CC ! ! CHECK FIRST FOR VALID UNDERLINED WORD ! %IF LETTERFLAG=1 %AND 0>((WORD(2)-1)&31)=0 %OR %C I&1<<(SIZE-2)=0 %THEN ->CODS LENGTH=LENGTH+SIZE I=CC(LENGTH+4) ->L2 %FINISH ! ! NEXT CHECK FOR NON ALPHABETIC BASIC SYMBOL USING TABLE BASSYM ! %IF SIZE=1 %THEN %START I=WORD(1); ! THE ONLY SYMBOL %IF I='/' %THEN %START CC(LENGTH+5)='D'+128 CC(LENGTH+6)='I'+128 CC(LENGTH+7)='V'+128 LENGTH=LENGTH+3; ->L2 %FINISH %CYCLE J=0,2,NBASICS %IF I=BASSYM(J) %THEN %START CC(LENGTH+5)=BASSYM(J+1) LENGTH=LENGTH+1; ->L2 %FINISH %REPEAT %FINISH ! %IF SIZE=2 %START %IF WORD(1)='1' %AND WORD(2)='0' %START LENGTH=LENGTH+1 CC(LENGTH+4)='&' ->L2 %FINISH %IF WORD(1)='*'=WORD(2) %START LENGTH=LENGTH+2 CC(LENGTH+3)='*' CC(LENGTH+4)='*' ->L2 %FINISH %FINISH ! ! KEYWORD IS A LOAD OF CODSWALLOP. STUFF IT INTO CC AND ALLOW ! NEXT PASS TO REPORT IT (NB IT MAY BE IN A STRING OR COMMENT) ! TREAT THE LAST QUOTE AS FIRST QUOTE AGAIN IN CASE OF A MISSING QUOTE ! CODS: LENGTH=LENGTH+1 CC(LENGTH+4)='''' %IF SIZE>0 %START %CYCLE I=1,1,SIZE LENGTH=LENGTH+1 J=WORD(I); CC(LENGTH+4)=J %REPEAT %FINISH %IF TLINE(LP)=M'''' %THEN LP=LP-1; ->L2 ! %FINISH %IF QFLAG=0 %START %IF I='%' %THEN DEL=128 %AND ->L2 DEL=0 %UNLESS TRTAB(I)=2 %IF DEL#0 %THEN I=ULINED(I) %FINISH ->L2 %IF I=' ' %IF I=NL %THEN %START LINE=LINE+1 CCLINES(LINE)=LENGTH+5 ->L2 %FINISH LENGTH=LENGTH+1; CC(LENGTH+4)=I ->L2 %ROUTINE GET LINE %SYSTEMROUTINESPEC IOCP(%INTEGER EP,N) %SYSTEMROUTINESPEC SIM2(%INTEGER EP,R1,R2,%INTEGERNAME R3) %INTEGER K,PU,ST,LS %CONSTBYTEINTEGERARRAY ITOI(0:255)=%C 32(10),10,32(14),25,26,32(5), 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 96,97,98,99,100,101,102,103,104,105,106,107,108,109, 110,111,112,113,114,115,116,117,118,119, 120,121,122,123,124,125,126,32, 26(5),10,26(10), 26(16), 26(14),92,38, 26(11),35,26(4), 26(16), 26(9),35,26(5),94, 26(32); LL=0 %IF FILE ADDR=0 %THEN %START; ! SOURCE NOT A 'CLEAN' FILE SIM2(0,ADDR(BLINE(1)),0,K) LL=K %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE K=1,1,LL BLINE(K)=ITOI(BLINE(K)) %REPEAT %FINISH %ELSE %START *LD_BLD0 *LDB_LL *LSS_ITOI+4 *LUH_X'18000100' *TTR_%L=%DR %FINISH %IF BLINE(1)=25 %THEN %START TLINE(1)=25; TLINE(2)=10 %RETURN %FINISH %FINISH %ELSE %START; ! SOURCE IN EMAS FILE %IF FILEPTR>=FILE END %THEN %START BLINE(1)=25; TLINE(1)=25 TLINE(2)=10; LL=2 %RETURN %FINISH %IF INCLUDE HANDCODE=YES %THEN %START *LDA_FILEPTR *LB_FILEEND *SBB_FILEPTR *ADB_X'18000000' *LDTB_%B *SWNE_%L=%DR,0,10 *JCC_8, *CYD_0 *STUH_%B *IAD_1 *ST_%B *ISB_FILEPTR *ST_LL *LDA_FILEPTR *STB_FILEPTR *LDB_LL *CYD_0 *LDA_BLD1 *STD_%TOS *MV_%L=%DR,0,0 *LD_%TOS *LSS_ITOI+4 *LUH_X'18000100' *TTR_%L=%DR ->OLIST %FINISH IMP: %UNTIL K=NL %OR K=0 %CYCLE K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE FILE PTR=FILE PTR+1 BLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT OLIST: %FINISH %IF LIST#0 %THEN %START %IF INCLUDE HANDCODE=NO %THEN %START WRITE(LINE, 5) BLINE(-5)=LL+4; ! SPACES(5) IOCP(15,ADDR(BLINE(-5))) %FINISH %ELSE %START *LSS_LINE *CDEC_0 *DSH_9 *LDTB_X'18000006' *LDA_BLD1 *INCA_-11 *CPB_%B *SUPK_%L=6,0,32 *INCA_-6 *LDB_6 *ANDS_%L=6,0,63 BLINE(-11)=LL+10 IOCP(15,ADDR(BLINE(-11))) %FINISH NEWLINE %FINISH %IF FREE FORMAT=0 %AND LL>73 %THEN BLINE(73)=10 %AND LL=73 PU=1; ST=1; LS=0 %IF INCLUDE HANDCODE=NO %THEN %START %IF QFLAG=1 %START %UNTIL K=10 %CYCLE K=BLINE(PU) PU=PU+1 %IF K#' '%THEN TLINE(ST)=K %AND ST=ST+1 %REPEAT %FINISH %ELSE %START %UNTIL K=10 %CYCLE K=BLINE(PU) PU=PU+1 %UNLESS K=' ' %AND (LS<'A' %OR LS>'Z') %THEN %C TLINE(ST)=K %AND ST=ST+1 %AND LS=K %REPEAT %FINISH LL=ST-1 %FINISH %ELSE %START *LD_BLD0 *LDB_LL *SWEQ_%L=%DR,0,32 *CYD_=0 *LDA_TLINE+4 *INCA_=1 *MV_%L=%DR *INCA_=-2; ! TO LAST SPACE *LSS_=32 BACK: *ICP_(%DR) *JCC_7, *INCA_=-1 *J_ OUT: *LSS_=10 *INCA_=1 *ST_(%DR) *STD_ST *LSS_LS *ISB_TLINE+4 *ST_LL %FINISH %END %END %ROUTINE COMPARE %ROUTINESPEC UP %LONGREAL ALIGN %INTEGER RA, RL, RP, RQ, RR, SSL, SC, RS, MARKER, ALT, PP, I, J, FAILNO %CONSTINTEGERARRAY OPMASK(0:7)=0,X'00350000',2,0(3),X'08008000',0; %SWITCH BIP(999:1045) %IF INCLUDE HANDCODE=YES %THEN %START I=ADDR(SYMBOL(1300))-4*1300 *LSS_I *LUH_X'28001000' *ST_ALIGN *JLK_2 *EXIT_-64 %FINISH SUBENTRY: RP=SYMBOL(P) RL=LEVEL %IF P=SS %START I=CC(Q) %IF TRTAB(I)#2 %AND I#'F'+128 %AND I#'G'+128 %AND %C (I#'I'+128 %OR CC(Q+1)#'F'+128) %START RQ=Q; RR=R; SSL=STRLINK; ALT=2; SC=LINE; P=P+1 RS=SYMBOL(P); RA=SYMBOL(RS); ->UPR %FINISH %FINISH P=P+1; PP=P ->COMM ! ROUTINE REALLY STARTS HERE BIP(999): ! REPEATING PHRASES A(RR)=ALT; P=PP; ! P BACK TO CURRENT PHRASE AGN COMM: ! COMMON INITIALISE CODEING %IF INCLUDE HANDCODE=NO %THEN %START RQ=Q; ! RESET VALUES OF LINE&AR PTRS RR=R SSL=STRLINK; ! SAVE STRLINK IN CASE BACK- SC=LINE; ! -TRACKING ACROSS A RT CALL %FINISH %ELSE %START *LSQ_Q *ST_RQ %FINISH ALT=1; ! FIRST ALTERNATIVE TO BE TRIED %IF INCLUDE HANDCODE=NO %THEN %START RS=P RA=SYMBOL(P); ! RA TO NEXT PHRASE ALTERNATIVE %FINISH %ELSE %START *LB_P *STB_RS *LSS_(ALIGN+%B) *ST_RA %FINISH UPR: R=R+1 SUCC: ! SUCCESS ON TO NEXT ITEM %IF INCLUDE HANDCODE=NO %THEN %START RS=RS+1; ! RS=NEXT ALTERNATIVE MEANS THAT ! THIS ALT HAS BEEN COMPLETED SO ! EXIT WITH HIT=1 %IF RS#RA %THEN ->NEXTBR %FINISH %ELSE %START *LB_RS *ADB_1 *CPB_RA *JCC_7, %FINISH BIP(1000): A(RR)=ALT HIT=1 %IF INCLUDE HANDCODE=NO %THEN %RETURN %ELSE %START *J_%TOS %FINISH NEXTBR: ! ONTO NEXT BRICK %IF INCLUDE HANDCODE=NO %THEN %START ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT %IF ITEM<999 %START %IF CC(Q)=ITEM %THEN Q=Q+1 %AND ->SUCC ->FAIL1 %FINISH %IF ITEM <1300 %THEN ->BIP(ITEM) P=ITEM COMPARE %FINISH %ELSE %START *STB_RS *LSS_(ALIGN+%B) *ICP_999 *JCC_10, *LB_Q *ICP_(CC+%B) *JCC_7, *ADB_1 *STB_Q *J_ NOTLIT: *ICP_1300 *JCC_10, *ST_ITEM ->BIP(ITEM) NOTBIP: *ST_P *LSQ_RA *SLSQ_RR *SLSQ_MARKER *ST_%TOS *JLK_ *LSQ_%TOS *ST_MARKER *LSQ_%TOS *ST_RR *LSQ_%TOS *ST_RA %FINISH %IF HIT#0 %THEN ->SUCC ->FAIL; ! PRESERVE FAILNO FROM RETURN FAIL1: FAILNO=1; ! LEXICAL MISMATCH TYPE OF FAIL FAIL: ! FAILURE - NOTE POSITION REACHD ! ! THIS SECTION IS EXECUTED SO OFTEN IT IS WORTH HANDCODEING ! %IF RA=RP %START; ! TOTAL FAILURE NO ALT LEFT TO TRY HIT=0 %IF LEVEL#RL %START UP %IF LEVEL>RL LEVEL=RL %FINISH %IF INCLUDE HANDCODE=NO %THEN %RETURN %ELSE %START *J_%TOS %FINISH %FINISH %IF INCLUDE HANDCODE=NO %THEN %START QMAX=Q %AND ANALFAIL=FAILNO %IF Q>QMAX %FINISH %ELSE %START *LSS_Q *ICP_QMAX *JCC_12, *ST_QMAX *LSS_FAILNO *ST_ANALFAIL %FINISH MCL1: %IF INCLUDE HANDCODE=NO %THEN %START Q=RQ; ! RESET LINE AND A.R. POINTERS R=RR LINE=SC STRLINK=SSL RS=RA; ! MOVE TO NEXT ALT OF PHRASE RA=SYMBOL(RA) %FINISH %ELSE %START *LSQ_RQ *ST_Q *LB_RA *STB_RS *LSS_(ALIGN+%B) *ST_RA %FINISH ALT=ALT+1 ->UPR BIP(1001): ! PHRASE NAME BIP(1004): ! PHRASE OLDNAME %IF LASTAT=Q %THEN %START A(R)=LASTNAME Q=LASTEND ->UPR %FINISH ->FAIL1 %UNLESS TRTAB(CC(Q))=2 PNAME(ITEM-1004) ->SUCC %IF HIT=1; FAILNO=2; ->FAIL BIP(1002): ! PHRASE INTEGER CONSTANT BIP(1003): ! PHRASE CONST FAILNO=CONST(ITEM-1003) ->FAIL %IF HIT=0 %IF CTYPE=2 %START; ! %REAL A(R)=2 A(R+1)=INTEGER(ADDR(CVALUE)) A(R+2)=INTEGER(ADDR(CVALUE)+4) R=R+3 %FINISH %ELSE %START A(R)=1 A(R+1)= S; R=R+2 %FINISH; ->SUCC BIP(1005): ! PHRASE COMMENT TEXT S=0 I=CC(Q) %WHILE I#';' %CYCLE %IF I&128#0 %THEN 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 %C %AND CC(J+2)='G'+128 %AND CC(J+1)='E'+128 %C %AND CC(J)='B'+128 %THEN ->SEP I=CC(Q) %IF I=';' %THEN Q=Q+1 %AND ->SEP %IF I='E'+128 %AND CC(Q+1)='N'+128 %C %AND CC(Q+2)='D'+128 %THEN ->SEP ->FAIL1 SEP: ! SEPERATOR FOUND %IF JROUND(LEVEL)#0 %AND JROUND(LEVEL)&255=0 %THEN UP ->SUCC BIP(1007): S=0 %CYCLE; ! PHRASE ENDTEXT=COMMENT TEXT %WHILE ';'#CC(Q)#'E'+128 %CYCLE %IF CC(Q)>128 %AND S=0 %THEN S=1 %AND WARN(1,0) Q=Q+1 %REPEAT ->SUCC %IF CC(Q)=';' ->SUCC %IF CC(Q+1)='N'+128 %AND CC(Q+2)='D'+128 ->SUCC %IF CC(Q+1)='L'+128 %AND CC(Q+2)='S'+128 %C %AND CC(Q+3)='E'+128 Q=Q+1 %REPEAT BIP(1008): ! PHRASE TEXTTEXT=BETWEEN QUOTES TEXTTEXT ->FAIL1 %IF HIT=0; ->UPR BIP(1009): ! PHRASE NAMELIST BIP(1012): ! PHRASE OLD NAMELIST ! GIVES AR IN FORM NNAMES,NAME1,....NAMEN U=R; V=1; R=R+1 ->FAIL1 %UNLESS TRTAB(CC(Q))=2 PNAME(ITEM-1012) %IF HIT=0 %THEN FAILNO=2 %AND ->FAIL %CYCLE J=CC(Q) Q=Q+1 %EXIT %UNLESS J=',' I=CC(Q) PNAME(ITEM-1012) %EXIT %IF HIT=0; V=V+1 %REPEAT Q=Q-1 A(U)=V; ->SUCC BIP(1010): ! PHRASE HOLE MARKER=R; ->UPR BIP(1011): ! PHRASE MARK A(MARKER)=R-MARKER ->SUCC BIP(1013): ! PHRASE UP STATEMENT COUNT LINE=LINE+1 %WHILE CCLINES(LINE+1)<=Q A(R)=LINE; ->UPR BIP(1014): ! PHRASE LETTER STRING I=CC(Q) ->FAIL1 %UNLESS TRTAB(I)=2 Q=Q+1 %WHILE TRTAB(CC(Q))=2 ->SUCC BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL %IF LEVEL>=2 %THEN %C A(SET(LEVEL))=A(SET(LEVEL))+X'1000';! NOTE NESTED BLK LEVEL=LEVEL+1 JROUND(LEVEL)=0 RAL(LEVEL)=R; !RAL FOR LINKING LABELS A(R)=0; R=R+1 FLAG(LEVEL)=R; ! FLAG FOR LINKING SCALARS A(R)=0; R=R+1 L(LEVEL)=R; ! L FOR LINKING ARRAYS A(R)=0; R=R+1 M(LEVEL)=R; ! M FOR LINKING SWITCHES A(R)=0; R=R+1 NMDECS(LEVEL)=R; ! NMDECS FOR LINKING OWNS A(R)=0; R=R+1 STACKBASE(LEVEL)=R; ! STACKBASE FOR LINKING PROCS A(R)=0; R=R+1 SET(LEVEL)=R; ! A(SET(LEVEL)) COUNTS EMBEDDED LABS A(R)=0; R=R+1; ->SUCC BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL %IF JROUND(LEVEL)&255#0 %THEN %C JROUND(LEVEL)=JROUND(LEVEL)-1 %AND ->SUCC UP; ! ONE TEXTUAL LEVEL ->SUCC BIP(1017): ! PHRASE SCALAR TYPE TYPE=A(R-2); ->SUCC %UNLESS TYPE=4; ->FAIL1 BIP(1018): ! PHRASE DECLARE NAME I=A(R-1) J=NTYPE(I) %IF J&31=LEVEL %THEN %START FAILNO=4 %AND ->FAIL %C %UNLESS TYPE=J>>8&255 %AND (TYPE>=128 %OR TYPE=38) %FINISH %ELSE %START %IF J#0 %THEN PUSH(TAGS(I), J, DPOSN(I),0) NTYPE(I)=TYPE<<8!LEVEL!NAMES(LEVEL)<<16 DPOSN(I)=R-1 NAMES(LEVEL)=I %FINISH ->SUCC BIP(1019): ! PHRASE TYPE=ARITHMETIC ->SUCC %IF 1<=NTYPE(LASTNAME)>>8&7<=2 %IF NTYPE(LASTNAME)=0 %THEN FAILNO=2 %ELSE FAILNO=10; ->FAIL BIP(1020): ! PHRASE TYPE=BOOLEAN ->SUCC %IF NTYPE(LASTNAME)>>8&7=3 %IF NTYPE(LASTNAME)=0 %THEN FAILNO=2 %ELSE FAILNO=10; ->FAIL BIP(1021): ! PHRASE ARRAYTYPE TYPE=A(R-2)+32 TYPE=34 %IF TYPE=36; ->SUCC BIP(1022): ! PHRASE PROCTYPE TYPE=A(R-2)&3+128; ->SUCC BIP(1023): ! PHRASE LINK SCALAR DECLNS %IF LEVEL<=1 %THEN QMAX=Q-1 %AND FAILNO=9 %AND ->FAIL A(FLAG(LEVEL))=R-FLAG(LEVEL)-1 A(R)=0; FLAG(LEVEL)=R; R=R+1; ->SUCC BIP(1024): ! PHRASE LINK ARRAY DECLNS %IF LEVEL<=1 %THEN FAILNO=9 %AND ->FAIL A(L(LEVEL))=R-L(LEVEL)-1 A(R)=0; L(LEVEL)=R; R=R+1; ->SUCC BIP(1025): ! PHRASE CHKLPL(LOOK FOR :=) ->FAIL1 %UNLESS TRTAB(CC(Q))=2 I=Q I=I+1 %WHILE ';'#CC(I)#':' %IF CC(I)=':' %AND CC(I+1)='=' %THEN ->SUCC ->FAIL1 BIP(1026): ! PHRASE LABTYPE PASS2INF=PASS2INF!LABBYNAME; ! NOTE PRESENCE OF LAB PARAMETERS TYPE=6; ->SUCC BIP(1043): ! PHRASE SWITCH BY NAME PASS2INF=PASS2INF!SWBYNAME; ! NOTE PRESENCE OF FORMAL SWITCH BIP(1027): ! PHRASE SWTYPE TYPE=38; ->SUCC BIP(1028): ! PHRASE STRTYPE TYPE=5; ->SUCC BIP(1029): ! PHRASE CHK LAB I=Q I=I+1 %WHILE TRTAB(CC(I))#0 %IF CC(I)=':' %AND CC(I+1)#'=' %START %IF CC(I+1)#'C'+128 %OR CC(I+2)#'O'+128 %OR %C CC(I+3)#'M'+128 %THEN ->SUCC Q=I+1; ->FAIL1 %FINISH ->FAIL1 BIP(1030): ! TYPE=ARR %IF NTYPE(LASTNAME)>>8&32=0 %THEN ->NOTARR ->SUCC %IF CC(Q)='[' %OR(CC(Q)='(' %AND CC(Q+1)='/') I=DPOSN(LASTNAME) A(I)=A(I)!X'10000' ->SUCC NOTARR: %IF CC(Q)='[' %OR (CC(Q)='(' %AND CC(Q+1)='/') %THEN %C FAILNO=3 %AND QMAX=Q-1 %ELSE FAILNO=1 ->FAIL BIP(1031): ! PHRASE LINK SWITCH DECLNS %IF LEVEL<=1 %THEN FAILNO=9 %AND ->FAIL A(M(LEVEL))=R-M(LEVEL)-2 A(R)=0; M(LEVEL)=R; R=R+1; ->SUCC BIP(1032): ! PHRASE LINK OWN DECLNS %IF LEVEL<=1 %THEN FAILNO=9 %AND ->FAIL A(NMDECS(LEVEL))=R-NMDECS(LEVEL) A(R)=0; NMDECS(LEVEL)=R; R=R+1; ->SUCC BIP(1033): ! PHRASE LINK PROC STMNTS A(STACKBASE(LEVEL))=R-STACKBASE(LEVEL)-1 A(R)=0; STACKBASE(LEVEL)=R; R=R+1; ->SUCC BIP(1034): ! PHRASE LINKLAB %IF LEVEL<=1 %THEN FAILNO=9 %AND ->FAIL A(RAL(LEVEL))=R-RAL(LEVEL)-2 A(R)=0; RAL(LEVEL)=R; I=LEVEL-1 %WHILE I>=2 %CYCLE A(SET(I))=A(SET(I))+1 I=I-1 %REPEAT R=R+1; ->SUCC BIP(1035): ! PHRASE NOMORE I=CC(Q) ->SUCC %IF I=')' %OR I=',' ->FAIL1 BIP(1036): ! PHRASE CMPND I=CC(Q) ->FAIL %IF LEVEL <= 1; !* UKC ->FAIL1 %UNLESS I=';' %OR I='E'+128 %OR CC(Q-1)='N'+128 JROUND(RL)=JROUND(RL)+1 ->SUCC BIP(1037): ! PHRASE UP AT (NEXT) SEP JROUND(LEVEL)=JROUND(LEVEL)+256 ->SUCC BIP(1038): ! P(PLUS')='+','-',0 I=CC(Q) %IF I='-' %THEN A(R)=2 %AND Q=Q+1 %ELSE A(R)=3 %IF I='+' %THEN Q=Q+1 ->UPR BIP(1039): ! P(OP)=^,**,+,-,*,/,%DIV,%POWER I=CC(Q) ->FAIL1 %UNLESS OPMASK(I>>5)&X'80000000'>>(I&31)#0 Q=Q+1 %IF I='-' %THEN A(R)=4 %AND ->UPR %IF I='+' %THEN A(R)=3 %AND ->UPR J=CC(Q) %IF I='*' %THEN %START %IF J#'*' %THEN A(R)=5 %AND ->UPR Q=Q+1; A(R)=2; ->UPR %FINISH %IF I='/' %THEN A(R)=6 %AND ->UPR %IF I='^' %THEN A(R)=1 %AND ->UPR %IF I='D'+128 %AND J='I'+128 %AND CC(Q+1)='V'+128 %THEN %C Q=Q+2 %AND A(R)=7 %AND ->UPR %IF I='P'+128 %AND J='O'+128 %AND CC(Q+1)='W'+128 %AND %C CC(Q+2)='E'+128 %AND CC(Q+3)='R'+128 %THEN %C Q=Q+4 %AND A(R)=8 %AND ->UPR ->FAIL1 BIP(1040): ! PHRASE CHECKSC ->SUCC %IF CC(Q)=';'; ->FAIL1 BIP(1041): ! PHRASE LEFT SQUARE BRACKET I=CC(Q) %IF I='[' %THEN Q=Q+1 %AND ->SUCC %UNLESS I='(' %AND CC(Q+1)='/' %THEN ->FAIL1 Q=Q+2; ->SUCC BIP(1042): ! PHRASE RIGHT SQUARE BRACKET I=CC(Q) %IF I=']' %THEN Q=Q+1 %AND ->SUCC %UNLESS I='/' %AND CC(Q+1)=')' %THEN ->FAIL1 Q=Q+2; ->SUCC BIP(1044): ! PHRASE TYPENOTBOOLEAN ->SUCC %UNLESS NTYPE(LASTNAME)>>8&7=3 %AND %C NTYPE(LASTNAME)&31=LEVEL FAILNO=10; ->FAIL BIP(1045): ! PHRASE TYPENOT ARITH ->SUCC %UNLESS 1<=NTYPE(LASTNAME)>>8&7<=2 %AND %C NTYPE(LASTNAME)&31=LEVEL FAILNO=10; ->FAIL %ROUTINE UP !*********************************************************************** !* COME UP A TEXTUAL LEVEL. INVOLVES UNDECLARING NAMES * !*********************************************************************** I=NAMES(LEVEL) %WHILE 0<=I<=NNAMES %CYCLE J=NTYPE(I) NTYPE(I)=0 %IF TAGS(I)#0 %THEN POP(TAGS(I), NTYPE(I), DPOSN(I),ITEM) I=J>>16 %REPEAT NAMES(LEVEL)=-1 LEVEL=LEVEL-1 %END; ! OF ROUTINE UP %END; !OF ROUTINE 'COMPARE' %ROUTINE PNAME(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME * !*********************************************************************** %CONSTINTEGERARRAY HASH(0:7)=71,47,97,79,29,37,53,59; %INTEGER JJ, KK, LL, FQ, FS, S, TT, I %IF INCLUDE HANDCODE=YES %THEN %START %LONGINTEGER DRDES,ACCDES %FINISH HIT=0; FQ=Q; FS=CC(Q) %RETURN %UNLESS TRTAB(FS)=2; ! 1ST CHAR MUST BE LETTER TT=1; LETT(NEXT+1)=FS; JJ=71*FS %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE Q=Q+1 I=CC(Q) %EXIT %IF TRTAB(I)=0 JJ=JJ+HASH(TT)*I %IF TT<=7 TT=TT+1 LETT(NEXT+TT)=I %REPEAT %FINISH %ELSE %START CYC: *LB_Q *ADB_1 *STB_Q *LB_(CC+%B) *LSS_(TRTAB+%B) *JAT_4, *STB_I *LSS_%B; ! I TO ACC *LB_TT *CPB_7 *JCC_2, *IMY_(HASH+%B) *IAD_JJ *ST_JJ SKIP: *ADB_1 *STB_TT *LSS_I *ADB_NEXT *ST_(LETT+%B) *J_ EXIT: %FINISH LETT(NEXT)=TT; ! INSERT LENGTH T=TT S=T+1 FAULT(103,0) %IF NEXT+S>DSIZE;!DICTIONARY OVERFLOW JJ=(JJ+113*TT)&NNAMES %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE KK=JJ, 1, NNAMES LL=WRD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT %CYCLE KK=0,1,JJ LL=WRD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT %FINISH %ELSE %START *LDTB_X'18000000' *LDB_S *LDA_LETT+4 *STD_DRDES *INCA_NEXT *STD_ACCDES *LB_JJ CYC1: *STB_KK *LB_(WRD+%B) *JAT_12, *LSD_ACCDES *LD_DRDES *INCA_%B *CPS_%L=%DR *JCC_8, *LB_KK *CPIB_NNAMES *JCC_7, *LB_0 CYC2: *STB_KK *LB_(WRD+%B) *JAT_12, *LSD_ACCDES *LD_DRDES *INCA_%B *CPS_%L=%DR *JCC_8, *LB_KK *CPIB_JJ *JCC_7, %FINISH FAULT(104, 0); ! TOO MANY NAMES HOLE: %IF MODE=0 %THEN ->XIT WRD(KK)=NEXT; NEXT=NEXT+S FND: LASTAT=FQ; HIT=1; LASTNAME=KK A(R)=LASTNAME R=R+1 LASTEND=Q XIT: %END; ! OF ROUTINE PNAME %%INTEGERFN CONST(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR NORMAL MODE=2 FOR EXPONENT (IE INTEGER CONSTANTS) * !*********************************************************************** %INTEGER Z, I %LONGLONGREAL X,CV %CONSTLONGLONGREAL TEN=R'41A00000000000000000000000000000' CV=0; I=CC(Q); CTYPE=1; HIT=0 S=0; ->N %IF M'0'<=I<=M'9' ->DOT %IF I='.' %AND MODE=0 ! 1 DIDT MIN %IF (I='&' %OR I='@') %AND MODE=0 %THEN CV=1 %AND ->ALPHA %RESULT=1 OFLOW: %RESULT=8 N: I=I&15; CV=TEN*CV+I Q=Q+1; I=CC(Q) ->N %IF M'0'<=I<=M'9' ->ALPHA %UNLESS MODE=0 %AND I='.' DOT: Q=Q+1; X=TEN; CTYPE=2 I=CC(Q) %RESULT=5 %UNLESS '0'<=I<='9'; ! '23.' NOT VALID IN ALGOL %WHILE '0'<=I<='9' %CYCLE CV=CV+(I&15)/X X=TEN*X; Q=Q+1 I=CC(Q) %REPEAT ALPHA: ! TEST FOR EXPONENT ->FIX %UNLESS MODE=0 %AND (I='&' %OR I='@') Q=Q+1; X=CV; CTYPE=2 Z=1; %UNLESS '+'#CC(Q)#'-' %START Z=-1 %IF CC(Q)='-'; Q=Q+1 %FINISH I=CONST(2); %RESULT=6 %IF HIT=0; S=S*Z HIT=0; CTYPE=2 %IF S=-99 %THEN CV=0 %ELSE %START CV=X %IF INCLUDE HANDCODE=YES %THEN %START *MPSR_X'8080'; ! MASK OUT OFLOW %FINISH %WHILE S>0 %CYCLE S=S-1 %IF INCLUDE HANDCODE=YES %THEN %START CV=CV*TEN *JAT_15,; ! OVERFLOWED %FINISH %ELSE CV=CV*TEN %REPEAT %WHILE S<0 %AND CV#0 %CYCLE S=S+1 CV=CV/TEN %REPEAT %FINISH FIX: ! SEE IF IT IS INTEGER %IF INCLUDE HANDCODE=NO %THEN CVALUE=CV %ELSE %START *LSD_X'7F00000000000000' *AND_CV *SLSD_X'0080000000000000' *AND_CV+8 *LUH_%TOS *RAD_CV *STUH_CVALUE %FINISH %IF CTYPE#1 %THEN HIT=1 %AND %RESULT=0 %IF CVALUE<=IMAX %THEN %START S=INT(CVALUE) CTYPE=1; HIT=1 %RESULT=0 %FINISH %RESULT=7 %END %ROUTINE TEXTTEXT %CONSTINTEGER TXT1='<' %INTEGER S, J, BR, FIRST, LAST, I, AAR S=R; R=R+2; BR=1; HIT=0 I=CC(Q) %RETURN %UNLESS (I=TXT1 %AND QFLAG=0) %OR I=123 ! FAIL UNLESS INITIAL QUOTE FIRST=I; LAST=FIRST+2 Q=Q+1; J=0; AAR=ADDR(A(R)) %UNTIL BR=0 %CYCLE I=CC(Q) %IF I=FIRST %THEN BR=BR+1 %IF I=LAST %THEN BR=BR-1 %IF I>128 %AND CC(Q-1)<128 %THEN %C BYTE INTEGER(AAR+J)=KYCHAR1 %AND J=J+1 %IF I<128 %AND CC(Q-1)>128 %THEN %C BYTE INTEGER(AAR+J)=KYCHAR2 %AND J=J+1 BYTE INTEGER(AAR+J)=I J=J+1; Q=Q+1 %IF Q>LENGTH %THEN FAULT(106,0) %REPEAT %IF J>256 %THEN WARN(5,0) %AND J=256 J=J-1 R=R+(J+3)>>2 A(S+1)=J A(S)=STRLINK; STRLINK=S HIT=1 %END BEND:%END ;! END OF FIRST 2 PASSES %IF LEVEL>1 %THEN FAULT(15, 0) I=0 NEWLINE %IF FAULTY=0 %THEN %START WRITE(LASTLINE-1, 5) PRINT STRING(" LINES ANALYSED ") %FINISH %ELSE %START PRINTSTRING(" CODE GENERATION NOT ATTEMPTED ") COMREG(24)=8 COMREG(47)=FAULTY %STOP %FINISH %BEGIN !*********************************************************************** !* FINAL OR CODE GENERATING PASS * !*********************************************************************** %ROUTINESPEC CNOP(%INTEGER I, J) %ROUTINESPEC PCLOD(%INTEGER FROM, TO) %ROUTINESPEC PCONST(%INTEGER X) %ROUTINESPEC PSF1(%INTEGER OPCODE,K,N) %ROUTINESPEC PF1(%INTEGER OPCODE,KP,KPP,N) %ROUTINESPEC PSORLF1(%INTEGER OPCODE,KP,KPP,N) %ROUTINESPEC PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) %ROUTINESPEC PF3(%INTEGER OPCODE,MASK,KPPP,N) %ROUTINESPEC PLANT(%INTEGER VALUE) %ROUTINESPEC PLUG(%INTEGER I, J, K) %ROUTINESPEC CODEOUT %ROUTINESPEC NOTE CREF(%INTEGER CA) %INTEGERFNSPEC PARAM DES(%INTEGER PREC) %INTEGERFNSPEC SPECIAL CONSTS(%INTEGER WHICH) %ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,C1,C2) %ROUTINESPEC DUMP CONSTS %ROUTINESPEC PROLOGUE %ROUTINESPEC EPILOGUE %ROUTINESPEC CSS(%INTEGER P) %ROUTINESPEC ABORT %IF ALLOW CODELIST=YES %THEN %START %ROUTINESPEC RECODE(%INTEGER START, FINISH, CA) %ROUTINESPEC PRINT USE %FINISH %INTEGERARRAY REGISTER, OLINK, GRUSE, GRAT, GRINF(0:7) %BYTEINTEGERARRAY CODE, GLABUF(0:268) %INTEGERARRAY DESADS,PLABS,PLINK(0:31),DVHEADS(0:12) %INTEGERARRAY AUXSBASE,LABEL,DIAGINF,DISPLAY(0:MAXLEVELS) %INTEGERARRAY AVL WSP(1:4,0:MAXLEVELS) %INTEGERARRAYFORMAT CF(0:12*NNAMES) %INTEGERARRAYNAME CTABLE %CYCLE I=0, 1, 7 REGISTER(I)=0; GRUSE(I)=0 GRAT(I)=0; GRINF(I)=0 %REPEAT %CYCLE I=0, 1, MAXLEVELS NAMES(I)=-1 DIAGINF(I)=0; DISPLAY(I)=0 AUXSBASE(I)=0; LABEL(I)=0 NMDECS(I)=0 DVHEADS(I)=0 %IF I<=12 %CYCLE J=1,1,4 AVL WSP(J,I)=0 %REPEAT %REPEAT CTABLE==ARRAY(ADDR(ASLIST(1)),CF) LINE=0 PROLOGUE NEXTP=8 LEVEL=1; RLEVEL=0 %CYCLE %IF ALLOW CODELIST=YES %AND DCOMP#0 %AND CA>CABUF %THEN %C CODEOUT %AND PRINT USE I=NEXTP NEXTP=NEXTP+A(NEXTP) LINE=A(I+1) %EXIT %IF LINE=0 CSS(I+2) %REPEAT %IF FAULTY=0=CPRMODE %THEN LINE=LASTLINE-1 %AND FAULT(57,0) LINE=9999 EPILOGUE !*********************************************************************** !* PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** GLACA=(GLACA+7)&(-8) USTPTR=(USTPTR+7)&(-8) CNOP(0, 8) CODE OUT I=(PARMDIAG<<1!PARMLINE)<<1!PARMTRCE ! ! ALGOL LANGUAGE VALUE IS 5. 6 IS RESERVED FOR ANY OPTIMISED PROGRAM ! FIXED GLA(4)=(6-PARMTRCE)<<24!1<<16!(CPRMODE&1)<<8!I I=GLACA-GLACABUF %IF INHCODE=0 %THEN %START LPUT(2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 GLACABUF=GLACA; GLACURR=0; ! DUMP CONSTS MAY PLUG GLA ! BACK OF GLAP LPUT(2, N0<<2, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP I=X'E2E2E2E2' LPUT(4, 4, SSTL, ADDR(I)) LPUT(19, 2, 12, 4); ! RELOCATE POINTER TO CST LPUT(19, 2, 8, 5); ! RELOCATE PTR TO GLAST %FINISH DUMP CONSTS SSTL=(SSTL+11)&(-8) NEWLINE %IF VMEB=YES %THEN FAULTMK(8) PRINTSTRING( "CODE") WRITE(CA, 6); PRINTSTRING( " BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING( "+") WRITE(USTPTR, 1); PRINTSTRING( " BYTES DIAG TABLES") WRITE(SSTL, 3); PRINTSTRING( " BYTES TOTAL") REGISTER(0)=CA; REGISTER(1)=GLACA REGISTER(2)=0 REGISTER(3)=SSTL REGISTER(4)=USTPTR K=CA+GLACA+SSTL+USTPTR; REGISTER(5)=K WRITE(K, 5); PRINTSTRING( " BYTES") NEWLINE %IF FAULTY=0 %THEN %START WRITE(LASTLINE-1,7); PRINTSTRING(" LINES COMPILED") COMREG(47)=LASTLINE-1; ! NO OF LINES FOR SUMMARY %FINISH %ELSE %START PRINT STRING("PROGRAM CONTAINS"); WRITE(FAULTY,2) PRINT STRING(" FAULT"); PRINT SYMBOL('S') %IF FAULTY>1 COMREG(47)=FAULTY %FINISH NEWLINES(2) I=0; I=8 %IF FAULTY#0 COMREG(24)=I %IF INHCODE=0 %THEN LPUT(7, 24, 0, ADDR(REGISTER(0))) ! SUMMARY INFO..REGISTER AS BUF ! PPROFILE %STOP %ROUTINE ABORT PRINTSTRING( ' **************** ABORT******************** ABORT *******') %IF ALLOW CODELIST=YES %THEN %START RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %UNLESS CA=CABUF PRINT USE %FINISH %MONITOR; %STOP %END ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** %IF ALLOW CODELIST=YES %THEN %START %ROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START %IF VMEB=YES %THEN FAULTMK(4);! START OF CODE PRINTSTRING(" CODE FOR LINE"); WRITE(LINE,5) NCODE(S,F,AD) %IF VMEB=YES %THEN FAULTMK(1);! BACK TO NORMAL %FINISH %END %FINISH %ROUTINE CODEOUT %IF PPCURR>0 %THEN %START %IF ALLOW CODELIST=YES %AND DCOMP#0 %THEN %C RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) LPUT(1, PPCURR, CABUF, ADDR(CODE(0))) %IF INHCODE=0 PPCURR=0; CABUF=CA %FINISH %END %ROUTINE PLANT(%INTEGER HALFWORD) !*********************************************************************** !* ADD A HALF WORD OF BINARY TO THE BUFFER * !*********************************************************************** %IF INCLUDE HANDCODE=NO %THEN %START CODE(PPCURR)<-HALFWORD>>8 CODE(PPCURR+1)<-HALFWORD PPCURR=PPCURR+2 %FINISH %ELSE %START *LDA_CODE+4 *LDTB_X'58000002' *LB_PPCURR *LSS_HALFWORD *ST_(%DR+%B) *ADB_2 *STB_PPCURR %FINISH CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE PCONST(%INTEGER WORD) !*********************************************************************** !* ADD A WORD OF BINARY TO THE BUFFER * !*********************************************************************** %INTEGER I %IF INCLUDE HANDCODE=N0 %THEN %START %CYCLE I=24,-8,0 CODE(PPCURR)=WORD>>I&255 PPCURR=PPCURR+1 %REPEAT %FINISH %ELSE %START *LDA_CODE+4 *LDTB_X'58000004' *LSS_WORD *LB_PPCURR *ST_(%DR+%B) *ADB_4 *STB_PPCURR %FINISH CA=CA+4 CODE OUT %IF PPCURR>=256 %END %ROUTINE PSF1(%INTEGER OPCODE,K,N) !*********************************************************************** !* PLANT THE HALFWORD FORMS OF PRIMARY FORMAT NR INSTRNS * !* IF N IS TOO LARGE FOR THE SHORT FORM PF1 IS CALLED TO PLANT * !* THE CORRESPONDING LONG FORM * !*********************************************************************** %INTEGER KPP ! ABORT %UNLESS 0<=K<=2 %AND OPCODE&1=0 %IF (K=0 %AND -64<=N<=63) %OR (K#0 %AND 0<=N<=511) %START %IF K#0 %THEN N=N//4 %IF INCLUDE HANDCODE=NO %THEN %START CODE(PPCURR)=OPCODE!K>>1 CODE(PPCURR+1)=(K&1)<<7!N&127 PPCURR=PPCURR+2 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_K *USH_7 *SLSS_N *AND_127 *LB_PPCURR *OR_%TOS *LDA_CODE+4 *LDTB_X'58000002' *ST_(%DR+%B) *ADB_2 *STB_PPCURR %FINISH CA=CA+2 CODEOUT %IF PPCURR>=256 %FINISH %ELSE %START %IF K=0 %THEN KPP=0 %ELSE KPP=2 PF1(OPCODE,K>>1<<1,KPP,N) %FINISH %END %ROUTINE PF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* PLANT THE NORMAL FORMS OF PRIMARY FORMAT INSTRNS(IE THOSE * !* WHICH DO NOT DEPEND ON THE SIZE OF N) * !*********************************************************************** %INTEGER INC ! ABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0 INC=2 %IF KPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH %IF (1<>16&3) CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_3 *USH_2 *OR_KP *USH_3 *OR_KPP *USH_18 *SLSS_N *AND_X'3FFFF' *OR_%TOS *LDTB_X'58000004' *LDA_CODE+4 *LB_PPCURR *ST_(%DR+%B) %FINISH %IF KPP<=5 %THEN INC=4 PPCURR=PPCURR+INC CA=CA+INC CODEOUT %IF PPCURR>=256 %END %ROUTINE PSORLF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* AS PF1 BUT CUT VALID FORMS TO SHORT FORM * !*********************************************************************** %INTEGER INC INC=2 %IF (KPP=0=KP %AND -64<=N<=63) %OR%C (KPP=LNB %AND KP&1=0 %AND 0<=N<=511) %START %IF KPP=LNB %THEN KP=1+KP>>1 %IF KP#0 %THEN N=N//4 %IF INCLUDE HANDCODE=NO %THEN %START CODE(PPCURR)=OPCODE!KP>>1 CODE(PPCURR+1)=(KP&1)<<7!(N&127) %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_KP *USH_7 *SLSS_N *AND_127 *LB_PPCURR *OR_%TOS *LDA_CODE+4 *LDTB_X'58000002' *ST_(%DR+%B) %FINISH %FINISH %ELSE %START %IF KPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH %IF (1<>16&3) CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_3 *USH_2 *OR_KP *USH_3 *OR_KPP *USH_18 *SLSS_N *AND_X'3FFFF' *OR_%TOS *LDTB_X'58000004' *LDA_CODE+4 *LB_PPCURR *ST_(%DR+%B) %FINISH %IF KPP<=5 %THEN INC=4 %FINISH CA=CA+INC; PPCURR=PPCURR+INC CODEOUT %IF PPCURR>=256 %END %ROUTINE PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) !*********************************************************************** !* PLANT SECONDARY(STORE TO STORE) FORMAT INSTRNS * !* THESE MAY BE 16 OR 32 BIT DEPENDING ON Q * !*********************************************************************** ! ABORT %UNLESS 0<=H<=1 %AND 0<=Q<=1 %AND 0<=N<=127 %C ! %AND OPCODE&1=0 PLANT(OPCODE<<8!H<<8!Q<<7!N) %IF Q#0 %THEN PLANT(MASK<<8!FILLER) %END %ROUTINE PF3(%INTEGER OPCODE,MASK,KPPP,N) !*********************************************************************** !* PLANT THE TERTIARY(JUMP) FORMAT INSTRUCTIONS * !*********************************************************************** ! ABORT %UNLESS 0<=MASK<=15 %AND 0<=KPPP<=7 %AND OPCODE&1=0 %IF KPPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH CODE(PPCURR)=OPCODE!MASK>>3&1 CODE(PPCURR+1)=(MASK&7)<<5!KPPP<<2!(N>>16&3) PPCURR=PPCURR+2 CA=CA+2 %IF KPPP<=5 %THEN %START CODE(PPCURR)=N>>8&255 CODE(PPCURR+1)=N&255 PPCURR=PPCURR+2; CA=CA+2 %FINISH CODEOUT %IF PPCURR>=256 %END %ROUTINE NOTE CREF(%INTEGER CA) !*********************************************************************** !* NOTE THAT A (PC+N) INSTRUCTION HAS N RELATIVE TO CONST TABLE * !* NOT REATIVE TO CODE. REMEMBER THE ADDRESS OF THE INSTRUCTION * !* SO THAT AN LPUT(18) CORRECTION CAN BE MADE AT END OF COMPILATION * !*********************************************************************** %RECORD(LISTF)%NAME CELL CELL==ASLIST(CREFHEAD) %IF CREFHEAD=0 %OR CELL_S3#0 %THEN %C PUSH(CREFHEAD,CA,0,0) %AND %RETURN %IF CELL_S2=0 %THEN CELL_S2=CA %ELSE CELL_S3=CA %END %ROUTINE PCLOD(%INTEGER FROM, TO) !*********************************************************************** !* PLANT A SERIES OF INTRUNS FROM ARRAY FIXED CODE * !*********************************************************************** %INTEGER I,T,B %CONSTINTEGERARRAY FIXED CODE(0:127)= %C X'7B985398',X'18041C01', X'5D984998',X'5B987E84', X'6C091FCC',X'000A1B98', M'FREE',0, X'0580000B',X'63985F98', X'73986F9C',X'2A04779C', X'B1800081',X'49981B98', X'00000000',X'5F98E398', X'E87EE001',X'43986F98', X'49981B98',0, X'49987998',X'180463A0', X'000443A0',X'0002420A', X'43DC4998',X'7E846C09', X'1FCC000A',M'FREE', M'FREE', M'FREE', M'FREE', M'FREE', M'FREE', M'FREE', M'FREE',M'FREE', M'FREE',X'5D98738C', X'00051414',X'59986C0A', X'338040C0',0, X'7E807F8C',X'00046485', X'499879CC',X'000C63DC', X'48866289',X'E8658A07', X'E79C0240',X'00320280', X'00188A03',X'EA044285', X'8B81FFFF',X'EB98499C', X'E08649DC',X'E7A00002', X'02400044',X'779C7398', X'12007286',X'B3006685', X'38006201',X'E81BE089', X'48858B81',X'FFFF499C', X'EA08E086',X'49DCE7A0', X'00020240',X'002D2201', X'63E80009',X'A80049E8', X'00050783',X'FFFA6685', X'38006201',X'E81BE489', X'48858B81',X'FFFF499C', X'EA04E086',X'49DCE7A0', X'00020240',X'00152201', X'65E80009',0, X'F837F849',X'5B98B99C', X'2A04E99C',X'32117B98', X'49E80005',X'0783FFF1', X'66853800',0, X'7B987998',X'5B985998', X'45980440',X'00350600', X'00074598',X'06200030', X'65981B98',X'45984998', X'0440001A',X'F837F849', X'B99C2A04',X'26400340', X'00037A40',X'E99C4B9C', X'02E0000E',X'6E7E499C', X'6201A800',X'07800005', X'6E7E1B98',X'5998FB98', X'247E1B98',X'65984598', X'18044998',X'7E846C07', M'FREE',X'FB981804', X'49987E84',X'6C071A01', X'5D984998',X'5B98359C', X'20105B98',X'4D983798', X'7DA00004',M'FREE', X'31987F98',X'33987B98', X'61987D98',X'3A001A01'; B=(TO-FROM+1)*4 B=B-2 %IF FIXED CODE(TO)&X'FFFF'=X'1A01' CODE OUT %IF PPCURR+B>=256 T=ADDR(FIXED CODE(FROM)) %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE I=0,1,B-1 CODE(PP CURR)=BYTEINTEGER(T+I) PP CURR=PP CURR+1 %REPEAT %FINISH %ELSE %START *LDTB_X'18000000' *LDB_B *LDA_T *CYD_0 *LDA_CODE+4 *INCA_PPCURR *MV_%L=%DR PPCURR=PPCURR+B %FINISH CA=CA+B %END %ROUTINE CNOP(%INTEGER I, J) PLANT(X'1A01') %WHILE CA&(J-1)#I;! JUNC *+1 %END %ROUTINE PGLA(%INTEGER BDRY, L, INF ADR) %INTEGER I, J J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING %IF L+GLACURR>256 %THEN %START %IF INHCODE=0 %C %THEN LPUT(2, GLACURR, GLACABUF, ADDR(GLABUF(0))) GLACURR=0; GLACABUF=GLACA %FINISH %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE I=0,1,L-1 GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR) %REPEAT %FINISH %ELSE %START *LDTB_X'58000004' *LDB_L *LDA_INFADR *CYD_0 *LDA_GLACURR *INCA_GLABUF+4 *MV_%L=%DR %FINISH GLACURR=GLACURR+L GLACA=GLACA+L %END %ROUTINE PLUG(%INTEGER AREA, AT, VALUE) !*********************************************************************** !* WRITE ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * !*********************************************************************** %INTEGER RELAD, BUFAD %IF AREA=2 %THEN BUFAD=ADDR(GLABUF(0)) %AND RELAD=AT-GLACABUF%C %ELSE BUFAD=ADDR(CODE(0)) %AND RELAD=AT-CABUF %IF RELAD>=0 %AND AREA<=2 %THEN %START %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE I=0,1,3 BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((3-I)<<3) %REPEAT %FINISH %ELSE %START *LDA_RELAD *INCA_BUFAD *LSS_VALUE *LDTB_X'58000004' *ST_(%DR) %FINISH %FINISH %ELSE %START %IF RELAD=-2 %THEN CODEOUT %IF INHCODE=0 %THEN LPUT(AREA, 4, AT, ADDR(VALUE)) %IF ALLOW CODELIST=YES %AND DCOMP#0 %AND AREA=1 %THEN %C NCODE(ADDR(VALUE),ADDR(VALUE)+4,AT) %FINISH %END %INTEGERFN PARAM DES(%INTEGER TYPE) !*********************************************************************** !* SET UP BNDED L=1 DESRIPTOR FOR PASSING VARIABLE BY REFERENCE * !* ONLY THE TOP HALF IS SET UP * !*********************************************************************** %INTEGER K,DES,PREC PREC=SIZECODE(TYPE) K=DESADS(PREC) %RESULT=K %UNLESS K=0 DES=PREC<<27!1 STORE CONST (K,4,DES,0) DESADS(PREC)=K %RESULT=K %END %INTEGERFN SPECIAL CONSTS(%INTEGER WHICH) !*********************************************************************** !* PUTS CERTAIN SPECIAL CONSTANTS INTO THE CONSTANT TABLE ON * !* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHONG * !*********************************************************************** %CONSTINTEGERARRAY SCS(0:5) = X'40800000',0, X'41100000',0, X'E5000000',X'E5000001'; %INTEGER K K=DESADS(WHICH+16) %RESULT=K %UNLESS K=0 STORE CONST(K,8,SCS(2*WHICH),SCS(2*WHICH+1)) DESADS(WHICH+16)=K %RESULT=K %END %ROUTINE STORE CONST(%INTEGERNAME D, %INTEGER L, C1, C2) !*********************************************************************** !* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER I, J, K, LP LP=L//4 %IF PARMOPT#0 %THEN ->SKIP K=CONST BTM; ! AFTER STRINGS IN CTABLE %IF L=4 %THEN %START %IF INCLUDE HANDCODE=NO %THEN %START %WHILE K *ICP_(%DR+%B) *JCC_7, *CPB_CONSTHOLE *JCC_8, *LSS_%B *IMY_4 *OR_X'80000000' *ST_(D) *EXIT_-64 %FINISH %FINISH %ELSE %START J=CONSTPTR-LP %IF INCLUDE HANDCODE=NO %THEN %START %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND %C (CONSTHOLE=K+LP) %START D=4*K!X'80000000' %RETURN %FINISH K=K+2 %REPEAT %FINISH %ELSE %START *LD_CTABLE *LB_K AGN2A: *LSS_C1 AGN2: *CPB_J *JCC_2, *ICP_(%DR+%B) *JCC_8, *ADB_2 *J_ ON2: *STB_K *ADB_1 *LSS_(%DR+%B) *ICP_C2 *JCC_8, BACK2: *ADB_1 *J_ ON2A: *LSS_K *ICP_CONSTHOLE *JCC_8, *CPB_CONSTHOLE *JCC_8, *IMY_4 *OR_X'80000000' *ST_(D) *EXIT_-64 %FINISH %FINISH SKIP: %IF L=4 %AND CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 D=4*CONSTHOLE!X'80000000' CONSTHOLE=0 %RETURN %FINISH %IF L>4 %AND CONST PTR&1#0 %C %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR!X'80000000' CTABLE(CONSTPTR)=C1 CTABLE(CONSTPTR+1)=C2 CONST PTR=CONST PTR+LP %IF CONST PTR>CONST LIMIT %THEN FAULT(107,0) %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I,J %CYCLE J=0, 1, 4; I=GRMAP(J) PUSH(HEAD, GRINF(I), GRAT(I), I<<8!GRUSE(I)) %C %IF GRUSE(I)>1 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I, J, R, USE, INF, AT %CYCLE J=0, 1, 4; I=GRMAP(J) GRUSE(I)=0; GRINF(I)=0 %REPEAT %WHILE HEAD#0 %CYCLE POP(HEAD, INF, AT, I) R=I>>8; USE=I&255 GRUSE(R)=USE; GRINF(R)=INF GRAT(R)=AT %REPEAT %END %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5 * !* IF THE RELOCATION IS RELATIVE TO SYMBOL TABLES THE WORD * !* CAN NOT BE RELOCATED TILL SIZE OF THE CODE(OR GLA) IS KNOWN * !*********************************************************************** %IF GLARAD<0 %THEN PGLA(4,4,ADDR(VALUE)) %AND GLARAD=GLACA-4 LPUT(19,2,GLARAD,AREA) %END %ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK LPUT TO ARRANGE FOR A DOUBLE WORD AT 'AT' IN THE GLA * !* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH * !*********************************************************************** %INTEGER LPUTNO %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12 LPUT(LPUTNO,XTRA,AT,ADDR(NAME)) %END %ROUTINE CXREF(%STRING(255) NAME,%INTEGER MODE,XTRA,%INTEGERNAME AT) !*********************************************************************** !* CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET * !* IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT * !* PARAMETERS ARE AS FOR GXREF. * !*********************************************************************** %INTEGER Z1,Z2 Z1=0; Z2=0 PGLA(4,8,ADDR(Z1)); ! 2 ZERO WORDS AT=GLACA-8 GXREF(NAME,MODE,XTRA,AT) %END %ROUTINE CODEDES(%INTEGERNAME AT) !*********************************************************************** !* PUT A CODE DESCRIPTOR INTO THE PLT FOR USE BY DEFINE EP * !*********************************************************************** %INTEGER DESC1,DESC2 DESC1=X'E1000000'; DESC2=0 %IF CDCOUNT=0 %THEN FIXED GLA(0)=DESC1 %AND AT=0 %C %ELSE PGLA(4,8,ADDR(DESC1)) %AND AT=GLACA-8 CDCOUNT=CDCOUNT+1 %END %ROUTINE DEFINE EP(%STRING(255)NAME, %INTEGER ADR,AT,MAIN) !*********************************************************************** !* AN EP CONSISTS OF A CODE DESCRIPTOR IN THE GLA(PLT) OF * !* FILE CONTAINING THE EP. LPUT IS TOLD ABOUT THIS AND THE LOADER* !* ARRANGES TO PUT A DESCRIPTOR-DESCRIPTOR TO THE CODE-DESC * !* IN THE GLA OF ANY FILE REFERENCES THIS EP. THIS FIRST WORD * !* OF ICLS PLT IS THE MAIN EP AND WE MIMIC THIS AS FAR AS POSS * !*********************************************************************** %IF AT=0 %THEN FIXED GLA(1)=ADR %ELSE PLUG(2,AT+4,ADR) RELOCATE(AT+4,ADR,1) LPUT(11,MAIN<<31!2,AT,ADDR(NAME)) %IF NAME#"" %END %ROUTINE PROLOGUE !*********************************************************************** !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* !*********************************************************************** %INTEGERFNSPEC STRINGIN(%INTEGER POS) %ROUTINESPEC ERR EXIT(%INTEGER A, B, C) %INTEGER I, J, K, L, STCA J=X'C2C2C2C2' LPUT(4,4,0,ADDR(J)) %CYCLE I=0, 1, 31 DESADS(I)=0; PLABS(I)=0; PLINK(I)=0 %REPEAT SSTL=4 ! ! NEXT GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! PLABS(1)=CA %CYCLE I=0, 1, 1 PCONST(UNASSPAT) %REPEAT ! ! GENERATE THE RUN TIME ERROR ROUTINE :- ! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA) ! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR IS IN ACC. XTRA HAS BEEN STACKED ! ENTRY HAS BEEN BY JLK SO RETURN ADDRESS ALSO STACKED ! !RTF LB TOS RETURN ADDRESS TO B ! SLB TOS XTRA TO B,RETURN ADDR TO TOS ! PRCL 4 START AN EXTERNAL CALL ! JLK +1 STACK DUMMY PC ! STLN TOS LNB AS SECOND PARAMETER ! ST TOS ERROR NO AS THIRD PARAM ! STB TOS XTRA AS FOURTH PARAMETER ! LXN (LNB+4) POINTER TO GLA ! RALN 9 TO STORED LNB ! CALL ((XNB+10)) VIA XREF=DESCRIPTOR-DESCRIPTOR ! J TOS BACK AFTER A MONITOR ! PLABS(2)=CA ! PF1(LB,0,TOS,0) ! PF1(SLB,0,TOS,0) ! PSF1(PRCL,0,4) ! PSF1(JLK,0,1) ! PF1(STLN,0,TOS,0) ! PF1(ST,0,TOS,0) ! PF1(STB,0,TOS,0) ! PSF1(LXN,1,16) ! PSF1(RALN,0,9) ! PF1(CALL,2,XNB,40) ! PF1(JUNC,0,TOS,0) PCLOD(0,5) ! ! SUBROUTINE TO ADVANCE STACK FRONT BY B WORDS AND FILL WITH UNASSIGNED ! ! JAT 12,*+13 B IS ZERO ! LSS TOS ! STSF TOS ! LDTB STRING DECRIPTOR SET UP DESCRIPTOR FOR MVL ! LDA TOS ! ASF B ADVANCE BY B WORDS ! MYB 4 CHANGE B TO BYTES ! LDB B AND MOVE TO BOUND FIELD ! MVL L=DR AND FILL WITH X80S ! ST TOS ! J TOS RETURN ! %IF PARMCHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING CNOP(0,4); I=CA PCONST(X'18000000') PLABS(3)=CA PF1(LDTB,0,PC,I) ! PF3(JAT,12,0,11) ! PF1(LSS,0,TOS,0) ! PF1(STSF,0,TOS,0) ! PF1(LDA,0,TOS,0) ! PF1(ASF,0,BREG,0) ! PSF1(MYB,0,4) ! PF1(LDB,0,BREG,0) ! PF2(MVL,1,1,0,0,UNASSPAT&255) ! PF1(ST,0,TOS,0) ! PF1(JUNC,0,TOS,0) PCLOD(8,13) %FINISH ! ! SUBROUTINE TO RESET STACK FRONT TO VALUE IN ACC. LINK IS ON TOS ! B MUST NOT BE ALTERED MAY HAVE SWITCH VALUE IN IT ! !RESET STSF TOS IN BYTES ! ISB TOS ADJUSTMENT IN BYTES ! ISH -2 IN WORDS ! IAD 1 ALLOW FOR DESTACKING RETURN ADDR ! SLSS TOS ! ASF TOS ! ST TOS ! J TOS ! PLABS(4)=CA ! PF1(STSF,0,TOS,0) ! PF1(ISB,0,TOS,0) ! PSF1(ISH,0,-2) ! PSF1(IAD,0,1) ! PF1(SLSS,0,TOS,0) ! PF1(ASF,0,TOS,0) ! PF1(ST,0,TOS,0) ! PF1(JUNC,0,TOS,0) PCLOD(15,18) ! ! SOME ERROR ROUTINES ! ERR EXIT(5, X'801', 0) %IF PARMCHK#0;! UNASSIGNED VARIABLE ! ERR EXIT(6, X'602', 0); ! ARRAY BOUND EXCEEDED ERR EXIT(7, X'505', 0) %IF PARMOPT#0;! ILLEGEAL EXPONENTIATION ERR EXIT(8, X'201', 0) %IF PARMOPT#0;! EXCESS BLOCKS ERR EXIT(9, 22, 0); ! LHS NOT DESTIN ERR EXIT(10,36,0) %IF PARMOPT#0; ! WRONG PARAM TO EXTERNAL ! ! PUT THE STRINGS ONTO THE FRONT OF CONSTANT AREA ! CTABLE(0)=X'18000100' CTABLE(1)=4 STCA=8; L=ADDR(CTABLE(0)) CONST PTR=2; ! IN CASE NO STRINGS %WHILE STRLINK#0 %CYCLE I=STRLINK; STRLINK=A(I) A(I)=STRINGIN(I+1); ! CHANGE LINK TO STRING ADDR %REPEAT STRLINK=X'80000000' CONST BTM=CONST PTR CTABLE(CONST PTR)=M'ADIA' CONST PTR=CONST PTR+1 %CYCLE I=0,1,31 %IF PLINK(I)#0 %THEN CLEAR LIST(PLINK(I)) %REPEAT GXREF(MDEP,0,2,40) GXREF(AUXSTEP,2,X'02000008',52) AUXST=48 %CYCLE I=0,1,NNAMES TAGS(I)=0 %REPEAT %CYCLE I=0,1,MAXLEVELS RAL(I)=0 %REPEAT J=SNUM; SNUM=0; LEVEL=0 %CYCLE I=1,1,J A(R)=13; A(R+1)=SNNNO(I) CSS(R); ! DECLARE THE SPECIAL NAME %REPEAT LEVEL=1 %RETURN %INTEGERFN STRINGIN(%INTEGER POS) !*********************************************************************** !* PUT A STRING INTO THE CONSTANT AREA CHECKING FOR DUPLICATES * !*********************************************************************** %INTEGER J,K,IND,HD,AD,SYM %RECORD(LISTF)%NAME CELL K=A(POS); ! STRING LENGTH %IF K=0 %THEN %RESULT=0 IND=K&31; HD=PLINK(IND) %WHILE HD#0 %CYCLE %EXIT %IF K>255; ! FOR LONG EBCDIC STRINGS CELL==ASLIST(HD) %IF CELL_S1=K %AND STRING(L+CELL_S2)=STRING(ADDR(A(POS))) %C %THEN %RESULT=CELL_S2-4 HD=CELL_LINK %REPEAT HD=STCA; AD=ADDR(A(POS))+3 BYTEINTEGER(L+STCA)<-K; STCA=STCA+1 %CYCLE J=AD+1,1,AD+K SYM=BYTE INTEGER(J)&127 %IF EBCDIC#0 %THEN SYM=ITOETAB(SYM) BYTE INTEGER(L+STCA)=SYM STCA=STCA+1 %REPEAT CONST PTR=((STCA+7)&(-8))>>2 PUSH(PLINK(IND),K,HD,0) %RESULT=HD-4 %END %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN ACC * !*********************************************************************** PLABS(LAB)=CA %IF MODE=0 %THEN PLANT(X'6200');! LSS 0 PSF1(SLSS,0,ERRNO) PSF1(JLK,0,(PLABS(2)-CA)//2) %END %END %ROUTINE EPILOGUE !*********************************************************************** !* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING * !* THE CODE GENERATION PHASE * !*********************************************************************** %ROUTINESPEC FILL(%INTEGER LAB) ! ! ARRAY BY VALUE SUBROUTINE ! ***** ** ***** ********** ! ENTERED BY A CALL WITH 1 PARAMETER (THE HEADER ) STACKED ! B HAS THE SIZE CODE FOR COPIED ARRAY ! EXITS WITH NEW HEADER IN ACC ! ! LXN (LNB+0) OLD VALUE OF LNB ! LXN (XNB+4) XNB TO PLT ! LSD (LND+5) COPY ORIGINAL ARRAY DESCRIPTOR ! ST %TOS TO (LNB+9) AND ASF 2 ! LD ((XNB+AUXST)) ! LSS @DR AUX STACK STACKPOINTER ! ST (LNB+6) CORRECTED HEADER ! LSS (LNB+9) GET SIZE CODE FOR ORIGINAL ! ISH -27 ! AND 7 ! ICP B COMPARE WITH REQUIRED ! JCC 2,RASI FIXING REQUIRED ! JCC 4,IASR FLOATING REQD ! AND 3 SIZE CODE NOW 1 OR 2 ! IMY 4 BYTE PER ELEMENT IN AC ! SLSS (LNB+5) GET NO OF ELEMENT ! AND X1FFFF REMOVE TYPE BITS ! IMY TOS SIZE OF ARRAY IN BYTE ! ST B ! IAD (LNB+6) UPDATE AUX STACK PTR ! ST @DR ROUNDED VALUE STORED ! ICP @DR+2 CHECK TOP OF AUXSTACK ! JCC 2,XBLKS ! LDTB BYTE DESCRIPTOR ! LDB B ! LDA (LNB+10) BYTE DESCPTR TO OLD ARRAY ! CYD 0 AS SOURCE STRING ! LDA (LNB+6) DITTO AS DESTN STRING ! MV L=DR MAKE THE COPY ! LSQ (LNB+5) NEW HEADER ! EXIT ! !IASR LSS 1 ! ISH 27 ! IAD (LNB+9) CONVERT 32 TO 64 DECSRPT ! ST (LNB+5) AND PUT INTO HEAD ! AND X'1FFFF' GET NO OF ELEMENTS ! ST B ! IMY 8 SPACE REQUIRED ! IAD (LNB+6) UPDATE AUX ST PNTR ! ST @DR ! ICP @DR+2 AND CHECK FOR O'FLOW ! JCC 2,XBLKS !LOOP SBB 1 STEP THRO ELEMENTS ! LSS ((LNB+9)),B GET OLD INTEGER ELEMENT ! FLT 0 FLOAT IT ! ST ((LNB+5)),B AND STORE IN NEW COPY OF ARRAY ! JAF 12,LOOP ! LSQ (LNB+5) PICK UP NEW HEAD ! EXIT ! !RASI LSS 1 ! ISH 27 ! IRSB (LNB+9) CONVERT 64 T0 32 BIT DECRPTR ! ST (LNB+5) AND PUT IN NEW HEADER ! AND X'1FFFF' GET NO OF ELEMENTS ! ST B ! IMY 4 ! IAD (LNB+6) UPDATE AUX ST PNTR ! ST @DR ! ICP @DR+2 AND CHECK FOR O'FLOW ! JCC 2,XBLKS !LOOP SBB 1 STEP THRO ELEMENTS ! LSD ((LNB+9)),B GET OLD REAL ELEMENT ! RAD D'0.5' AND FIX IT ! RSC 55 ! RSC -55 ! STB TOS ! FIX B ! MYB 4 ! ISH B ! MPSR 17 ! LB TOS ! ST ((LNB+5)),B AND STORE FIXED INTEGER ELEMENT ! JAF 12,LOOP ! LSQ (LNB+5) ! EXIT !XBLKS J ERROR RT 8 ! %IF PLINK(13)=0 %THEN ->P14 FILL(13) ! PSF1(LXN,1,0) ! PF1(LXN,0,XNB,16) ! PSF1(LSD,1,20) ! PF1(ST,0,TOS,0) ! PF1(LD,2,XNB,AUXST); ! NB CHANGES WITH AUXST**** ! PF1(LSS,2,7,0) ! PSF1(ST,1,24) ! PSF1(LSS,1,36) ! PSF1(ISH,0,-27) ! PSF1(AND,0,7) ! PF1(ICP,0,BREG,0) ! PF3(JCC,2,0,50) ! PF3(JCC,4,0,24) ! PSF1(AND,0,3) ! PSF1(IMY,0,4) ! PSF1(SLSS,1,20) ! PF1(AND,0,0,X'1FFFF') ! PF1(IMY,0,TOS,0) ! PF1(ST,0,BREG,0) ! PSF1(IAD,1,24) ! PF1(ST,2,7,0) ! PF1(ICP,1,0,2) ! PF3(JCC,2,0,X'44') PCLOD(42,56) PF1(LDTB,0,PC,PARAM DES(5)) ! PF1(LDB,0,BREG,0) ! PF1(LDA,0,TOS,0) ! PSF1(CYD,0,0) ! PSF1(LDA,1,24) ! PF2(MV,1,0,0,0,0) ! PSF1(LSQ,1,20) ! PSF1(EXIT,0,0) ! PSF1(LSS,0,1) ! PSF1(ISH,0,27) ! PSF1(IAD,1,36) ! PSF1(ST,1,20) ! PF1(AND,0,0,X'1FFFF') ! PF1(ST,0,BREG,0) ! PSF1(IMY,0,8) ! PSF1(IAD,1,24) ! PF1(ST,2,7,0) ! PF1(ICP,1,0,2) ! PF3(JCC,2,0,X'2D') ! PSF1(SBB,0,1) ! PF1(LSS,3,LNB,36) !! PSF1(FLT,0,0) ! PF1(ST,3,LNB,20) ! PF3(JAF,12,0,-6) ! PSF1(LSQ,1,20) ! PSF1(EXIT,0,0) ! PSF1(LSS,0,1) ! PSF1(ISH,0,27) ! PSF1(IRSB,1,36) ! PSF1(ST,1,20) ! PF1(AND,0,0,X'1FFFF') ! PF1(ST,0,BREG,0) ! PSF1(IMY,0,4) ! PSF1(IAD,1,24) ! PF1(ST,2,7,0) ! PF1(ICP,1,0,2) ! PF3(JCC,2,0,X'15') ! PSF1(SBB,0,1) ! PF1(LSD,3,LNB,36) PCLOD(57,80) PF1(RAD,0,PC,SPECIAL CONSTS(0));! 0.5 ! PSF1(RSC,0,55) ! PSF1(RSC,0,-55) ! PF1(STB,0,TOS,0) ! PF1(FIX,0,BREG,0) ! PSF1(MYB,0,4) ! PF1(ISH,0,BREG,0) ! PSF1(MPSR,0,17) ! PF1(LB,0,TOS,0) ! PF1(ST,3,LNB,20) ! PF3(JAF,12,0,-15) ! PSF1(LSQ,1,20) ! PSF1(EXIT,0,0) PCLOD(82,88) PF1(JUNC,0,0,(PLABS(8)-CA)//2) P14: ! ! EVALUATE X**Y ! ******** **** ! Y IS IN ACC X IS STACKED BELOW THE LINK(UNAVOIDABLE) ! FAULT(21) IS GIVEN IF X<0 OR (X=0 AND Y<=0) ! REPEATED MULTIPLICATION IS USED IF Y>0 AND FRACPT(Y)=0 ! OTHERWISE RESULT=EXP(Y*LOG(Y)) ! ! LB TOS SWOP RETURN ADDRESS & X ! LD TOS X TO DR ! STB TOS ! STD TOS ! SLSD TOS X TO ACC Y TO TOS ! JAT 2,EXPERR ERROR IF X<0 ! JAF 0,TRYMULT JUMP X#0 ! SLSD TOS STACK X & GET Y ! JAF 1.EXPERR Y<=0 ! LSD TOS X (=0) =RESULT TO ACC ! J TOS RETURN !TRYMULT X IS IN ACC & Y STACKED ! SLSD TOS Y TO ACC AND X STACKED ! ST TOS Y STACKED ! JAT 2,NONINT Y IS NEGATIVE ! RSC 55 ! RSC -55 ! FIX B FIX PINCHED FROM ICL ALGOL ! MYB 4 ! CPB -64 ! JCC 10,*+3 ! LB -64 ! ISH B ! STUH B ACC TO 1 WORD ! JCC 7,NONINT JUMP IF TRUNCATION ! ASF -2 LOSE Y OF STACK ! ST B INTEGER VERSION OF Y TO B ! LSS 1 ! FLT 0 ! JAF 12,MUL JUMP IF B#0 ! ASF -2 LOSE X OFF STACK ! J TOS X**0 =1 !AGN STD TOS STACK ANOTHER COPY OF X !MUL RMY TOS ! DEBJ AGN REPEATED MULTIPLICATION ! J TOS !NONINT Y IS STACKED OVER X ! LSD TOS ! SLSD TOS ! PRCL 4 ! ST TOS ! LXN (LNB+4) ! RALN 7 ! CALL ((XNB+LOGEPDISP) ! RMY TOS ! PRCL 4 ! ST TOS ! LXN (LNB+4) TO PLT ! RALN 7 ! CALL ((XNB+EXPEPDISP)) CALL EXP ! J TOS !EXPERR J ERROR RT NO 7 ! %IF PLINK(14)=0 %THEN ->P15 FILL(14) %IF LOGEPDISP=0 %THEN CXREF("S#ILOG",PARMDYNAMIC,2,LOGEPDISP) %IF EXPEPDISP=0 %THEN CXREF("S#IEXP",PARMDYNAMIC,2,EXPEPDISP) ! PF1(LB,0,TOS,0) ! PF1(LD,0,TOS,0) ! PF1(STB,0,TOS,0) ! PF1(STD,0,TOS,0) ! PF1(SLSD,0,TOS,0) ! PF3(JAT,2,0,X'37') ! PF3(JAF,0,0,7) ! PF1(SLSD,0,TOS,0) ! PF3(JAF,1,0,X'32') ! PF1(LSD,0,TOS,0) ! PF1(JUNC,0,TOS,0) ! PF1(SLSD,0,TOS,0) ! PF1(ST,0,TOS,0) ! PF3(JAT,2,0,26) ! PSF1(RSC,0,55) ! PSF1(RSC,0,-55) ! PF1(FIX,0,BREG,0) ! PSF1(MYB,0,4) ! PSF1(CPB,0,-64) ! PF3(JCC,10,0,3) ! PSF1(LB,0,-64) ! PF1(ISH,0,BREG,0) ! PF1(STUH,0,BREG,0) ! PF3(JCC,7,0,14) ! PSF1(ASF,0,-2) ! PF1(ST,0,BREG,0) ! PSF1(LSS,0,1) ! PSF1(FLT,0,0) ! PF3(JAF,12,0,5) ! PSF1(ASF,0,-2) ! PF1(JUNC,0,TOS,0) ! PF1(STD,0,TOS,0) ! PF1(RMY,0,TOS,0) ! PSF1(DEBJ,0,-2) ! PF1(JUNC,0,TOS,0) ! PF1(LSD,0,TOS,0) ! PF1(SLSD,0,TOS,0) ! PSF1(PRCL,0,4) ! PF1(ST,0,TOS,0) ! PSF1(LXN,1,16) ! PSF1(RALN,0,7) PCLOD(90,113) PF1(CALL,2,XNB,LOGEPDISP) ! PF1(RMY,0,TOS,0) ! PSF1(PRCL,0,4) ! PF1(ST,0,TOS,0) ! PSF1(LXN,1,16) ! PSF1(RALN,0,7) PCLOD(115,117) PF1(CALL,2,XNB,EXPEPDISP) PF1(JUNC,0,TOS,0) PF1(JUNC,0,0,(PLABS(7)-CA)//2) P15: %IF PLINK(15)=0 %THEN ->P16 FILL(15) ! ! CONTINGENCY ENTRY - LNB RESTORE FOR MAIN PROGRAM. ACC HAS WORD DECP ! TO 18 WORD AREA OF FAILURE & IMAGE STORE:- ! WORD0 = FAILURE?, WORD1=XTRA?,WORD2=LNB,WORD4=PC ! THIS ROUTINE TRANSCRIBES THESE INTO A CALL ON MDIAGS ! ! ST TOS ! LD TOS DESCRIPTOR TO DR ! PRCL 4 START RT CALL ! LSS (DR+4) PC FIRST PARAM ! SLSS (DR+2) LNB SECOND PARAM ! SLSS 10 INTERRUPT OF CLASS ! SLSS (DR) XTRA IS CLASS NO ! ST TOS ! LXN (LNB+4) TO PLT(GLA) ! RALN 9 ! CALL ((XNB+10)) TO MDIAGS - DOES NOT RETURN ! ! PF1(ST,0,TOS,0) ! PF1(LD,0,TOS,0) ! PSF1(PRCL,0,4) ! PF1(LSS,1,0,4) ! PF1(SLSS,1,0,2) ! PSF1(SLSS,0,10) ! PF1(SLSS,2,7,0) ! PF1(ST,0,TOS,0) ! PSF1(LXN,1,16) ! PSF1(RALN,0,9) ! PF1(CALL,2,XNB,40) PCLOD(20,26) P16: %IF PLINK(16)=0 %THEN ->P17 FILL(16) ! ! THE STOP SEQUENCE ! CALL %SYSTEMROUTINE STOP(NO PARAMETERS) ! !STOP1 PRCL 4 ! LXN (LNB+4) ! RALN 5 ! CALL ((XNB+STOPEPDISP)) ! **PLEASE DONT COME BACK** ! CXREF("S#STOP",PARMDYNAMIC,2,J) PCONST(X'18047E84'); ! PRCL 4-- LXN (LNB+4) PLANT(X'6C05'); ! RALN 5 PF1(CALL,2,XNB,J) P17: ! ROUTINE PARAMETER SUBROUTINE ! B HAS FOURTH PARAMETER (ENV) WORD ! ACC (32BITS) HAS DESCRIPION WORD M'AE'&M'IMP' INDICATE THE OLD ! COMPILERS WITH ENV IN XNB ! ALL OTHER NON ZERO ENVIRONMENTS ARE STACKED ! ! LXN B XNB IS ENV OR IMMATERIAL ! JAF 12,*+6 ZERO B = NO ENV !OLDAE J TOS ! ICP M'AE' ! JCC 8,OLDAE OLD ALGOL(E) ! ICP M'IMP' ! JCC 8,OLDAE OLD IMP AS OLD AE ! SLB TOS STACK PARM RETURN ADDR TO B ! J B %IF PLINK(17)=0 %THEN ->P18 CNOP(0,4) PCONST(M'IMP') FILL(17) PF1(LXN,0,BREG,0) PF3(JAF,12,0,3) PF1(JUNC,0,TOS,0) PF1(ICP,0,0,M'AE') PF3(JCC,8,0,-3) PF1(ICP,0,PC,CA-20) PF3(JCC,8,0,-4) PF1(SLB,0,TOS,0) PF1(JUNC,0,BREG,0) P18: %RETURN %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS * !*********************************************************************** %INTEGER AT,INSTRN,SPARE %WHILE PLINK(LAB)#0 %CYCLE POP(PLINK(LAB),AT,INSTRN,SPARE) INSTRN=INSTRN!(CA-AT)>>1 PLUG(1,AT,INSTRN) %REPEAT PLABS(LAB)=CA %END %END %ROUTINE DUMP CONSTS !*********************************************************************** !* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS * !*********************************************************************** %ROUTINESPEC DOIT(%INTEGER VAL) %INTEGER I,J,K,DISP LPUT(1,CONSTPTR*4,CA,ADDR(CTABLE(0))) %IF CONSTPTR#0 %IF ALLOW CODELIST=YES %AND DCOMP#0 %START %IF VMEB=YES %THEN FAULTMK(4); ! START OF CODE ETC PRINTSTRING(" CONSTANT TABLE") I=0 %CYCLE NEWLINE PRHEX(CA+4*I,5) %CYCLE J=0,1,7 SPACES(2) PRHEX(CTABLE(I+J),8) %REPEAT SPACE %CYCLE J=0,1,31 K=BYTEINTEGER(ADDR(CTABLE(I))+J) %IF K<31 %OR K>95 %THEN K=32 PRINT SYMBOL(K) %REPEAT I=I+8 %EXIT %IF I>=CONSTPTR %REPEAT NEWLINE %IF VMEB=YES %THEN FAULTMK(1); ! BACK TO NORMAL %FINISH ! DISP=CA//2; ! RELOCATION FACTOR %WHILE CREFHEAD#0 %CYCLE POP(CREFHEAD,I,J,K) DOIT(I) %IF J#0 %THEN DOIT(J) %IF K#0 %THEN DOIT(K) %REPEAT CA=CA+4*((CONSTPTR+1)&(-2)) DISP=2*DISP; ! NOW UPDATE DESRPTR TO CONST ! WHICH ARE IN GLA %WHILE GLARELOCS#0 %CYCLE POP(GLARELOCS,I,J,K) J=J+DISP LPUT(2,4,I,ADDR(J)) %REPEAT %RETURN %ROUTINE DOIT(%INTEGER VAL) !*********************************************************************** !* IF VAL +VE THEN VAL IS CODE ADDRESS FOR LPUT(18) UPDATE * !* IF VAL -VE IT IS GLAWRDADDRR<<16!CTABLE WRD ADDR * !* THE GLA WORD IS TO RELOCATED BY HEAD OF CODE(ALREADY DONE) * !* HOWEVER THE GLAWORD NEEDS UPDATING FROM REL CTABLE TO REL CODE * !*********************************************************************** %INTEGER I,J %IF VAL>0 %THEN LPUT(18,0,VAL,DISP) %ELSE %START I=(VAL>>16&X'7FFF')<<2; ! GLA BYTE ADDRESS J=4*(VAL&X'FFFF')+CA; ! CTABLE ENTRY REL HD OF CODE PLUG(2,I,J); ! UPDATE THE GLA WORD %FINISH %END %END %ROUTINE CSS(%INTEGER P) %ROUTINESPEC MERGE INFO %ROUTINESPEC REDUCE ENV(%INTEGERNAME HEAD) %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG) %ROUTINESPEC ENTER LAB(%INTEGER M,FLAG,LEVEL) %ROUTINESPEC CEND(%INTEGER KKK) %ROUTINESPEC RESET AUX STACK %ROUTINESPEC SAVE AUX STACK(%INTEGER ARRS) %ROUTINESPEC CBPAIR(%INTEGERNAME LB,UB) %ROUTINESPEC CCOND %ROUTINESPEC SET LINE %ROUTINESPEC C FORSTMNT %ROUTINESPEC CSTMNT %ROUTINESPEC CUI %ROUTINESPEC GOTOLAB(%INTEGER MODE) %ROUTINESPEC CDE(%INTEGER MODE) %ROUTINESPEC CSDE(%INTEGER MODE) %ROUTINESPEC CCMPNDSTMNT %ROUTINESPEC CBLK(%INTEGER BLKTYPE) %ROUTINESPEC ETORP(%INTEGERNAME A,B,%INTEGER C) %ROUTINESPEC TORP(%INTEGERNAME HEAD,NOPS,%INTEGER MODE) %ROUTINESPEC SET USE(%INTEGER R,U,I) %ROUTINESPEC CSEXP(%INTEGER REG,MODE,NME) %ROUTINESPEC SAVE IRS %ROUTINESPEC BOOT OUT(%INTEGER MODE) %ROUTINESPEC EXPOP(%INTEGER A,B,C,D) %ROUTINESPEC TEST APP(%INTEGERNAME NUM) %ROUTINESPEC SKIP EXP(%INTEGER MODE) %ROUTINESPEC SKIP SEXP(%INTEGER MODE) %ROUTINESPEC SKIP APP %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,%INTEGERNAME C,D) %ROUTINESPEC MAKE DECS(%INTEGER P,K) %ROUTINESPEC DECLARE OWNS %ROUTINESPEC DECLARE ARRAYS %ROUTINESPEC DECLARE SCALARS %ROUTINESPEC DECLARE LAB %ROUTINESPEC DECLARE PROC %ROUTINESPEC DECLARE SWITCH %ROUTINESPEC CLABEL %ROUTINESPEC COLABEL %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) %ROUTINESPEC GTHUNKS(%INTEGER A,B) %INTEGERFNSPEC CHECK FPROCS(%INTEGER A,B) %ROUTINESPEC CRCALL(%INTEGER A) %ROUTINESPEC CALL THUNKS(%INTEGER A,REG,B,C) %ROUTINESPEC FETCH STRING(%INTEGER REG) %ROUTINESPEC CNAME(%INTEGER Z,REG) %ROUTINESPEC CANAME(%INTEGER Z,BS,DP) %ROUTINESPEC CSNAME(%INTEGER Z,REG) %ROUTINESPEC COPY TAG(%INTEGER KK) %ROUTINESPEC REDUCE TAG %ROUTINESPEC REPLACE TAG (%INTEGER KK) %ROUTINESPEC RT JUMP(%INTEGER CODE,%INTEGERNAME RT) %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK) %ROUTINESPEC UNPACK %ROUTINESPEC PACK(%INTEGERNAME PTYPE) %ROUTINESPEC RHEAD(%INTEGER KK) %ROUTINESPEC RDISPLAY(%INTEGER KK) %ROUTINESPEC ODDALIGN %INTEGERFNSPEC PTR OFFSET(%INTEGER RLEV) %ROUTINESPEC PPJ(%INTEGER MASK,N) %ROUTINESPEC REMEMBER %INTEGERFNSPEC REVERSE(%INTEGER MASK) %INTEGERFNSPEC AREA CODE %INTEGERFNSPEC SET XORYNB(%INTEGER WHICH,L) %INTEGERFNSPEC XORYNB(%INTEGER USE,LEV) %ROUTINESPEC GET IN ACC(%INTEGER A,B,C,D,E) %ROUTINESPEC NO APP %ROUTINESPEC DIAG POINTER(%INTEGER L) %ROUTINESPEC COPY DR %ROUTINESPEC CHANGE RD(%INTEGER REG) %ROUTINESPEC TEST ASS(%INTEGER REG) %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,VAR) %SWITCH SW(1:13) %RECORDFORMAT RD(%BYTEINTEGER UPTYPE,PTYPE,XB,FLAG,%C %INTEGER D,XTRA) %INTEGER TWSPHEAD,SNDISP,ACC,K,KFORM %INTEGER TCELL,JJ,JJJ,KK,BASE,DISP,AREA,ACCESS, %C PTYPE,I,J,OLDI,USEBITS,ROUT,NAM,ARR,TYPE %INTEGERARRAY SGRUSE,SGRINF(0:7) TWSPHEAD=0 ->SW(A(P)) SW(1): ! SET LINE %IF PARMLINE#0 %IF LEVEL<=1 %THEN FAULT(57,0) %AND %RETURN NMDECS(LEVEL)=NMDECS(LEVEL)!1 P=P+1; CSTMNT CSSEXIT: %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK,JJJ) RETURN WSP(JJ,KK) %REPEAT %RETURN SW(2): ! %END SET LINE %IF PARMLINE#0 %IF A(P+1)=1 %THEN FAULT(47,0) CEND(FLAG(LEVEL)) %RETURN SW(4): ! %PROCEDURE ->VDEC %UNLESS A(P+2)=1 FAULT(40,0) %UNLESS NMDECS(LEVEL)=0 %BEGIN %RECORD(LISTF)%NAME LCELL %INTEGER PNAME, EXTRN, Q, PP, PTYPEP, PARN, DISP, TYPEP, LINK, NP,%C LINEP, PE, PL, OPHEAD, AVHEAD, OPBOT P=P+1 PP=P; PNAME=A(P+4); ! PROCEDURE NAME EXTRN=P+3+A(P+3); ! TO OLABEL PL=EXTRN %WHILE A(EXTRN)=1 %CYCLE; EXTRN=EXTRN+3; %REPEAT PE=EXTRN+1; ! TO ALT OF PROCSTMNT EXTRN=A(PE) %IF LEVEL=1 %AND CPRMODE=0 %THEN CPRMODE=2 %AND MAKE DECS(0,-1) COPY TAG(PNAME); Q=K LINEP=SNDISP P=PP %UNLESS ROUT=1 %AND OLDI=LEVEL %THEN DECLARE PROC P=PP ->L99 %IF EXTRN<=3 %OR J=14 %IF LEVEL=1 %THEN %START CPRMODE=2 %IF CPRMODE=0 FAULT(105, PNAME) %IF CPRMODE#2 JJ=ASLIST(Q)_S1 DEFINE EP(STRING(DICTBASE+WRD(PNAME)), CA, JJ, 0) %IF JJ#0 %THEN PSF1(INCA,0,-JJ) DIAG POINTER(LEVEL+1) %FINISH COPY TAG(PNAME) LINK=K; Q=ACC JJ=LINK; NP=ASLIST(LINK)_S2; ! NO OF PARAMS PLABEL=PLABEL-1 %UNLESS CPRMODE=2 %AND LEVEL=1 %START JROUND(LEVEL+1)=PLABEL ENTER JUMP(15,PLABEL, 0) %FINISH PTYPEP=PTYPE RHEAD(PNAME) ! ! CHANGE TAG TO 'BODY GIVEN' BY SETTING J=0 IN WORD 0 OF THE TAGS FIELD ! LCELL==ASLIST(TAGS(PNAME)) LCELL_S1=LCELL_S1&X'FFFFFFF0'; ! AND OUT "J"(DIMEN) FIELD ! ! GO DOWN THE PARAMETER LIST OF THE PROCEDURE AND DECLARE THE ! PARAMETERS AS LOCAL VARIABLE AT THIS LEVEL ! MLINK(LINK); AVHEAD=0 %WHILE LINK#0 %CYCLE FROM123(LINK, TYPEP, PARN, DISP) J=PARN>>16; PTYPE=TYPEP %IF PTYPE&X'F00'>X'100' %THEN PTYPE=PTYPE&X'F0FF'!X'100' TYPE=PTYPE&7 K=PARN&X'FFFF'; ACC=0; KFORM=LINK ! TEST NST; SNDISP=M'FP' ACC=BYTES(TYPE) %IF TYPE<=3 %AND PTYPE<4096 %IF PTYPE>=4096 %START; ! PROCEDURE PARAMETERS OPHEAD=0; OPBOT=0; JJ=J %WHILE JJ>0 %CYCLE BINSERT(OPHEAD,OPBOT,ASLIST(JJ)_S1, %C ASLIST(JJ)_S2,ASLIST(JJ)_S3) MLINK(JJ) %REPEAT; J=0 ASLIST(OPHEAD)_S1=(DISP&X'FFFF') DISP=OPHEAD %FINISH STORE TAG(K, DISP&X'FFFF') %IF PTYPE&X'FF0'=X'10' %START; ! ARRAYS BY VALUE PUSH(AVHEAD,DISP,SIZECODE(PTYPE&7),0) %FINISH MLINK(LINK) %REPEAT N=Q; ! TOTAL SPACE OCCUPIED BY SAVE !AREA AND PARAMS Q=PP+6 PTYPE=PTYPEP RDISPLAY(PNAME) %WHILE AVHEAD#0 %CYCLE POP(AVHEAD,DISP,JJ,JJJ) SAVE AUX STACK(1); ! ARRAYS ON STACK PLANT(X'1804'); ! PRCL 4 PSF1(LSQ,1,DISP&X'FFFF') PLANT(X'4998'); ! ST TOS PLANT(X'7A00'!JJ); ! LB JJ(=ELSIZE IN BYTES) PLANT(X'6C09'); ! RALN 5 PPJ(-1,13); ! CALL PERM SUBROUTINE PSF1(ST,1,DISP&X'FFFF') %REPEAT %IF NP>0 %THEN Q=Q+3*NP-1 MAKE DECS(Q, PTYPEP) P=PL; COLABEL %IF EXTRN=5 %THEN %START P=PE+1; LINE=A(P) P=P+1; SET LINE %IF PARMLINE#0 CSTMNT CEND(FLAG(LEVEL)) %FINISH L99: %END ->CSSEXIT VDEC: SW(7): ! '%OWN' (TYPE)(OWNDEC) FAULT(40,0) %UNLESS NMDECS(LEVEL)=0 %RETURN SW(5): ! %BEGIN %BEGIN %INTEGER CORB,SIGEPNO CORB=A(P+1) PTYPE=0 %IF LEVEL=1 %AND RLEVEL=0 %THEN %START RLEVEL=1 FAULT(105,0) %IF CPRMODE#0 CODE DES(JJ) DEFINE EP(MAINEP, CA, JJ, 1) L(1)=0; M(1)=0 DIAGINF(1)=0; AUXSBASE(1)=0 CPRMODE=1 N=24; NMAX=N %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE I=0,1,7 GRUSE(I)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH DIAGPOINTER(LEVEL+1) ! ! LAY DOWN A CONTINGENCY AGAINST ERROR IN PROGRAM ! IE COMPILE EXTERNAL CALL 'S#SIGNAL(0,PC,LNB,FLAG)' ! CXREF(SIGEP,PARMDYNAMIC,2,JJ); ! REFERENCE TO SIGNAL ! ! THE CODE PLANTED IS AS FOLLOWS:- ! LXN (LNB+4) TO GLA(PLT) ! STLN (XNB+5) SAVE LNB FOR STOP SEQUENCE ! ASF 1 FOR REPORT WORD ! PRCL 4 START OF STANDARD CALL ! LSS SIGEPNO 9 IN JOBBER MODE 0 OTHERWISE ! ST TOS FIRST PARAM ! JLK +3 2ND PARAM AND JUMP ROUND NEXT INSTR ! JCC 15,PERM15 TO RECOVERY SUBROUTINE ! STLN TOS 3RD PARAM ! LDTB WORD DES DESC USED FOR 'INTEGER()' ! LDA (XNB+5) ADD IN LNB ! INCA +20 TO WORD 5 OF FRAME(REPORT WORD) ! STD TOS 4TH AND LAST PARAM ! RALN 10 ! CALL SIGREF ! PSF1(LXN,1,16) PF1(STLN,0,XNB,20) PSF1(ASF,0,1) PSF1(PRCL,0,4) %IF PARMBITS1&JOBBERBIT#0 %THEN SIGEPNO=9 %ELSE SIGEPNO=0 PSF1(LSS,0,SIGEPNO) PF1(ST,0,TOS,0) PSF1(JLK,0,3) PPJ(15,15) PF1(LDTB,0,PC,PARAM DES(1)) ! PF1(STLN,0,TOS,0) ! PF1(LDA,0,XNB,20) ! PSF1(INCA,0,20) ! PF1(STD,0,TOS,0) ! PSF1(RALN,0,10) ! PF1(MPSR,0,0,X'40C0') PCLOD(37,40) PF1(CALL,2,XNB,JJ) ! ! SET THE PROGRAM MASK TO MASK OUT UNDERFLOW AND ALLOW ALL OTHER INTS ! ! MPSR X'40C0' ! PTYPE=1 RHEAD(-1) RDISPLAY(-1) %IF CORB=1 %THEN %START P=P+2 %WHILE A(P)=1 %CYCLE; P=P+1; %REPEAT; ! PAST COMMENTS P=P+1; COLABEL ! LINE=LINE+1 SET LINE %IF PARMLINE#0 NMDECS(LEVEL)=NMDECS(LEVEL)!1 CSTMNT %FINISH %ELSE MAKE DECS(P+2,-1) %FINISH %ELSE %START P=P+2 %IF CORB=1 %THEN CCMPNDSTMNT %ELSE %START RHEAD(-1) RDISPLAY(-1) MAKE DECS(P,-1) %FINISH %FINISH %END ->CSSEXIT SW(6): ! %SWITCH := FAULT(40,0) %UNLESS NMDECS(LEVEL)=0 %BEGIN %INTEGER N,DIS,REP,I,PL,FLAG,SWNAME,J SWNAME=A(P+1)&X'FFFF' COPYTAG(SWNAME) REP=0; N=KFORM %IF ARR=1 %THEN %START; ! SWITCH NOT SIMPLE DIS=(K&X'FFFF')*4 P=P+4 PLABEL=PLABEL-1 PL=PLABEL FLAG=B'10' ENTER JUMP(15,PL,FLAG) %CYCLE I=0,1,N-1 J=CA-DIS PLUG(1,DIS+4*I,J) %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE J=0,1,7 GRUSE(J)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH CDE(2) P=P+2 %REPEAT ENTER LAB(PL,B'110',LEVEL) %FINISH %END ->CSSEXIT SW(8): ! : P=P+1; CLABEL; CSS(P) SW(3): ! %COMMENT %RETURN SW(10): ! %CODEON SW(11): ! %CODEOFF %IF ALLOW CODELIST=YES %THEN %START CODEOUT DCOMP=(A(P)-1)&1 %FINISH %RETURN SW(13): ! %SPECIALNAME Q=A(P+1) PUSH(TAGS(Q),SNPT<<16!X'8000',0,SNUM<<16) SNUM=SNUM+1 %RETURN SW(9): ! NMDECS(LEVEL)=NMDECS(LEVEL)!1 %RETURN SW(12): ! %PROGRAM (NAME)(S) FAULT(40,0) %UNLESS CPRMODE=0 Q=A(P+1) MAINEP<-STRING(DICTBASE+WRD(Q)) %RETURN %ROUTINE DECLARE OWNS !*********************************************************************** !* OWN DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES * !* ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES * !* FOR THE LOADER TO RELOCATE THE HEADERS. * !*********************************************************************** %ROUTINESPEC CLEAR(%INTEGER L) %ROUTINESPEC STAG(%INTEGER J) %INTEGER LENGTH, BP, PP, ICONST1, ICONST2, TAGDISP, AH1, AH2, AH3, %C AH4, AD, NNAMES, PTYPEP, PTYPEPP, LB, APARM FAULT(40,0) %IF NMDECS(LEVEL)&1#0 P=P+3 NAM=0; ARR=A(P)-1; ROUT=0 ICONST1=0; ICONST2=0 TYPE=A(P-1); TYPE=2 %IF TYPE=4 ACC=BYTES(TYPE); P=P+2 PACK(PTYPE); PTYPEP=PTYPE ->NON SCALAR %UNLESS ARR=0 ! %UNTIL A(P-1)=2 %CYCLE; ! DOWN J=0; K=A(P) KFORM=0; AD=ADDR(ICONST1) PGLA(ACC, ACC, AD); ! PUT CONSTANT INTO GLA TAGDISP=GLACA-ACC; ! OFFSET OF VAR FOR TAGS STAG(TAGDISP) P=P+2 %REPEAT %RETURN NONSCALAR: ! OWN ARRAYS !*********************************************************************** !* P:= * !* P:=',',%NULL * !*********************************************************************** P=P+1; PP=P; NNAMES=1; ! P TO START OF DECLIST APARM=A(P) %WHILE A(P+1)=1 %CYCLE APARM=APARM!A(P); P=P+2; NNAMES=NNAMES+1 %REPEAT APARM=1-APARM>>16 P=P+2; BP=ACC; PTYPEPP=PTYPEP ! ! NOW OUTPUT A DOPE VECTOR ! AH4=DOPE VECTOR(BP, APARM, LENGTH, LB)+12 %IF LB=0 %AND J=1 %THEN PTYPEPP=PTYPEPP+16;! SET ARR=2 NO DVM NEEDED %UNTIL NNAMES=0 %CYCLE K=A(PP)&X'FFFF' USTPTR=(USTPTR+3)&(-4) ! ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL- ! TABLES IN WHICH THE ARRAY RESIDES. THE LOADER WILL RELOCATE ! BY ADDING INTO AH1-3 THE VIRTUAL ADDRESS OF THE START OF THE ! APPROPIATE AREA. ! %IF TYPE=2 %THEN AH1=6 %ELSE AH1=5 AH1=AH1<<27!LENGTH AH2=USTPTR AH3=5<<27!3*J; ! DV DESCPTR = WORD + CHECKED CLEAR(LENGTH) PGLA(8, 16, ADDR(AH1)) TAGDISP=GLACA-16 RELOCATE(TAGDISP+4, AH2, 5);! RELOCATE ADDR(A(FIRST)) RELOCATE(TAGDISP+12, AH4, 1);! RELOCATE DV POINTER NOTE CREF(((AH4<<1>>3)!X'80000000')!(TAGDISP+12)>>2<<16) PTYPE=PTYPEPP KFORM=0 STAG(TAGDISP) PP=PP+2 NNAMES=NNAMES-1 %REPEAT %IF A(P)=1 %THEN P=P+2 %AND ->NONSCALAR %RETURN %ROUTINE CLEAR(%INTEGER LENGTH) LENGTH=(LENGTH+3)&(-4) LPUT(5, LENGTH, USTPTR, 0) %IF INHCODE=0 USTPTR=USTPTR+LENGTH %END %ROUTINE STAG(%INTEGER J) %INTEGER RL ! TEST NST RL=RLEVEL SNDISP=0 RLEVEL=0 STORE TAG(K, J) RLEVEL=RL %END %END; %ROUTINE MAKE DECS(%INTEGER PP, KK) !*********************************************************************** !* PP TO LIST OF LIKS:- * !* A(PP) = LINKS FOR LABELS, A(PP+1) = LINKS FOR SCALARS * !* A(PP+2) = LINK FOR ARRAYS, A(PP+3) = LINK FOR SWITCHES * !* A(PP+4) = LINK FOR OWN DECS,A(PP+5) = LINK FOR PROCEDURES * !* A(PP+6) = COUNT OF BLKS & (LABELS IN INNER BLOCKS) * !* KK <0 FOR BEGIN BLOCKS >0 FOR PROCEDURES * !*********************************************************************** %ROUTINESPEC DOWN LIST(%INTEGER Q,LN,INC,%ROUTINE DEC) %INTEGER SAVELINE, Q, QQ, ARRS, INTLABS, LABPARAMS, INNERBLKS SAVELINE=LINE ARRS=AUXSBASE(LEVEL)!A(PP+2); ! =0 IF THERE ARE NO ARRAYS TO BE ! DECLARED & THERE WERE NO ARRAYS ! PASSED BY VALUE LABPARAMS=PASS2INF&(LABBYNAME!SWBYNAME) INNERBLKS=A(PP+6)>>12 INTLABS=A(PP)!A(PP+6)&X'FFF'; ! =0 IF NOLABS IN BLK OR SUBBLKS ! ! PROGRAMS AND EXTERNAL ROUTINES NEED A COPY OF AUX STACKTOP IN CASE ! A LABEL IS PASSED BY NAME INTO A SEPARATELY COMPILED ENTITY WHICH ! HAS DECLARED ARRAYS. IF PASS 2 REPORTS NO LABEL OR SWITCH PARAMETERS ! AND THERE ARE NO NESTED BLOCKS OR THIS BLOCK + ALL CONTAINED ! BLOCKS&PROCS HAVE NO LABELS THEN THIS CASE CAN NOT ARRISE ! %IF LEVEL=2 %AND (INTLABS#0 %%AND INNERBLKS!LABPARAMS#0) %C %THEN SAVE AUX STACK(ARRS) ! DOWN LIST(PP+1,1,2,DECLARE SCALARS) ! DOWN LIST(PP+4,1,1,DECLARE OWNS) ! DOWN LIST(PP,0,3,DECLARE LAB) ! Q=PP+3; QQ=A(Q) %IF QQ#0 %START CNOP(0,4); PLABEL=PLABEL-1 ENTER JUMP(15,PLABEL,B'10') DOWN LIST(Q,1,3,DECLARE SWITCH) ENTER LAB(PLABEL,0,LEVEL) %FINISH ! DOWN LIST(PP+5,2,2,DECLARE PROC) ! Q=PP+2 DOWN LIST(Q,2,2,DECLARE ARRAYS) ! LINE=SAVELINE Q=AUXSBASE(LEVEL)&X'3FFFF' %IF Q#0 %THEN %START %IF ARRS#0 %START ! ! WE HAVE AN AUX STACK: DO WE NEED TO STORE THE AUGMENTED TOP? ! ONLY IF WE CAN PASS A LABEL FROM THIS OR INNER BLOCK OUT OR ! IF WE CAN JUMP INTO THIS(OR INNER)BLK FROM NESTED BLK ! %IF INTLABS#0 %AND INNERBLKS!LABPARAMS#0 %THEN %START PSF1(LSS,2,Q) %IF A(PP+2)=0;! NOT STILL GOT AUXSF IN ACC PSF1(ST,1,Q+12); ! ONLY USED AFTER JUMP OUT OF ! AN INNER BLK OR PROCEDURE %FINISH %FINISH %FINISH %ELSE AUXSBASE(LEVEL)=AUXSBASE(LEVEL-1) ! ! MUST STORE STACKTOP IN CASE THIS PROC IS REENTERED BY BY JUMPING OUT ! OF AN INNER BLOCK OR FN WHEN THE STACK MUST BE RESET. IF THE BLOCK ! HAS NO LABELS IN IT AND NO LABELS IN ANY INNER BLOCK CAN OMIT THIS ! %IF KK>0 %OR LEVEL=2 %START ! ! DO WE NEED TO STORE SF AT THIS POINT. YES FOR REASONS OF AUX STACK FRNT ! %IF INTLABS#0 %AND INNERBLKS!LABPARAMS#0 %START PSF1(STSF,1,N) STACKBASE(RLEVEL)=N N=N+4 %FINISH %ELSE STACKBASE(RLEVEL)=-1 %FINISH %RETURN %ROUTINE DOWN LIST(%INTEGER Q,LN,INC,%ROUTINE DECLARE) !*********************************************************************** !* SCANS DOWN A LINKED LIST OF ARS MAKING THE APPROPIATE * !* DECLARATIONS. THIS BRINGS ALL DECLARATIONS INCLUDING PROCS * !* TO THE FRONTOF THE BLOCK AND SIDESTEPS FORWARD REFS * !*********************************************************************** %INTEGER QQ QQ=A(Q) %WHILE QQ#0 %CYCLE Q=Q+QQ-1 %IF LN=0 %THEN LINE=SAVELINE %C %ELSE LINE=A(Q-LN) P=Q; DECLARE Q=Q+INC QQ=A(Q) %REPEAT %END %END %ROUTINE DECLARE LAB !*********************************************************************** !* THIS ROUTINE DECLARES ALL THE LABELS SO THAT A %GOTO CAN * !* BE CLASSIFIED AS INTERNAL OR EXTERNAL IMMEDIATELY * !*********************************************************************** K=A(P+2); ! K IS NAME PTYPE=6; SNDISP=0 KFORM=0; J=0; ACC=0 ! TEST NST STORE TAG(K, 0) %END %ROUTINE DECLARE SWITCH !*********************************************************************** !* P IS TO ALT OF P(SS) * !* THIS ROUTINE RESERVES SPACE IN THE SST FOR THE SWITCH AND * !* DECLARES THE NAME BUT NO CODE IS GENERERATED * !*********************************************************************** %INTEGER I, N, MARK, D0, D1, SIMPLE, SWNAME SWNAME=A(P+2)&X'FFFF'; N=0; SIMPLE=1 MARK=P+3 %UNTIL A(MARK)#1 %CYCLE N=N+1 SIMPLE=0 %UNLESS A(MARK+2)=2 %AND A(MARK+3)=1 %AND %C A(MARK+5)=3 %IF SIMPLE#0 %START COPY TAG(A(MARK+4)) SIMPLE=0 %UNLESS OLDI=LEVEL %AND PTYPE=6 %FINISH MARK=MARK+1+A(MARK+1) %REPEAT %IF SIMPLE=0 %THEN D0=5<<27!N %ELSE D0=X'E0'<<24!(2*N) D1=CA PGLA(4,8,ADDR(D0)); ! DESCPTR TO SW IN PLT RELOCATE(GLACA-4,D1,1) SNDISP=GLACA>>2-2; KFORM=N J=1; K=SWNAME ACC=4; PTYPE=(SIMPLE+1)<<4!6; ! LABEL ARRAY ! TEST NST STORE TAG(K, CA>>2) MARK=P+3 %CYCLE I=1,1,N %IF SIMPLE=0 %THEN PCONST(0) %ELSE ENTERJUMP(15,A(MARK+4),0) MARK=MARK+1+A(MARK+1) %REPEAT %END %ROUTINE DECLARE PROC !*********************************************************************** !* P TO TYPE OF PROCEDURE-1 * !* SIDE CHAIN SET UP IN OPHEAD CONSISTS OF:- * !* PTYPE, NAME AND DISPLACEMENT FOR EACH FORMAL PARAMETER * !* FOR RTPARAMS THE TOP HALF OF NAME IS THE PARAMLIST * !* THE TOP CELL HAS:- * !* RTADDR , NO OF PARAMS AND INFO * !* INFO 2**0 BIT SET IF PARAMS ARE SIMPLE * !* 2**1 BIT SET IF THUNKS ARE REQUIRED * !*********************************************************************** %ROUTINESPEC CFP %ROUTINESPEC CFPARAMS(%INTEGERNAME OPHEAD,OPBOT,%INTEGERNAME NP) %ROUTINESPEC CVALLIST(%INTEGERNAME OPHEAD,%INTEGER MODE) %ROUTINESPEC CCOMMENT %ROUTINESPEC CTYPELIST(%INTEGERNAME OPHEAD,%INTEGER MODE) %ROUTINESPEC CHECK FPS(%INTEGERNAME OPHEAD,%INTEGER MODE) %INTEGER PNAME, TYPEP, INC, I, N, CELL, NP, LINK, EXTRN, OPBOT, %C OPHEAD, RTHEAD, EPNAME, SLINE SLINE=LINE OPHEAD=0; NP=0; OPBOT=0 TYPEP=4096+A(P)&3 P=P+1 PNAME=A(P+3) P=P+4; INC=1; ! TO ALT OF FPP CFPARAMS(OPHEAD,OPBOT,NP) P=P+8; ! PAST 7 HOLES TO VALUE LIST CVALLIST(OPHEAD,0) CTYPELIST(OPHEAD,0) P=P+1 %UNTIL A(P)=2 P=P+1 %WHILE A(P)=1 %CYCLE; P=P+3; %REPEAT; ! SKIP OLABEL (IF ANY) EXTRN=A(P+1); ! EXTRN VALUES SIGNIFY: ! 1=%ALGOL ! 2=%EXTERNAL(IE IMP) ! 3=%FORTRAN ! 4=%BEGIN ! 5=SIMPLE STATEMENT LINE=SLINE; ! FOR FAULTING FORMAL PMS CHECK FPS(OPHEAD,0) J=15; I=0 %IF EXTRN<=3 %THEN %START J=14; EPNAME=PNAME %IF A(P+2)=1 %THEN EPNAME=A(P+3) CXREF(STRING(DICTBASE+WRD(EPNAME)),PARMDYNAMIC,2,I) %FINISH %ELSE %START %IF LEVEL=1 %THEN CODE DES(I) %FINISH PUSH(OPHEAD, I, NP, 0) K=PNAME; SNDISP=LINE; ACC=INC KFORM=0 PTYPE=TYPEP ! TEST NST STORE TAG(K, OPHEAD) %RETURN %ROUTINE CFPARAMS(%INTEGERNAME OPHEAD,OPBOT,%INTEGERNAME NP) !*********************************************************************** !* PUT THE NAMES BETWEEN BRACKETS INTO A LIST CHECKING THEY * !* ARE NOT ALREADY THERE * !*********************************************************************** %WHILE A(P)=1 %CYCLE P=P+INC; NP=NP+1 K=A(P); ! NAME %IF OPHEAD#0 %AND FIND(K, OPHEAD)>=0 %THEN FAULT(7, K) %C %ELSE BINSERT(OPHEAD,OPBOT, 256, K, 0) ! TYPE=?NAME P=P+1; INC=2; ! P TO REST OF FPP %REPEAT %END %ROUTINE CVALLIST(%INTEGERNAME OPHEAD,%INTEGER MODE) !*********************************************************************** !* COMPILING THE VALUE LIST CONSISTS OF CHECKING EACH NAME HAS * !* APPEARED IN FPLIST AND RESETING NAME FIELD IN THE TYPE WORD * !* MODE=0 FOR COMPILING PROC STMNT,#0 FOR FUNNY COMMENT * !*********************************************************************** %IF A(P)=1 %THEN %START; ! IF THERE IS A VALUE LIST P=P+1 %UNTIL A(P)=2 %OR MODE#0;! PAST COMMENTS P=P+1; LINE=A(P) N=A(P+1); P=P+2 %CYCLE I=1, 1, N; ! DOWN THE NAMELIST K=A(P) CELL=FIND(K, OPHEAD) %IF CELL>0 %THEN ASLIST(CELL)_S1=0 %ELSE FAULT(8, K) P=P+1 %REPEAT %FINISH %ELSE P=P+1 %END %ROUTINE CTYPELIST(%INTEGERNAME OPHEAD,%INTEGER MODE) !*********************************************************************** !* COMPILING THE TYPE DECLARATIONS IS SIMILAR TO THE VALUE LIST * !* MODE IS ZERO WHEN COMPILING A PROC #0 FOR FUNNY COMMENT * !*********************************************************************** %INTEGER CELL,PIN,ACCP %RECORD(LISTF)%NAME LC PIN=P %WHILE A(P)=1 %CYCLE; ! WHILE (MORE) DECLARATIONS P=P+1 %UNTIL A(P)=2 %OR MODE#0 P=P+1; LINE=A(P) P=P+1; CFP P=P+1 %UNTIL A(P-1)=2 %CYCLE; ! UNTIL NO MORE OF DECLIST K=A(P)&X'FFFF' CELL=FIND(K, OPHEAD) LC==ASLIST(CELL) %UNLESS CELL<0 %IF CELL<0 %OR LC_S1&X'F0FF'#0 %C %THEN FAULT(9, K) %ELSE %START I=LC_S1 LC_S1=PTYPE!I %IF PTYPE>=4096 %AND MODE=0 %START CCOMMENT LC_S2=RTHEAD<<16!LC_S2 %FINISH %IF PTYPE<6 %AND I#0 %THEN ACCP=8 %ELSE ACCP=ACC LC_S3=ACCP %FINISH P=P+2 %REPEAT %IF PTYPE>=4096 %AND MODE=0 %START;! SKIP OVER FUNNY COMMENT %IF A(P)=2 %THEN P=P+1 %ELSE P=P+1+A(P+1) %FINISH %REPEAT %END %ROUTINE CHECK FPS(%INTEGERNAME OPHEAD, %INTEGER MODE) !*********************************************************************** !* PASS DOWN THE LIST AGAIN CHECKING EVERYTHING HAS BEEN GIVEN * !* A VALID TYPE AND ALSO ASSIGNING PARAMETER DISPLACEMENTS * !*********************************************************************** %RECORD(LISTF)%NAME LC INC=20 LINK=OPHEAD %WHILE LINK>0 %CYCLE LC==ASLIST(LINK) PTYPE=LC_S1 J=LC_S2 I=LC_S3 UNPACK %IF TYPE=6 %AND NAM=0 %THEN %START LC_S1=PTYPE+256 NAM=1 WARN(3,J) %FINISH ! ! FAULT ANY VALUE PARAMETERS FOR FORTRAN ! %IF NAM=0=MODE %AND EXTRN=3 %THEN FAULT (10,J) %IF MODE=0 %AND 2<=EXTRN<=3 %AND ROUT=0 %AND 1<=TYPE<=3 %C %AND NAM#0 %THEN NAM=EXTRN %AND %C LC_S1=PTYPE+256*(EXTRN-1) FAULT(10, J) %C %IF PTYPE=0 %OR PTYPE=256 %OR (ROUT=1 %AND NAM=0) %OR %C (MODE=0 %AND EXTRN=3 %AND (TYPE=6 %OR %C (TYPE=5 %AND EBCDIC=0))) J=0 J=1 %IF NAM=1 %AND (ARR=0 %OR TYPE=6)%AND ROUT=0 %AND TYPE#5 LC_S3=INC!J<<16 INC=INC+I LINK=LC_LINK %REPEAT %END %ROUTINE CCOMMENT !*********************************************************************** !* DEAL WITH FUNNY COMMENT SPECIFYING PARAMS FOR RT TYPES * !*********************************************************************** %INTEGER NNP,PP,LINEP,PTYPEP,ACCP,RTBOT NNP=0; PP=P PTYPEP=PTYPE; ACCP=ACC LINEP=LINE; RTHEAD=0; RTBOT=0 P=P+2 %WHILE A(P+1)=1; ! FIND END OF DECLIST P=P+2 %IF A(P)=1 %THEN %START; ! THERE IS A COMMENT INC=2 CFPARAMS(RTHEAD,RTBOT,NNP) P=P+1 CVALLIST(RTHEAD,1) CTYPELIST(RTHEAD,1) LINE=LINEP CHECKFPS(RTHEAD,1) %FINISH PUSH(RTHEAD,0,NNP,0) P=PP; PTYPE=PTYPEP; ACC=ACCP %END %ROUTINE CFP !*********************************************************************** !* SETS PTYPE AND ACC FOR EACH ALT OF FORMAL PARAMETER * !*********************************************************************** %SWITCH ALT(1:7) ->ALT(A(P)) ALT(1): ! %LABEL PTYPE=6; ->SAC ALT(2): ! %SWITCH PTYPE=22; ->SAC ALT(3): ! %STRING PTYPE=5; ->SAC ALT(4): !(TYPE')(VDECLN) TYPE=A(P+1); P=P+2 ->ALT(A(P)+4) ALT(5): ! '%ARRAY' (ADECLN) ARR=1; ROUT=0; NAM=0 P=P+1; ACC=16 TYPE=2 %IF TYPE=4 PACK(PTYPE); %RETURN ALT(6): ! (TYPE')(PROCEDURE) ROUT=1; NAM=0; ARR=0; ACC=16 TYPE=TYPE&3; P=P+1 PACK(PTYPE); %RETURN ALT(7): ! (TYPE) PTYPE=TYPE ACC=BYTES(PTYPE) P=P+1; %RETURN SAC: ACC=8 P=P+1 %END %END %ROUTINE DECLARE SCALARS !*********************************************************************** !* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION * !* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,TYPE & ACC.IT WORKS * !* OUT ROUNDING FACTORS FOR ITSELF. * !* P POINTS TO THE DECLIST ON ENTRY AND IS UPDATED. * !*********************************************************************** %INTEGER INC TYPE=A(P) ROUT=0; NAM=0; ARR=0 P=P+4 PACK(PTYPE); J=0 INC=4; ACC=BYTES(TYPE) %IF ROUT=0 %AND ARR=0 %THEN INC=BYTES(TYPE) %IF N&7=0 %AND (INC=8 %OR INC=16) %THEN ODD ALIGN %UNTIL A(P-1)=2 %CYCLE; ! DOWN THE NAMELIST K=A(P) ! TEST NST SNDISP=0; KFORM=0 STORE TAG(K, N) N=N+INC P=P+2 %REPEAT %END %ROUTINE DECLARE ARRAYS !*********************************************************************** !* P IS AT P IN * !* * !* P= * !* P = ,'('':'*')' * !* * !* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR * !* DOPE-VECTOR IN THE CONSTANT AREA AND MAY HAVE THEIR SPACE * !* ALLOCATED AT COMPILE TIME AMONG THE SCALARS * !* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET * !* THEIR SPACE OFF THE STACK AT RUN TIME * !* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS * !* SYSTEM STANDARDS * !*********************************************************************** %ROUTINESPEC CLAIM AS %INTEGER DVDISP, PP, DVF, ELSIZE, TOTSIZE, R, LBND, PTYPEPP, %C PTYPEP, ARRP, NN, ND, II, JJ, QQ, CDV, D0, D1, DESC, APARM SET LINE %IF PARMLINE#0 SAVE AUX STACK(1) TYPE=A(P) TYPE=2 %IF TYPE=4 NAM=0; ROUT=0; ADFLAG=1 P=P+5 ARRP=1; ARR=ARRP; PACK(PTYPEP) ELSIZE=BYTES(TYPE) DESC=SIZECODE(TYPE)<<27 START: NN=1; APARM=A(P); ! FIND NO OF NAMES IN NAMELIST PP=P; CDV=0; PTYPEPP=PTYPEP %WHILE A(P+1)=1 %CYCLE; P=P+2; APARM=APARM!A(P); NN=NN+1; %REPEAT APARM=1-APARM>>16; ! 0 IS PASSED ,1 NOT PASSED P=P+2; ! TO ALT OF P %IF A(P)=1 %THEN ->CONSTDV; ! P = ! ! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME ! ND=0; JJ=P; DVF=0; TOTSIZE=X'FFFF' %UNTIL A(P)=2 %CYCLE; ! TILL NO MORE BPAIRS P=P+1; ND=ND+1; ! COUNT NO OF DIMENSIONS SKIP EXP(0); SKIP EXP(0) %REPEAT P=JJ; DVDISP=N; ! DVDISP IS D-V POSITION N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V FAULT(37, 0) %IF ND>12; ! TOO MANY DIMENSIONS ! D0=5<<27!3*ND; D1=12; ! DESCPTR FOR DV STORE CONST(JJ,8,D0,D1) PF1(LD,0,PC,JJ) PSF1(STD,1,DVDISP) GRUSE(DR)=0 ! PLANT(X'6201'); ! LSS 1=M1 THE FIRST MULTIPLIER GRUSE(ACCR)=5; GRINF(ACCR)=1 %CYCLE II=ND,-1,1 P=P+1 QQ=DVDISP+12*II; ! TRIPLE FOR IITH DIMENSION PSF1(ST,1,QQ+4); ! STORE MULTIPLIER %IF ND<=2 %AND PARMARR=0 %AND A(P)=2 %AND A(P+2)=3 %C %AND A(P+3)=2 %AND A(P+4)=1 %AND A(P+6)=2 %AND %C 0<=A(P+5)<=APARM %AND II=ND %START PLANT(X'6200'); ! LSS 0 GRUSE(ACCR)=0 P=P+7; PTYPEPP=PTYPEPP+16 %FINISH %ELSE CSEXP(ACCR,1,0);! LOWER BOUND PSF1(ST,1,QQ); ! STORED IN DV CSEXP(ACCR,1,0); ! UPPER BOUND PSF1(ISB,1,QQ) PF3(JAF,6,0,3); ! JUMP UNLESS NEGATIVE PLANT(X'627F'); ! LSS -1 SET UP -1 (ENSURES 0 ELEMENTS PLANT(X'E001'); ! IAD 1 CONVERT TO RANGE PSF1(IMY,1,QQ+4); ! RANGE*MULTIPLIER PSF1(ST,1,QQ+8); ! AND STORED IN DV GRUSE(ACCR)=0 %REPEAT PSF1(IMY,0,ELSIZE) PSF1(ST,1,DVDISP+8) P=P+1 -> DECL CONSTDV: ! CONSTANT BOUNDS DVF=1; P=P+1; CDV=1 DVDISP=DOPE VECTOR(ELSIZE, APARM, TOTSIZE, LBND); ! AND GENERATE A D-V ND=J %IF LBND=0 %AND ND<=2 %THEN PTYPEPP=PTYPEPP+16 ! DECL: ! MAKE DECLN - BOTH WAYS %IF N&7=0 %THEN ODD ALIGN PTYPE=PTYPEPP J=ND %CYCLE JJJ=0, 1, NN-1; ! DOWN NAMELIST %IF DVF#0 %THEN %START; ! ARRAY IS STRING OF LOCALS R=TOTSIZE//ELSIZE D0=DESC!R STORE CONST(D1,4,D0,0) PF1(LDTB,0,PC,D1) %FINISH %ELSE %START STORE CONST(D1,4,DESC,0) PF1(LDTB,0,PC,D1) PSF1(LDB,1,DVDISP+20) %FINISH PSF1(STD,1,N); ! ARRAY DESC TO HEAD GRUSE(DR)=0 PSF1(LSS,2,AUXSBASE(LEVEL)&X'3FFFF') PSF1(ST,1,N+4) %IF DVF#0 %THEN QQ=PC %ELSE QQ=LNB PSORLF1(LDRL,0,QQ,DVDISP) PSF1(STD,1,N+8) SNDISP=0 GRUSE(DR)=0; GRUSE(ACCR)=0 ! ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD KFORM=0 K=A(2*JJJ+PP)&X'FFFF' ! TEST NST STORE TAG(K, N) N=N+16 CLAIM AS %REPEAT P=P+1; ! PAST REST OF ARRAYLIST %IF A(P-1)=1 %THEN P=P+2 %AND ->START ADFLAG=0 %RETURN %ROUTINE CLAIM AS !*********************************************************************** !* CLAIM THE SPACE FOR AN ARRAY FROM STACK OR AUX STACK * !*********************************************************************** %INTEGER D %IF CDV=1 %THEN %START TOTSIZE=(TOTSIZE+3)&(-4) %IF TOTSIZE * !* DOPE VECTOR CONSISTS OF :- * !* DESRIPTOR (SCALED WORD) POINTING AT FIRST TRIPLE BND=3*ND * !* SIZE (IN BYTES OF ENTIRE ARRAY) FOR STACK ADJUSTMENT * !* AND ND TRIPLES EACH CONSISTING OF:- * !* LBI - THE LOWER BOUND OF THE ITH DIMENSION * !* MI - THE STRIDE FOR THE ITH DIMENSION * !* CBI THE UPPER CHECK =(UBI-LBI+1)*MI * !* WHERE M1=1(SCALED ARRAYS) OR THE ELEMENT SIZE AND * !* MI = M(I-1)*RANGE(I-1) * !*********************************************************************** %INTEGER I, JJ, K, ND, D, PP, M0, HEAD %RECORD(LISTF)%NAME LCELL %INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS ND=0; PP=P ND=ND+1 %AND P=P+7 %UNTIL A(P)=2 P=PP M0=1 %CYCLE D=ND,-1,1 CBPAIR(I, JJ) K=3*D %IF PARMARR=0 %AND D=ND<=2 %AND 1<=I<=APARM %THEN I=0 DV(K)=I DV(K+1)=M0 M0=M0*(JJ-I+1) DV(K+2)=M0 %REPEAT P=P+1 ! ASIZE=M0*ELSIZE DV(2)=ASIZE DV(1)=12 DV(0)=5<<27!3*ND; ! DESPTR FOR DV LB=DV(3*ND) J=ND; ! DIMENSIONALITY FOR DECLN K=3*ND+2 HEAD=DVHEADS(ND) %WHILE HEAD#0 %CYCLE LCELL==ASLIST(HEAD) %IF LCELL_S2=ASIZE %AND LCELL_S3=DV(5) %START %CYCLE D=0,1,K ->ON %UNLESS DV(D)=CTABLE(D+LCELL_S1) %REPEAT %RESULT=X'80000000'!4*LCELL_S1 %FINISH ON: HEAD=LCELL_LINK %REPEAT %IF CONST PTR&1#0 %THEN CONST HOLE=CONST PTR %AND %C CONST PTR=CONST PTR+1 I=4*CONST PTR!X'80000000' PUSH(DVHEADS(ND),CONSTPTR,ASIZE,DV(5)) %CYCLE D=0,1,K CTABLE(CONST PTR)=DV(D) CONST PTR=CONST PTR+1 %REPEAT %IF CONST PTR>CONST LIMIT %THEN FAULT(107,0) %RESULT =I %END !%ROUTINE TEST NST !!*********************************************************************** !!* SEE IF NAME 'K' HAS BEEN DECLARED BEFORE AT THIS LEVEL * !!*********************************************************************** !%INTEGER Q ! FNAME=K ! Q=TAGS(FNAME) ! FAULT(7, FNAME) %IF ASLIST(Q)_S1>>8&15=LEVEL !%END %ROUTINE RT JUMP(%INTEGER CODE,%INTEGERNAME LINK) !*********************************************************************** !* PLANTS A 'BAL' TO THE APPROPIATE ENTRY ADDRESS IN LINK * !* IF ROUTINE HAS BEEN SPECIFIED BUT NOT DESCRIBED THE JUMP CAN * !* NOT BE PLANTED AND IS LINKED INTO A LIST HEADED BY LINK * !* TO AWAIT FILLING (BY ' RHEAD ') WHEN THE BODY IS GIVEN. * !* THE FORMAT OF AN ENTRY IS :- * !* S2(32 BITS) = ADDRESS OF JUMP TO BE FILLED * !* THE CODING ASSUMES I,J&OLDI ARE SET UP FOR THE CALLED ROUTINE * !*********************************************************************** %INTEGER DP %IF J=15 %THEN %START; ! RT BODY NOT GIVEN YET PUSH(LINK, CODE<<24!3<<23, CA, 0) PCONST(X'01800000'!CODE<<24) %FINISH %ELSE %START; ! BODY GIVEN AND ADDRESS KNOWN DP=LINK-CA DP=DP//2+1 %IF CODE=CALL PSF1(CODE,0,DP) %FINISH %END %ROUTINE DIAG POINTER (%INTEGER LEVEL) !*********************************************************************** !* INSERT A POINTER TO THE DIAG TABLE INTO THE DESCRIPTOR IN * !* IN DR AND STORE THE DESCRIPTOR IN ITS PROPER PLACE * !*********************************************************************** %IF PARMTRCE#0 %THEN %START PUSH(RAL(LEVEL),1,CA,LDB<<24!3<<23) PCONST(X'77800000'); ! LDB 0 LONG FORM FILLED LATER GRUSE(DR)=0 %FINISH PLANT(X'5883'); ! STD (LNB+3) %END %ROUTINE CEND(%INTEGER KKK) !*********************************************************************** !* DEAL WITH ALL OCCURENCES OF '%END' * !* KKK=PTYPE(>=4096) FOR ROUTINES,FNS AND MAPS * !* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS * !* KKK=-1 FOR BLOCKS AFTER %DO OR %ELSE * !* KKK=-2 FOR BLOCKS AFTER %THEN (IE %ELSE IS VALID) * !* KKK=-3 FOR THE HYPOTHETICAL BLOCK TO STOP JUMPS INTO %FOR * !* %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS * !* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND * !* ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO * !* THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE * !*********************************************************************** %INTEGER KP, WK, JJ, KK, BIT %ROUTINESPEC DTABLE(%INTEGER LEVEL) NMAX=N %IF N>NMAX; ! WORK SPACE POINTER ! ! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING ! AS NOT SET AND COMMENTING ON LABELS NOT USED ! %WHILE LABEL(LEVEL)#0 %CYCLE POP(LABEL(LEVEL), I, J, KP) %IF J&X'FFFF'#0 %THEN %START J=J&X'FFFF' CLEAR LIST(J) %FINISH %REPEAT ! %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK,BIT) RETURN WSP(JJ,KK) %REPEAT %CYCLE J=1, 1, 4 %IF AVL WSP(J,LEVEL)#0 %THEN %C CLEAR LIST(AVL WSP(J, LEVEL)) ! RELEASE TEMPORARY LOCATIONS %REPEAT ! ! ! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED ! DESTROY SIDE CHAINS FOR ROUTINES ! NB PROCEDURES WITH PROCEDURE PARAMS HAVE SECONDARY SIDECHAINS ! ! AT THE SAME TIME CONSTRUCTTHE DIAGNOSTIC TABLES DTABLE(LEVEL); ! OUTPUT DIAGNOSTIC TABLES ! ! CLAIM THE STACK FRAME BY FILLING THE ASF IN THE BLOCK ENTRY CODING. ! NMAX=(NMAX+7)&(-8) %IF KKK=2 %THEN %RETURN JJ=SET(RLEVEL) %IF KKK>=4096 %OR KKK=1 %THEN %START WK=JJ>>18; JJ=JJ&X'3FFFF' KP=(ASF+12*PARMCHK)<<24!3<<23!(NMAX-WK+3)>>2 PLUG(1,JJ,KP) %FINISH ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! %IF KKK>=4096 %THEN %START; ! PROCEDURE END JJ=KKK&7 %IF JJ#0 %THEN %START %IF JJ=2 %THEN KP=2 %ELSE KP=1 %IF GRUSE(ACCR)#10 %OR WRD(GRINF(ACCR))#M(LEVEL) %START GET IN ACC(ACCR,KP,0,LNB,SET(RLEVEL)>>18);! LOAD RESULT %IF PARMCHK#0 %THEN TYPE=JJ %AND TEST ASS(ACCR) %FINISH %FINISH RESET AUX STACK PLANT(X'3840'); ! EXIT -64 %FINISH %IF KKK<=0 %THEN %START; ! BEGIN BLOCK EXIT JJ=AUXSBASE(LEVEL-1) %IF JJ#AUXSBASE(LEVEL) %THEN RESET AUX STACK %IF PARMTRCE=1 %AND KKK#-3 %START;! RESTORE DIAGS POINTERS PLANT(X'7883'); ! LD LNB+12 DIAG POINTER(LEVEL-1) %FINISH %FINISH %IF KKK>=0 %THEN %START %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE JJ=0,1,7 GRUSE(JJ)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH %FINISH ! ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE ! ! %UNLESS LEVEL>2 %OR (LEVEL=2 %AND CPRMODE=2) %THEN %START %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %C %ELSE FAULT(14, 0) %AND %STOP %FINISH LEVEL=LEVEL-1 %IF KKK>=4096 %THEN RLEVEL=RLEVEL-1 ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! POP(LEVELINF, JJ, N,BIT) NMAX=N>>16 %IF KKK>=4096 N=N&X'7FFF' %IF KKK=2 %THEN PPJ(15,16) %AND CEND(KKK) ! ROUND AGAIN FOR 'ENDOFPROGRAM' ! ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN ! %TRUSTEDPROGRAM IS IN OPERATION. ! %IF KKK>=4096 %AND (RLEVEL#0 %OR CPRMODE#2) %C %THEN ENTER LAB(JROUND(LEVEL+1), 0,LEVEL) %RETURN ! ! LAYOUT OF DIAGNOSIC TABLES ! ****** ** ********* ****** ! ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED. ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY ! FIRST WORD IN THE SST). ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT ! ! FORM OF THE TABLES:- ! ! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB) ! WORD 1 = (12 LANG DEPENDENT BITS)<<20 ! ENVIRONMENT ! (BIT X'20000000 SET IF EBCDIC MODE) ! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO ! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE ! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED ! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC ! ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY ! A WORD OF X'FFFFFFFF' ! ! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT ! BIT 2**19 =0 UNDER LNB =1 IN GLA ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES ! ! ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS. ! %ROUTINE DTABLE(%INTEGER LEVEL) !*********************************************************************** !* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & * !* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.* !*********************************************************************** %STRING (31) RT NAME %STRING (8) LOCAL NAME %INTEGER DPTR, LNUM, ML, KK, JJ, Q, S1, S2, S3, S4 %RECORD(LISTF)%NAME LCELL %INTEGERARRAY DD(0:1000); ! BUFFER FOR SEGMENT OF SST ! ! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK ! %WHILE RAL(LEVEL)#0 %CYCLE POP(RAL(LEVEL),Q,JJ,KK) %IF KKK=-3 %THEN PUSH(RAL(LEVEL-1),Q,JJ,KK) %ELSE %C PLUG(Q,JJ,KK!SSTL) %REPEAT %RETURN %IF KKK=-3; ! NO DECS IN FOR BLOCKS PUSH(RAL(LEVEL-1),4,SSTL+4,EBCDIC<<29) %IF PARMTRCE#0 DD(0)=L(LEVEL)<<16!(DIAGINF(LEVEL)+4) DD(1)=EBCDIC<<29 DD(2)=DISPLAY(RLEVEL)<<16!FLAG(LEVEL) ML=M(LEVEL); ! ROUTINE NAME(=0 FOR %BEGIN) LNUM=BYTEINTEGER(DICTBASE+ML); ! LENGTH OF THE NAME DPTR=4 %IF LNUM=0 %THEN DD(3)=0 %ELSE %START Q=DICTBASE+ML RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST LNUM=BYTE INTEGER(ADDR(RT NAME)) DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS %FINISH ! ! FOR TYPED PROCEDURES ADD THE RESULT VARIABLE TO THE DIAG TABLES ! %IF KKK>4096 %AND PARMDIAG#0 %START TYPE=KKK&7 DD(DPTR)=SIZECODE(TYPE)<<24!TYPE<<20!%C SET(RLEVEL)>>18 LOCAL NAME<-RT NAME LNUM=BYTEINTEGER(ADDR(LOCAL NAME)) STRING(ADDR(DD(DPTR))+4)=LOCAL NAME DPTR=DPTR+(LNUM+8)>>2 %FINISH JJ=NAMES(LEVEL) %WHILE 0<=JJ>16 %IF PTYPE=6 %AND S2&X'FFFF'#0 %THEN FAULT(12,JJ) %IF PTYPE&X'F000'#0 %THEN %START K=S3>>16 POP(K,KK,KK,KK) %WHILE K>0 %CYCLE KK=ASLIST(K)_S2>>16; ! SECONDARY CHAIN IF PROCEDURE %IF ASLIST(K)_S1>=4096 %THEN CLEAR LIST(KK) POP(K,KK,KK,KK) %REPEAT %FINISH %IF PARMDIAG#0 %AND DPTR<997 %AND 1<=PTYPE&X'F00F'<=5 %START %IF PTYPE=5 %THEN NAM=1 %ELSE NAM=PTYPE>>8&3 TYPE=PTYPE&7; ARR=PTYPE>>4&3 Q=DICTBASE+WRD(JJ); ! ADDRESS OF NAME %IF S1>>4&15=0 %THEN I=1 %ELSE I=0 DD(DPTR)=NAM<<30!ARR<<28!SIZECODE(TYPE)<<24! %C TYPE<<20!I<<18!S3>>16 LOCAL NAME<-STRING(Q);! TEXT OF NAME FROM DICTIONARY LNUM=BYTE INTEGER(ADDR(LOCAL NAME)) STRING(ADDR(DD(DPTR))+4)=LOCAL NAME; ! MOVE IN NAME DPTR=DPTR+(LNUM+8)>>2 %FINISH JJ=S4>>18 %REPEAT DD(DPTR)=-1; ! 'END OF SEGMENT' MARK DPTR=DPTR<<2+4 %IF PARMTRCE=1 %AND KKK#-3 %THEN %START LPUT(4, DPTR, SSTL, ADDR(DD(0)));! ADD TO SHARABLE SYM TABS SSTL=SSTL+DPTR %FINISH %END; ! OF ROUTINE DTABLE %END %ROUTINE SAVE AUX STACK(%INTEGER ARRS) !*********************************************************************** !* COPY THE AUX STACK DESCRIPTOR UNDER LNB AND SAVE THE STACK PTR* !* FOUR WORDS ARE NEEDED TO SAVE THE AUXILLARY STACK STATUS * !* 1&2 HOLD A COPY OF THE STACK DESCRIPTOR(FOR CONVENIENCE) * !* 3 HAS COPY OF STACKTOP ON ENTRY(FOR RESETTING ON EXIT) * !* 4 HAS COPY OF STACKTOP AFTER DECLARATIONS. NEEDED ONLY IF * !* THE INNER BLOCKS ARE JUMPED OUT OF INTO CURR BLK * !*********************************************************************** %IF AUXSBASE(LEVEL)=0 %START %IF N&7=0 %THEN ODD ALIGN AREA=-1; BASE=0 GET IN ACC(DR,2,2,AREA CODE,AUXST) PLANT(X'63DC'); ! LSS @DR GRUSE(ACCR)=0 PSF1(STD,1,N) PSF1(ST,1,N+8) %IF ARRS=0 %THEN %C PSF1(ST,1,N+12); ! IF NO ARRAYS LAST 2 WORDS ! ARE IDENTICAL AUXSBASE(LEVEL)=RLEVEL<<18!N N=N+16 %FINISH %END %ROUTINE RESET AUX STACK !*********************************************************************** !* IF ANY ARRAYS HAVE BEEN PUT ON THE AUXSTACK THEN UNDECLARE * !*********************************************************************** %IF AUXSBASE(LEVEL)>>18=RLEVEL %START PSF1(LB,1,AUXSBASE(LEVEL)&X'3FFFF'+8) PSF1(STB,2,AUXSBASE(LEVEL)&X'3FFFF') GRUSE(BREG)=0 %FINISH %END %ROUTINE RHEAD(%INTEGER KK) !*********************************************************************** !* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY * !* KK IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) * !* THE FIRST (PERM) BEGIN WHICH HAS TO BE TREATED AS A ROUTINE * !*********************************************************************** %INTEGER W1, W3, INSRN, AT PUSH(LEVELINF, 0, NMAX<<16!N, 0) LEVEL=LEVEL+1 NMDECS(LEVEL)=0 AUXSBASE(LEVEL)=0; NAMES(LEVEL)=-1 DIAGINF(LEVEL)=DIAGINF(LEVEL-1) %IF KK>=0 %THEN %START RLEVEL=RLEVEL+1 %FINISH FAULT(34, 0) %IF LEVEL=MAX LEVELS FAULT(108, 0) %IF LEVEL>MAX LEVELS %IF KK>=0 %AND LEVEL>2 %START; ! ROUTINE ENTRY COPY TAG(KK); JJ=K; ! LIST OF JUMPS %IF J=15 %THEN %START; ! CHECK BODY NOT GIVEN J=ASLIST(JJ)_S1 %IF J=0 %AND LEVEL>2 %START;! REPLACE 'NOT USED' BIT W1=TAGS(KK) ASLIST(W1)_S1=( ASLIST(W1)_S1&X'FFFF3FFF') %FINISH ! ! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE ! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP' ! SOME CHECKS ARE MADE IN THE CASE THE LIST IS SCREWED UP BY IDIOT ! GIVING THE PROCEDURE BODY TWICE ! %WHILE 0>25=CALL>>1 INSRN=INSRN+W3 PLUG(1, AT, INSRN) %REPEAT ASLIST(JJ)_S1=( CA); ! NOTE ADDR FOR FUTURE CALLS %FINISH %FINISH %IF KK<0 %THEN W3=0 %ELSE W3=WRD(KK) L(LEVEL)=LINE; M(LEVEL)=W3 FLAG(LEVEL)=PTYPE; ! CURRENT BLOCK TYPE MARKER %END; ! OF ROUTINE RHEAD %ROUTINE RDISPLAY(%INTEGER KK) !*********************************************************************** !* SET UP OR COPY THE DISPLAY (A WORD ARRAY CONTAINING COPIES OF * !* LNB FOR THE GLOBAL LEVELS. THE HIGHEST LEVEL ENTRY IS TO THE * !* GLA(PLT) FOR OWNS AND IS ALSO KEPT IN(LNB+4) IN CASE WE WISH * !* TO MOVE TO READ-ONLY PLTS. ON INTERNAL CALLS THE LNB FOR THE * !* NEXT MOST GLOBAL LEVEL IS STACKED AS AN EXTRA PARAMETER * !*********************************************************************** %INTEGER W1,W2,STACK,OP,INC %IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED STACK=0; DISPLAY(RLEVEL)=N %IF LEVEL#2 %THEN %START PF1(LXN,0,TOS,0) GRUSE(XNB)=4; GRINF(XNB)=RLEVEL-1 GRUSE(CTB)=0 PCONST(X'798C0003'); ! LD (XNB+3) COPY PLT DESRPTR DIAG POINTER(LEVEL) W1=RLEVEL-1; W2=DISPLAY(W1) %IF W1=1 %THEN PLANT(X'4D98') %AND N=N+4 %ELSE %START %WHILE W1>0 %CYCLE OP=LSS; INC=1 %IF W1>=2 %THEN OP=LSD %AND INC=2 %IF W1>=4 %THEN OP=LSQ %AND INC=4 PF1(OP+STACK,0,XNB,W2) STACK=-32; N=N+4*INC W2=W2+4*INC; W1=W1-INC %REPEAT %FINISH %FINISH %IF STACK#0 %THEN PLANT(X'4998'); ! ST TOS PLANT(X'5D98'); ! STLN TOS N=N+4 %FINISH ! ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO. ! %IF PARMTRCE#0 %START DIAGINF(LEVEL)=N PF1(LSS,0,PC,4*CONST BTM!X'80000000') %IF KK>=0 %OR LEVEL=2 %START PSF1(SLSS,0,LINE) PLANT(X'4998'); ! ST TOS %FINISH %ELSE %START PSF1(ST,1,DIAGINF(LEVEL)) PSF1(LSS,0,LINE) PSF1(ST,1,DIAGINF(LEVEL)+4) PLANT(X'7883'); ! LD LNB+12 DIAGPOINTER(LEVEL) %FINISH N=N+8 GRUSE(ACCR)=0; ! NEEDED FOR %BEGIN BLOCKS %FINISH ! ! IN SEPARATELY COMPILED PROCEDURES CHECK THE CORRECT AMOUNT OF PARAMS ! ARE PRESENT ON THE STACK. THIS IS THE BEST POSSIBLE AT THIS DATE ! %IF PARMOPT#0 %AND KK>=0 %AND LEVEL=2 %START PLANT(X'5F9C'); ! STSF BREG PLANT(X'5D98'); ! STLN TOS PLANT(X'2398'); ! SBB TOS PSF1(CPB,0,N) PPJ(7,10) %FINISH ! ! CLAIM (THE REST OF) THE STACK FRAME ! %IF KK>=0 %OR LEVEL=2 %START SET(RLEVEL)=N<<18!CA NMAX=N PCONST((ASF+12*PARMCHK)<<24!X'01800000');! ASF 0 OR LB 0 PPJ(0,3) %IF PARMCHK#0 %IF KK>=0 %AND PTYPE&7#0 %THEN N=N+8; ! FOR RESULT %FINISH ! %IF KK>=0 %AND PARMOPT#0 %THEN %START ! ! STSF TOS GET STACK POINTER ! LSS TOS ! USH +14 ! USH -15 LOSE SEGMENT NO ! ICP X'1F800' CHECK WITHIN SEG ADDRESS ! SHIFTED DOWN 1 PLACE ! JCC 2,EXCESS BLKS ! PCONST(X'5F986398'); ! STSF TOS LSS TOS PCONST(X'C80EC871'); ! USH 14 USH -15 PCONST(X'E7800000'!ST LIMIT>>1);! ICP ST LIMIT>>1 PPJ(2,8) %FINISH %END %ROUTINE CLABEL !*********************************************************************** !* P POINTS TO IN * !*********************************************************************** %INTEGER LNAME,T,USE LNAME=A(P) %IF LEVEL>1 %THEN %START; ! LABELS BEFORE 1ST BEGIN T=TAGS(LNAME); USE=ASLIST(T)_S1 %UNLESS USE>>16=6 %AND ASLIST(T)_S3=0 %THEN %C FAULT(2,LNAME) %ELSE ENTER LAB(LNAME,0,USE>>8&63);! USE>>8&63=OLDI %FINISH P=P+2 %END %ROUTINE COLABEL !*********************************************************************** !* P POINTS TO ALT OF P * !*********************************************************************** %WHILE A(P)=1 %CYCLE; P=P+1; CLABEL; %REPEAT P=P+1 %END %ROUTINE CBLK(%INTEGER BLKTYPE) !*********************************************************************** !* SUCK IN A BLOCK OCCURRING IN IF..THEN ETC * !*********************************************************************** %INTEGER I,OLDLEV,KK KK=0 %CYCLE I=P,1,P+5; KK=KK+A(I); %REPEAT %IF KK=0 %THEN BLKTYPE=-3 PTYPE=BLKTYPE OLDLEV=LEVEL; RHEAD(-1) %IF BLKTYPE=-3 %THEN %START AUXSBASE(LEVEL)=AUXSBASE(LEVEL-1) %FINISH %ELSE %START RDISPLAY(-1) MAKE DECS(P,-1) %FINISH %CYCLE; ! TILL CORRESPONDING END I=NEXTP; NEXTP=NEXTP+A(NEXTP) %IF ALLOW CODELIST=YES %AND DCOMP#0 %AND CA>CABUF %THEN %C CODEOUT %AND PRINT USE LINE=A(I+1) P=I+2 %WHILE A(P)=8 %CYCLE; P=P+1; CLABEL; %REPEAT %IF A(P)=2 %AND LEVEL=OLDLEV+1 %START SET LINE %IF PARMLINE#0 CEND(BLKTYPE); ! BLKTYPE=FLAG(LEVEL) %EXIT; ! NOW COMPLETED THE BLOCK %FINISH %ELSE CSS(P) %REPEAT P=P+1; ! TO ELSE AFTER %END %END %ROUTINE CCMPNDSTMNT !*********************************************************************** !* SUCK IN A COMPOUND STATEMENT (IE BLOCK WITH NO DECLNS) * !* P TO PHRASE IN THE SEQUENCE:- * !* '%BEGIN' * !*********************************************************************** %INTEGER I,OLDLEVEL OLDLEVEL=LEVEL %WHILE A(P)=1 %CYCLE; P=P+1; %REPEAT; ! PAST ANY COMMENTS P=P+1; COLABEL ! LINE=LINE+1 SET LINE %IF PARMLINE#0 CSTMNT %CYCLE I=NEXTP; NEXTP=NEXTP+A(NEXTP) %IF ALLOW CODELIST=YES %AND DCOMP#0 %AND CA>CABUF %THEN %C CODEOUT %AND PRINT USE LINE=A(I+1) P=I+2 %WHILE A(P)=8 %CYCLE; P=P+1; CLABEL; %REPEAT %IF LEVEL=OLDLEVEL %AND A(P)=2 %THEN %EXIT CSS(P) %REPEAT P=P+1; ! TO ELSE IF ANY %END %ROUTINE C FORSTMNT !*********************************************************************** !* COMPILE A FOR STATEMENT TREATING SIMPLE CASES WELL * !*********************************************************************** %ROUTINESPEC C FORLISTEL %ROUTINESPEC INTO FOR %ROUTINESPEC C FOR BODY %INTEGER FORNAME,FORLISTE,FORTYPE,FORPTYPE,FPL,FP,FCMPLX,FBP FBP=P+2+A(P+2) FORLISTE=A(FBP); ! =2 IF ONE ELEMENT LIST %IF FORLISTE=2 %THEN %START FBP=FBP+1 %WHILE A(FBP)=1 %CYCLE; FBP=FBP+3; %REPEAT FBP=FBP+1 %FINISH FORNAME=A(P+3) FP=P+3; P=FP+1 COPYTAG(FORNAME) FCMPLX=ROUT!NAM!ARR!PARMCHK!(TYPE//7);! CATCH NAME NOT SET FAULT(25,FORNAME) %UNLESS (1<=TYPE<=2 %OR TYPE=7) %AND %C ARR=ROUT=0 %AND A(P)=3 TYPE=1 %AND PTYPE=1 %UNLESS 1<=TYPE<=2 %OR TYPE=7;! BOOLEANS HERE CAUSE HAVOC FORTYPE=TYPE; FORPTYPE=PTYPE %IF A(P)#3 %THEN SKIP APP %AND P=P-1 PLABEL=PLABEL-1; FPL=PLABEL %UNTIL FORLISTE=2 %OR A(P)=2 %CYCLE;! UNTIL FORLIST EXHAUSTED P=P+1; C FORLISTEL %REPEAT %IF FORLISTE#2 %THEN P=P+1 %AND C FORBODY %RETURN %ROUTINE C FORLISTEL !*********************************************************************** !* COMPILE ONE ELEMENT OF A FOR LIST * !* P TO * !*********************************************************************** %INTEGER PP, FALT,QQ,FEXITPL,STEPP,STEPTMP,STEPRP,CONTROLRP,CNSTSTEP,%C STEPVAL,COPCODE,CXTRA,STEPHEAD,ASSHEAD,OPHEAD,NOPS,NSE,OPBOT,%C ASSBOT,STEPBOT,FETYPE,RR,FINACC,FINAREA,FINDISP,FINBASE,RRR,CPI %SWITCH FALTNO(1:3) OPHEAD=0; CNSTSTEP=0; STEPVAL=0 ASSHEAD=0; STEPHEAD=0; NSE=0; CPI=0 STEPBOT=0; OPBOT=0; ASSBOT=0 PLABEL=PLABEL-1; QQ=PLABEL PLABEL=PLABEL-1; FEXITPL=PLABEL RR=RPPTR CONTROLRP=FORTYPE<<16!FCMPLX<<8!2 NOPS=1; ETORP(OPHEAD,NOPS,FORTYPE) RRR=RPPTR-3 A(RRR)=99 A(RRR+1)=RPPTR; ! TIC TO NEXT =NO-OP A(RPPTR)=FORPTYPE<<16!2 A(RPPTR+1)=FP A(RPPTR+2)=TAGS(FORNAME) A(RPPTR+3)=31; ! 31=ASSIGN RPPTR=RPPTR+6 FALT=A(P); FETYPE=TYPE P=P+1 ->FALTNO(FALT) FALTNO(1): ! STEP -UNTIL ! ! FIRST CHECK FOR CONSTANT STEPS WHICH DO NOT NEED TO BE EVALUATED ! OR ASSIGNED TO TEMPORARIES ! %IF A(P)=2 %AND A(P+3)=2 %AND A(P+4)=1 %AND A(P+5)#0 %C %AND A(P+6)=2 %THEN %START CNSTSTEP=1; STEPVAL=A(P+5) %IF A(P+2)=2 %THEN STEPVAL=-STEPVAL P=P+7 STEPRP=1<<16!1 STEPTMP=STEPVAL %IF FCMPLX=0 %AND FORTYPE=FETYPE %THEN NSE=1 ! NO SIDE EFFECTS IN INCREMENTING %IF NSE=FORTYPE=1 %AND PARMOPT=0 %AND A(P)=2 %AND %C A(P+1+A(P+1))=2 %START %IF A(P+3)=2 %AND A(P+4)=1 %START FINDISP=A(P+5); FINACC=0; FINAREA=0; FINBASE=0 %IF A(P+2)=2 %THEN FINDISP=-FINDISP %IF IMOD(FINDISP)>>18=0 %THEN ->CPIB %FINISH ! %IF A(P+3)=1 %AND A(P+5)=3 %START; ! NAME --NO APP COPYTAG(A(P+4)) %IF PTYPE&X'FEFF'=1 %START;! OMIT NAM BIT FINACC=PTYPE>>7; ! 0 FOR LOCAL-2 FOR NAMETYPE FINAREA=-1; FINDISP=K FINBASE=I; ->CPIB %FINISH %FINISH %FINISH %FINISH %ELSE %START GET WSP(STEPTMP,FORTYPE); ! TEMPORARY FOR STEP STEPRP=FORTYPE<<16!LNB<<12!7;! REVERSE POLISH DESCRPTR %FINISH ! ! EVALUATE STEP AND ASSIGN TO TEMPORARY ! STEPP=P %IF CNSTSTEP=0 %THEN %START NOPS=NOPS+1; ETORP(STEPHEAD,NOPS,FORTYPE) A(RPPTR-3)=STEPRP A(RPPTR-2)=STEPTMP A(RPPTR)=31 RPPTR=RPPTR+3 %FINISH %IF NSE#0 %START A(RRR+6)=30; ! REPLACE 31(:=) BY 30(::=) A(RRR)=12; ! MOVE LABEL TO ST INSTN A(RRR+1)=QQ!1<<16; ! AND FORCE A LOAD %FINISH %ELSE %START A(RPPTR)=12 A(RPPTR+1)=QQ RPPTR=RPPTR+3 %FINISH ! ! EVALUATE (V-C)*SIGN(D) ! COPCODE=27; CXTRA=5; ! '<=' %IF STEPVAL<0 %THEN CXTRA=2; ! '>=' %IF NSE=0 %START A(RPPTR)=CONTROLRP A(RPPTR+1)=FP RPPTR=RPPTR+3 %FINISH ! NOPS=NOPS+3 ETORP(ASSHEAD,NOPS,FORTYPE) RPPTR=RPPTR-3 %IF CNSTSTEP=0 %THEN COPCODE=16 A(RPPTR)=COPCODE A(RPPTR+1)=CXTRA RPPTR=RPPTR+3 ! %IF CNSTSTEP=0 %THEN %START A(RPPTR)=STEPRP A(RPPTR+1)=STEPTMP RPPTR=RPPTR+3 A(RPPTR)=14; ! SIGN A(RPPTR+3)=19; ! MULTIPLY RPPTR=RPPTR+6 %FINISH A(RPPTR)=100; ! TERMINATE RPPTR=RPPTR+3 PP=P; EXPOP(RR,ACCR,NOPS,FORTYPE) P=PP; RPPTR=RR %IF COPCODE=16 %START %IF CNSTSTEP#0 %AND STEPVAL<0 %THEN MASK=18 %ELSE MASK=17 %IF FORTYPE=1 %THEN MASK=MASK+4 %FINISH ENTER JUMP(MASK,FEXITPL,B'10') COMM: INTO FOR %IF CPI#0 %START P=FP; CSEXP(BREG,1,2); ! EXPRESSION OF SINGLE NAME %FINISH %ELSE %START ! ! INCREMENT CONTROL BY STEP ! P=STEPP; NOPS=1 %IF CNSTSTEP=0 %THEN %START ETORP(OPHEAD,NOPS,FORTYPE); RPPTR=RPPTR-3; ! EVALUATE STEP %FINISH A(RPPTR)=STEPRP A(RPPTR+1)=STEPTMP RPPTR=RPPTR+3 ! %IF CNSTSTEP=0 %START A(RPPTR)=30; ! ASSIGN VARIABLE STEP TO TEMP RPPTR=RPPTR+3 %FINISH A(RPPTR)=CONTROLRP A(RPPTR+1)=FP RPPTR=RPPTR+3 A(RPPTR)=15; ! ADD STEP TO CONTROL RPPTR=RPPTR+3 ! %IF NSE=0 %START A(RPPTR)=FORPTYPE<<16!2 A(RPPTR+1)=FP A(RPPTR+2)=TAGS(FORNAME) A(RPPTR+3)=31; ! ASSIGN INCREMENT CONTROL RPPTR=RPPTR+6 %FINISH ! A(RPPTR)=100 RPPTR=RPPTR+3 EXPOP(RR,ACCR,NOPS,FORTYPE) %FINISH RPPTR=RR ENTER JUMP(15,QQ,0) ENTER LAB(FEXITPL,B'111',LEVEL) P=PP; %RETURN CPIB: ! CAN USE CPIB OR EQIVALENT PP=P+7; CPI=1 A(RRR)=STEPRP; A(RRR+1)=STEPTMP A(RRR+3)=16; ! SUBTRACT A(RRR+6)=100 EXPOP(RR,BREG,NOPS,FORTYPE); ! (INIT-STEP) TO BREG ! ACCESS=FINACC; AREA=FINAREA BASE=FINBASE ENTER LAB(QQ,0,LEVEL) %IF STEPVAL=1 %START PSORLF1(CPIB,ACCESS,AREA CODE,FINDISP) %IF STEPVAL>=0 %THEN MASK=10 %ELSE MASK=12 %FINISH %ELSE %START PSF1(ADB,0,STEPVAL) PSORLF1(CPB,ACCESS,AREA CODE,FINDISP) %IF STEPVAL>=0 %THEN MASK=2 %ELSE MASK=4 %FINISH ! ! BEWARE OF ESCAPE DESCRIPTORS SINCE THESE ARE ALLOWED FOR FINAL VALUE ! DELETE THE NEXT STATEMENT WHEN 'STXN' ARRIVES AND ESCAPES ARE TRANSPARENT ! %IF FINACC#0 %THEN GRUSE(XNB)=0; ! MAY HAVE BEEN CORRUPTED GRUSE(BREG)=0 COPY TAG(FORNAME) ACCESS=0; AREA=-1; BASE=I PSORLF1(STB,ACCESS,AREA CODE,K) NOTE ASSMENT(BREG,FORNAME) ENTER JUMP(MASK,FEXITPL,B'10') P=PP; ->COMM FALTNO(2): ! WHILE ENTER LAB(QQ,0,LEVEL) A(RPPTR)=100 RPPTR=RPPTR+3 PP=P; EXPOP(RR,-1,NOPS,FORTYPE!16) RPPTR=RR P=PP; CCOND ENTER JUMP(MASK,FEXITPL,B'11') INTO FOR ENTER JUMP(15,QQ,0); ! UNCONDITIONALLY TO WHILE ENTER LAB(FEXITPL,B'111',LEVEL); ! TO EXIT WHEN BE FALSE %RETURN FALTNO(3): ! NULL PP=P A(RPPTR)=100 RPPTR=RPPTR+3 EXPOP(RR,-1,NOPS,FORTYPE!16) P=PP; RPPTR=RR INTO FOR %END %ROUTINE INTOFOR %INTEGER I %IF FORLISTE#2 %THEN %START ENTERJUMP(0,FPL,0) %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE I=0,1,7 GRUSE(I)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH %FINISH %ELSE %START P=P+1 C FOR BODY %FINISH %END %ROUTINE C FORBODY !*********************************************************************** !* A FOR BODY IS NORMALLY ENTERED BY A JLK * !*********************************************************************** %INTEGER FBALT,I,PL,RAD %IF FORLISTE#2 %THEN %START PLABEL=PLABEL-1; PL=PLABEL ENTER JUMP(15,PL,B'10') ENTER LAB(FPL,0,LEVEL) RAD=N; N=RAD+4 PLANT(X'6398'); ! LSS TOS GET RETURN ADDRESS PSF1(ST,1,RAD); ! AND SAVE IN STACK FRAME %FINISH PTYPE=-3; I=P RHEAD(-1) AUXSBASE(LEVEL)=AUXSBASE(LEVEL-1) COLABEL FBALT=A(P); P=P+1 %IF FBALT=1 %THEN %START; ! %BEGIN CBLK(-2) %IF A(P)=1 %THEN FAULT(47,0) %FINISH %ELSE %START CSTMNT %FINISH CEND(FLAG(LEVEL)) %IF FORLISTE#2 %THEN %START PSF1(JUNC,1,RAD) ENTER LAB(PL,B'111',LEVEL) %FINISH %END %END %ROUTINE CSTMNT !*********************************************************************** !* COMPILE AN ALGOL STATEMENT WHICH CAN BE A DUMMY * !*********************************************************************** %SWITCH ALT,UALT(1:4) %INTEGER SALT,PL1,PL2,CORB,PP,LNAM,CURRLINE CURRLINE=LINE PP=P ->ALT(A(P)) ALT(1): ! UI P=P+1; CUI %RETURN ALT(2): ! FOR STMNT C FOR STMNT %RETURN ALT(3): ! %IF %THEN ... P=P+1; CCOND PLABEL=PLABEL-1; PL1=PLABEL ! ! A SIMPLE PIECE OF OPTIMISATION IS TO AVOID JUMPING ROUND A ONE- ! INSTRUCTION JUMP WHICH OCCURS WHEN THE STATEMENT TURNS OUT TO BE A ! UNLABELLED 'GOTO' TO A LABEL IN THE CURRENT BLOCK ! %IF A(P)=2 %AND A(P+1)=3 %AND A(P+2)=3 %AND A(P+3)=2 %AND %C A(P+4)=1 %AND A(P+6)=3 %START LNAM=A(P+5); COPY TAG(LNAM) %IF PTYPE=6 %AND OLDI=LEVEL %THEN %START ENTER JUMP(REVERSE(MASK),LNAM,0) P=P+7 %IF A(P)#1 %THEN %RETURN PL2=PL1; ->UON %FINISH %FINISH ! ! END OF A SIMPLE PIECE OF OPTIMISATION WHICH WILL NOT CATCH JUMPS OUT ! OF FOR LOOPS BUT SHOULD CATCH ALL OTHHER 1 INSTRUCTION GOTOS ! ENTER JUMP(MASK,PL1,B'10'); ! MERGE NOT SHORT COLABEL; SALT=A(P); P=P+1 ->UALT(SALT) UALT(1): ! BEGIN CORB=A(P); P=P+1 %IF CORB=1 %THEN CCMPNDSTMNT %ELSE CBLK(-2) ->UBACK UALT(2): ! FOR STMNT P=P-1 C FOR STMNT; ->UBACK UALT(3): ! UI CUI; ->UBACK UALT(4): ! NULL UBACK: %IF A(P)#1 %THEN %C ENTER LAB(PL1,B'11',LEVEL) %AND %RETURN; ! MERGE %IF SALT=2 %THEN FAULT(47,0); ! %ELSE AFTER %FOR PLABEL=PLABEL-1; PL2=PLABEL ENTER JUMP(15,PL2,B'10') ENTER LAB(PL1,B'111',LEVEL); ! REPLACE UON: LINE=A(P+1); P=P+2; COLABEL SALT=A(P); P=P+1 SET LINE %IF PARM LINE#0 %AND LINE#CURR LINE %IF SALT#1 %THEN CSTMNT %ELSE %START CORB=A(P); P=P+1 %IF CORB=1 %THEN CCMPNDSTMNT %ELSE CBLK(-1) %FINISH ENTER LAB(PL2,B'11',LEVEL); ! MERGE %RETURN ALT(4): ! DUMMY STATEMENT WARN(4,0) %END %ROUTINE CUI !*********************************************************************** !* COMPILE AN UNCONDITIONAL STATEMENT * !*********************************************************************** %SWITCH ALT(1:3) %INTEGER OPHEAD,NOPS,BOT,TYPEP,LPALT,LPNAM,STOREOP,JJ,KK,LP,RR %RECORD(LISTF)%NAME LCELL ->ALT(A(P)) ALT(1): ! ASSIGNMENT RR=RPPTR; NOPS=0 LPNAM=A(P+1) TCELL=TAGS(LPNAM) LCELL==ASLIST(TCELL) TYPEP=LCELL_S1>>16&7 STOREOP=31; ! ALLOW MVC ON SINGLE LPLS LPALT=A(P+2) %IF (LPALT=1 %AND TYPEP#3) %OR (LPALT=2 %AND TYPEP>=3) %START %IF LPALT=1 %THEN FAULT(24,A(P+1)) %ELSE FAULT(42,A(P+1)) TYPEP=4-LPALT %FINISH ! ! SHIFT THE ENTRY FOR P UP ONE PLACE TO OVERWRITE THE ALT OF P ! SO THAT IT IS NEXT TO P FOR CNAME ETC AND THE FIRST DESTINATION ! IN LEFT PART LIST CAN THEN BE TREATED AS ANY SUBSEQUENT ENTRY ! A(P+2)=A(P+1); P=P+2 ->ON AGN: LPNAM=A(P) TCELL=TAGS(LPNAM) LCELL==ASLIST(TCELL) ON: BOT=RPPTR PTYPE=LCELL_S1>>16 FAULT(29,LPNAM) %UNLESS PTYPE&7=TYPEP %IF PTYPE&X'F0'#0 %THEN %START CNAME(1,ACCR) %IF A(P)=1 %THEN %START; ! MORE LPL FOLLOWS JJ=TAGS(A(P+1)) %IF ASLIST(JJ)_S1&X'F0000F'=X'200001' %START A(RPPTR)=X'51'<<16!BREG<<12!9 REGISTER(BREG)=1 OLINK(BREG)=ADDR(A(RPPTR)) %FINISH %ELSE %START PLANT(X'5B98'); ! STB TOS STACK SUBSCRIPT A(RPPTR)=X'51'<<16!TOS<<12!8 %FINISH A(RPPTR+1)=0 %FINISH %ELSE %START GET WSP(KK,1); ! LOCAL TEMPORARY A(RPPTR)=X'51'<<16!BREG<<12!9 A(RPPTR+1)=KK REGISTER(BREG)=2 OLINK(BREG)=ADDR(A(RPPTR)) %FINISH A(RPPTR+3)=32 A(RPPTR+4)=LPNAM RPPTR=RPPTR+6 %FINISH %ELSE %START JJ=PTYPE<<16!2; KK=P %IF PTYPE&X'F000'#0 %START I=LCELL_S1>>4&15 %CYCLE LP=LEVEL,-1,1 %IF WRD(LPNAM)=M(LP) %START JJ=(PTYPE&7)<<16!(I+1)<<8!6 KK=SET(I+1)>>18; %EXIT %FINISH %REPEAT %IF LP<=1 %OR A(P+1)#3 %THEN FAULT(29,LPNAM) %FINISH A(RPPTR)=JJ A(RPPTR+1)=KK A(RPPTR+2)=TCELL A(RPPTR+3)=STOREOP A(RPPTR+4)=A(P) RPPTR=RPPTR+6 P=P+1; %IF A(P)=3 %THEN P=P+1 %ELSE SKIP APP %FINISH %IF STOREOP=30 %THEN JJ=99 %ELSE JJ=100 A(RPPTR)=JJ A(RPPTR+1)=BOT-9 RPPTR=RPPTR+3 STOREOP=30; NOPS=NOPS+1 %IF A(P)=1 %THEN P=P+1 %AND ->AGN P=P+1 ETORP(OPHEAD,NOPS,TYPEP) A(RPPTR-3)=99 A(RPPTR-2)=BOT; ! TIC BACK TO LEFTPART LIST ! WHICH IS BACK LINKED ! SO THAT ASSIGNMENTS ARE MADE ! R TO L AS SUBCRIPTS UNSTACKED LP=P EXPOP(OPHEAD,-1,NOPS,TYPEP!16) P=LP RPPTR=RR %RETURN ALT(2): ! PROCEDURE CALL P=P+1 CNAME(0,0) %RETURN ALT(3): ! %GOTO P=P+1 CDE(0) %END %ROUTINE GOTOLAB(%INTEGER MODE) !*********************************************************************** !* GOTO A SIMPLE LAB OR ELEMENT OF SWITCH UNCONDITIONALLY * !* MODE =0 NORMAL GOTO STMNT * !* MODE=1 IF IN THUNKS (IE LABEL PASSED BY NAME) * !* MODE=2 IF IN SWITCH LIST (FAILURES HANDLED DIFFERENTLY) * !* MODE=3 SWITCH BEING PASSED BY NAME * !* MODE=5 AS MODE=1 BUT P HAS BEEN PARSED AS AN EXPRSN * !* THIS IS UNAVOIDABLE IN THE CASE OF ACTUAL PARAMETERS AS * !* BOTH LABELS AND PARAMETERLESS PROCEDURE CAN BE USED * !* WITHOUT BEING DECLARED! * !*********************************************************************** %ROUTINESPEC RESET STACK %INTEGER LNAM, SB, B, D, PP, F, SSN, RANGE, ARRP, LEVELP, XYNB LNAM=A(P); P=P+1; ! LNAM =LABEL(SWITCH)NAME PP=P COPYTAG(LNAM) RANGE=KFORM; ARRP=ARR; LEVELP=OLDI B=I; D=K SSN=SNDISP<<2 %IF A(P)=2 %THEN F=22 %AND ->ERROR %IF ARRP>=1 %AND MODE#3 %AND A(P)=3 %THEN F=18 %AND ->ERROR %IF TYPE#6 %OR ROUT=1 %THEN F=11 %AND ->ERROR SB=STACKBASE(B) ->SWITCH %IF ARRP>=1; ! SWITCHES ABORT %IF SB<0 %AND B#RLEVEL %AND NAM=0 ! %IF A(P)=1 %THEN F=4 %AND ->ERROR P=P+1 %IF NAM=1 %THEN %START; ! LABEL BY NAME CALL THUNKS(0, -1, B, D) %RETURN %FINISH ! RESET STACK ! ENTER JUMP(15, LNAM, 0) %RETURN ERROR: FAULT(F,LNAM) P=PP; SKIP APP; %RETURN ! SWITCH: ! GOTO SWITCH P=P+1 P=P+1 %UNLESS MODE=3; ! PAST (HOLE) IN P(APP) %IF NAM=1 %THEN %START CSEXP(ACCR, 1, 0) %UNLESS MODE=3 CALL THUNKS(0, -1, B, D); ! CAN NOT RETURN %FINISH %ELSE %START %IF MODE#3 %THEN CSEXP(BREG, 1, 0) %ELSE PLANT(X'499C');! ST BREG REGISTER(BREG)=1 XYNB=SET XORYNB(-1,-1) PLANT(X'2201'); ! SBB 1 ALGOL SWITCHES START AT 1 %IF ARRP=2 %START RESET STACK ! ! FOLLOWING 3 LINES AVOID H-W BUG ON 50&60 RE JUMP TO CODE DECSCRPTR ! WHEN FIXED DELETE 3 LINES AND UNCOMMENT NEXT 2 LINES ! ->NOT 2960 PLANT(X'2A04'); ! MYB 4 PF1(ADB,0,XYNB,SSN+4); ! RELOCATE FROM CODE DEC PLANT(X'1B9C'); ! J BREG NOT 2960: ! END OF REPABLE ALT PLANT(X'2A02'); ! MYB 2 PF1(JUNC,3,XYNB,SSN); ! USE BOUNDED CODE DESCRIPOR %FINISH %ELSE %START PF1(LB,3,XYNB,SSN); ! LB REL DISP OF SW ELMNT PF1(ADB,0,XYNB,SSN+4); ! RELOCATE ! ! MUST SET LNB TO EXPECTED VALUE BEFORE BRANCHING INTO THE SWITCH ! CODE. ! %IF B#RLEVEL %THEN PSF1(LLN,1,PTR OFFSET(B)) PLANT(X'1B9C'); ! JUNC BREG %FINISH REGISTER(BREG)=0; GRUSE(BREG)=0 %FINISH %IF MODE#3 %THEN %START %IF A(P)=1 %THEN F=18 %AND ->ERROR P=P+1 %FINISH %RETURN %ROUTINE RESET STACK %INTEGER I ! ! IF JUMPING OUT OF A BLOCK IT MAY BE NECESSARY TO RESET BLOCK NO ! AND/OR THE TOP OF STACK POINTER ! %IF PARMTRCE=0 %OR B#RLEVEL %OR LEVELP=LEVEL %THEN ->NEXT ! ! IT IS STILL NOT NECESSARY TO RESET DIAG POINTER IF THE ONLY BLOCKS ! BEING LEFT ARE THE HYPOTHETICAL BLOCKS SURROUNDING FOR STMNTS ! %CYCLE I=LEVEL,-1,LEVELP+1 ->RESET %IF FLAG(I)#-3; ! ANYTHING BUT FOR LOOP %REPEAT ->NEXT RESET: PLANT(X'7883'); ! LD LNB+12 - PLT DECRIPTOR GRUSE(DR)=0 DIAG POINTER(LEVELP) ! NEXT: DISP=AUXSBASE(LEVELP) ! ! CASE DISP=0 OCCURSS WHEN THERE IS NO AUXSTACK REQD AT ALL ! ! SIMILARLY THE CASE OF SB<=0 IF NO BLOCKS TO BE EXITED FROM ! %IF DISP#0 %AND (DISP#AUXSBASE(LEVEL) %OR MODE#0) %START AREA=-1; BASE=DISP>>18 DISP=DISP&X'3FFFF' GET IN ACC(ACCR,1,0,AREA CODE,DISP+12) PSORLF1(ST,2,AREA,DISP) %FINISH ! %IF SB>0 %AND (B#RLEVEL %OR MODE#0) %START;! AUTO STACK NEEDS RESETTING PSF1(LLN,1,PTR OFFSET(B)) %UNLESS B=RLEVEL PSF1(LSS,1,SB) PPJ(0,4) %FINISH %END %END %ROUTINE CSDE(%INTEGER MODE) !*********************************************************************** !* COMPILE A SIMPLE DESIGNATIONAL EXPRESSION * !* P:=,'('')' * !* MODE AS FOR ROUTINE GOTOLAB * !*********************************************************************** %INTEGER PP,PLUSALT,OPALT PP=P; P=P+1 %IF MODE#5 %THEN %START %IF A(PP)=2 %THEN CDE(MODE) %ELSE GOTOLAB(MODE) %FINISH %ELSE %START PLUSALT=A(P); OPALT=A(P+1) ->ERROR %UNLESS PLUSALT=3 %AND OPALT#2;! NOT INTEGER CONSTANT P=P+2; ! POINTS TO OPERAND %IF OPALT=3 %THEN CDE(5) %ELSE GOTOLAB(5) ->ERROR %UNLESS A(P)=2; ! NO REST OF EXPRN P=P+1 %FINISH %RETURN ERROR: FAULT(5,0) P=PP; SKIP EXP(0) %END %ROUTINE CDE(%INTEGER MODE) !*********************************************************************** !* COMPILE A DESIGNATIONAL EXPRSSION * !* P:-%IF%THEN%ELSE, * !* MODE AS FOR ROUTINE GOTOLAB * !*********************************************************************** %INTEGER R, PL1, PL2 %IF A(P)=2 %THEN P=P+1 %AND CSDE(MODE) %AND %RETURN P=P+1; CCOND PLABEL=PLABEL-1; PL1=PLABEL ENTER JUMP(MASK, PL1, B'11'); ! ROUND FIRST SDE ON FALSE R=0; CSDE(MODE) PLABEL=PLABEL-1; PL2=PLABEL %IF R#0 %THEN ENTER JUMP(15, PL2, B'11') ENTER LAB(PL1, B'110',LEVEL); ! UNCONDITIONAL AND REPLACE CDE(MODE) ENTER LAB(PL2, B'11',LEVEL); ! CONDITIONAL AND MERGE %END %ROUTINE CCOND !*********************************************************************** !* COMPILES A CONDITION INDEXED BY P AND LEAVES MASK SET UP * !* READY FOR A BRANCH IF FALSE OPERATION * !*********************************************************************** %INTEGER PP, EXPHEAD, NOPS, RR RR=RPPTR; NOPS=0 ETORP(EXPHEAD,NOPS,4) PP=P EXPOP(EXPHEAD,ACCR,NOPS,3) P=PP %IF NEST>=0 %THEN MASK=20 RPPTR=RR %END %ROUTINE CSEXP(%INTEGER REG, MODE, NME) !*********************************************************************** !* COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE' * !* MODE=1 FOR %INTEGER, =2 REAL, =3 BOOL * !* NME=2 IF EXPRESSION IS A SINGLE NAME, #2 FOR GENUINE EXPRSN * !*********************************************************************** %INTEGER EXPHEAD, NOPS, PP, RR, ENAME, T RR=RPPTR %IF NME=2 %THEN %START; ! EXPRSN (PARAM)IS NAME APP ENAME=A(P) T=TAGS(ENAME) PTYPE=ASLIST(T)_S1>>16 %IF PTYPE&7=MODE %THEN CNAME(2,REG) %AND %RETURN %IF PTYPE=SNPT %THEN REDUCE TAG %ELSE TYPE=PTYPE&7 %IF MODE=3 %AND TYPE#3 %THEN FAULT(24, ENAME) %IF MODE<3 %AND TYPE=3 %THEN FAULT(42, ENAME) EXPHEAD=RPPTR A(RPPTR)=PTYPE<<16!2 A(RPPTR+1)=P A(RPPTR+3)=100 RPPTR=RPPTR+6 NOPS=1 %FINISH %ELSE %START NOPS=0 ETORP(EXPHEAD, NOPS, MODE) %FINISH PP=P EXPOP(EXPHEAD, REG, NOPS, MODE) P=PP RPPTR=RR %END %ROUTINE ETORP(%INTEGERNAME HEAD, NOPS, %INTEGER MODE) !*********************************************************************** !* CONVERT EXPRESSION TO REVERSE POLISH * !*********************************************************************** %INTEGER TYPEP, TMODE, BHEAD, EHEAD1, EHEAD2, RR ! ABORT %UNLESS 1<=A(P)<=2 %IF A(P)=2 %THEN %START P=P+1 TORP(HEAD,NOPS,MODE) %FINISH %ELSE %START P=P+1 RR=RPPTR; HEAD=RR; RPPTR=RPPTR+3 %IF MODE>=3 %THEN TMODE=3 %ELSE TMODE=0 ETORP(BHEAD,NOPS,4) TORP(EHEAD1,NOPS,TMODE) TYPEP=PTYPE; EHEAD2=0 ETORP(EHEAD2,NOPS,TMODE) PTYPE=2 %UNLESS TYPEP=1 %IF TMODE=3 %THEN PTYPE=3 A(RR)=99 A(RR+1)=RPPTR A(RPPTR)=PTYPE<<16!4 A(RPPTR+1)=(BHEAD-RPBASE)<<16!(EHEAD1-RPBASE) A(RPPTR+2)=EHEAD2 A(RPPTR+3)=100 RPPTR=RPPTR+6 NOPS=NOPS!X'80000000' ;! SOMETHING NASTY BIT SET %FINISH %END %ROUTINE TORP(%INTEGERNAME HEAD, NOPS, %INTEGER MODE) !*********************************************************************** !* CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE * !* POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD' * !* WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS * !* IS ADDED TO NOPS. MODE SIGNIFIES :- * !* MODE=1 INTEGER EXPRESSION * !* MODE=2 REAL EXPRESSION * !* MODE=3 BOOLEAN EXPRESSION * !* MODE=4 A COMPARISION * !* MODE=0 INTEGER IF POSIIBLE OTHERWISE REAL * !* N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN * !*********************************************************************** %SWITCH OPERAND(1:12) %INTEGER RPHEAD, PASSHEAD, SAVEHEAD, RPBOT, PASSBOT, SAVEBOT, %C REAL, BOOL, OPSEEN, COMPLEX, OPERATOR, OPPREC, OPND, C, D, %C PP, RPTYPE, RPINF, XTRA, OPMASK, OPSTK, OPPSTK %CONSTINTEGERARRAY OPINF(1:13)=X'519'(2),X'30F', X'310',X'413',X'415',X'414', X'519',X'416',X'312',X'217',X'111'(2) ! OPINF IS THE PRECEDENCE<<8!EXPOP SWITCH VALUE OF ALT OF P OPSTK=0; OPPSTK=0; PASSHEAD=0; RPHEAD=0; OPSEEN=0 SAVEHEAD=0; REAL=0; OPMASK=0; BOOL=0 RPBOT=0; SAVEBOT=0; PASSBOT=0 PP=P; HEAD=RPPTR %IF MODE=3 %OR MODE=4 %THEN BOOL=8 NEXTB: P=P+1; ! PAST HOLE C=A(P) %IF 2=C %AND BOOL=0 %THEN %START;! INITIAL '-' OPMASK=1<<21 NOPS=NOPS+1; OPSEEN=1 OPSTK=11; OPPSTK=3 %FINISH %IF BOOL#0 %AND C=1 %START OPMASK=OPMASK!1<<22 NOPS=NOPS+1; OPSEEN=1 %WHILE 5<=OPPSTK&31 %CYCLE A(RPPTR)=OPSTK&31 RPPTR=RPPTR+3 OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5 %REPEAT OPSTK=OPSTK<<5!10; OPPSTK=OPPSTK<<5!5 %FINISH NEXTOPND: OPND=A(P+1); P=P+2 COMPLEX=0; XTRA=0 ->OPERAND(BOOL+OPND); ! SWITCH ON OPERAND OPERAND(1): ! NAME OPERAND(10): ! BOOLEAN NAME C=A(P) D=TAGS(C); PTYPE=ASLIST(D)_S1>>16 %IF PTYPE=X'FFFF' %THEN PTYPE=7; ! NAME NOT SET GIVES X'FFFF' %IF PTYPE=SNPT %THEN PTYPE=X'1000'+TSNAME(ASLIST(D)_S3>>16) TYPE=PTYPE&7 %IF PTYPE&X'FFF0'#0 %OR PARMCHK=1 %THEN COMPLEX=1 %IF PTYPE&X'F000'#0 %THEN OPMASK=OPMASK!X'80000000' ! SET SOMETHING NASTY BIT FOR RTS %IF ADFLAG#0 %START REDUCE TAG %IF OLDI=LEVEL %AND SNDISP#M'FP' %THEN FAULT(27,C) %FINISH %IF TYPE=2 %THEN REAL=1 RPTYPE=2; RPINF=P %IF BOOL=0 %THEN %START %IF PTYPE=7 %THEN PTYPE=1 %AND UNPACK %IF TYPE>=3 %THEN %START FAULT(42,C) RPTYPE=0; PTYPE=1 %FINISH %FINISH %ELSE %START %IF PTYPE=7 %THEN PTYPE=3 %AND UNPACK %IF TYPE#3 %THEN %START FAULT(24,C) RPTYPE=0; PTYPE=3 %FINISH %FINISH P=P+1 %IF A(P)=3 %THEN P=P+1 %ELSE SKIP APP; P=P+1 INS: A(RPPTR)=PTYPE<<16!COMPLEX<<8!RPTYPE A(RPPTR+1)=RPINF A(RPPTR+2)=XTRA RPPTR=RPPTR+3 ->OP OPERAND(2): ! CONSTANT C=A(P); RPTYPE=1 %IF C=2 %THEN %START; ! REAL CONSTANT PTYPE=2; RPINF=A(P+1) XTRA=A(P+2) P=P+4 REAL=1 %FINISH %ELSE %START D=A(P+1) %IF D>>17=0 %THEN RPTYPE=0 RPINF=D P=P+3; PTYPE=1 %FINISH; ->INS OPERAND(9): ! (EXPR)(COMP)(EXPR) ETORP(PASSHEAD,NOPS,0) RPPTR=RPPTR-3 C=A(P); P=P+1 %IF C>7 %THEN C=C-7; ! MAP ECMA FORM ONTO IMP FORM ETORP(SAVEHEAD,NOPS,0) ! ! OPTIMISE SIMPLE CONDITIONS HERE ! %IF MODE=4 %AND OPSEEN=0 %AND A(P)=2 %THEN D=27 %ELSE D=26 A(RPPTR-3)=D; A(RPPTR-2)=C; ! COMPARAISON & COMPARATOR P=P+1; ->OP OPERAND(11): ! BOOLEAN CONSTANT C=A(P); P=P+2; ! 0=FALSE -1=TRUE PTYPE=3; RPTYPE=0 RPINF=C-2; ->INS OPERAND(3): ! SUB EXPRESSION OPERAND(12): ! SUB EXPRESSION ETORP(PASSHEAD,NOPS,3*(BOOL>>3)) RPPTR=RPPTR-3 REAL=1 %IF TYPE=2 P=P+1 OP: ! DEAL WITH OPERATOR ->EOE %IF A(P-1)=2; ! EXPR FINISHED OPERATOR=A(P) ! OPPREC=OPINF(OPERATOR+BOOL) OPERATOR=OPPREC&63 %IF OPERATOR=21 %THEN REAL=1 OPPREC=OPPREC>>8 OPMASK=OPMASK!1<<(OPERATOR+5) NOPS=NOPS+1; OPSEEN=1 ! ! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS ! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1' ! AS PRECEDENCE. ! %WHILE OPPREC<=OPPSTK&31 %CYCLE A(RPPTR)=OPSTK&31 RPPTR=RPPTR+3 OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5 %REPEAT ! ! THE CURRENT OPERATOR CAN NOW BE STORED ! OPSTK=OPSTK<<5!OPERATOR; OPPSTK=OPPSTK<<5!OPPREC ->NEXTOPND %IF BOOL=0; ->NEXTB EOE: ! END OF EXPRESSION %WHILE OPSTK#0 %CYCLE A(RPPTR)=OPSTK&31 RPPTR=RPPTR+3 OPSTK=OPSTK>>5 %REPEAT A(RPPTR)=100 RPPTR=RPPTR+3 %IF BOOL#0 %THEN PTYPE=3 %ELSE PTYPE=1+REAL TYPE=PTYPE %IF REAL=1 %THEN OPMASK=OPMASK!1<<26;! REALS CANNOT BE EVALUATED IN B NOPS=NOPS!OPMASK %END %ROUTINE EXPOP(%INTEGER INHEAD, REG, NOPS, MODE) !*********************************************************************** !* EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE * !* THE RESULT IN REG * !* INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE * !* ENTRY AS FOLLOWS:- * !* 0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT * !* 1 = OTHER CONSTANT S2 (+S3 IF NEEDED) = CONSTANT * !* 2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS * !* (3 = DOPE VECTOR ITEM IF NEEDED) * !* (4 = CONDITONAL EXPRESSION AS IN ALGOL) * !* 7 = INTERMEDIATE RESULT UNDER LNB S2=DISPLCMNT FROM LNB * !* 8 = INTERMEDIATE RESULT STACKED * !* 9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG * !* * !* 10-19 = UNARY OPERATOR S2=OP S3 =EXTRA * !* 20 UP = BINARY OPERATOR * !* * !* ARRAY MCINST HOLD THE OPCODES CORRESPONDING TO THE OPERATORS:- * !* TOP BYTE = REAL FORWARD FORM * !* 2ND BYTE = REAL REVERSE FORM * !* 3RD BYTE = INTEGER FORWARD FORM * !* BTM BYTE = INTEGER REVERSE FORM * !*********************************************************************** %INTEGERARRAY OPERAND(1:2),STK(0:99) %RECORD(RD)%NAME OPND1, OPND2, OPND3 %RECORD(LISTF)%NAME LCELL %INTEGER C, D, KK, JJ, OPCODE, COMM, XTRA, STPTR, RDFORM, EVALREG, %C PP, PT, JJJ, LOADREG %ROUTINESPEC FLOAT(%RECORD(RD)%NAME OPND) %ROUTINESPEC TYPE CHK(%INTEGER MODE) %ROUTINESPEC FIX(%RECORD(RD)%NAME OPND,%INTEGER MODE) %ROUTINESPEC CTOP(%INTEGERNAME A) %ROUTINESPEC PUT %ROUTINESPEC STARSTAR %ROUTINESPEC REXP %ROUTINESPEC LOAD(%RECORD(RD)%NAME OPND,%INTEGER REG, MODE) %CONSTINTEGERARRAY MCINST(10:32)=X'8E8E',X'F4F4E4E4',0(3), X'F0F0E0E0',X'F2F4E2E4', X'8E8E',X'8C8C',X'FAFAEAEA', X'AAAC',X'BABC0000',X'8A8A', X'8C00',0,X'FA00EA00', X'F6F6E6E6'(2),X'2C002C00', X'02000200',X'48004800'(3); %CONSTBYTEINTEGERARRAY FCOMP(1:28)=%C 8,10,2,7,12,4,7, 8,12,4,7,10,2,7, 16,34,17,32,33,18,32, 16,33,18,32,34,17,32; %SWITCH SW(10:32) STPTR=0; RDFORM=MODE&16 EVALREG=ACCR %IF REG=BREG %AND NOPS&X'FEE00000'=0 %THEN %C EVALREG=BREG %IF REG=BREG#EVALREG %AND REGISTER(BREG)>0 %THEN BOOTOUT(BREG) NEXT: C=A(INHEAD) XTRA=A(INHEAD+1) %IF C=99 %THEN INHEAD=XTRA %AND ->NEXT; ! 99=TIC ->FINISH %IF C=100 JJ=C&255; D=INHEAD INHEAD=INHEAD+3 ->OPERATOR %IF 10<=JJ ! ! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION ! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST ! OPND1==RECORD(ADDR(A(D))) %IF (OPND1_FLAG=2 %AND OPND1_XB#0) %OR OPND1_FLAG=4 %START JJ=EVALREG %IF JJ=BREG %AND REGISTER(ACCR)=1 %THEN JJ=ACCR LOAD(OPND1,JJ,0) %FINISH STK(STPTR)=ADDR(OPND1) STPTR=STPTR+1 ! ABORT %IF STPTR>99 ->NEXT OPERATOR: STPTR=STPTR-1 %IF JJ>=15 %THEN OPERAND(2)=STK(STPTR) %AND STPTR=STPTR-1 OPERAND(1)=STK(STPTR) OPCODE=MCINST(JJ) COMM=1 OPND1==RECORD(OPERAND(1)) OPND2==OPND1 %IF JJ>14 %THEN %START; ! CHOOSE WHICH OPERAND FOR ACC OPND2==RECORD(OPERAND(2)) %IF OPCODE&X'00FF00FF'#0 %THEN %START C=OPCODE %IF OPND1_PTYPE&7=2 %OR OPND2_PTYPE&7=2 %THEN C=C>>16 %IF C>>8=0 %OR (C&255#0 %AND OPND2_FLAG=9) %START COMM=2; OPND3==OPND1 OPND1==OPND2; OPND2==OPND3 %FINISH %FINISH %FINISH %IF OPND1_FLAG<2>OPND2_FLAG %THEN CTOP(JJ) ->STRES %IF JJ=0; ! CTOP CARRIED OUT ! ! CARRY OUT A TYPE CHECK FOR OPERATORS 15(+),16(-),19(*),COMP(26,27) ! AND ASSIGNMENT (30&31) ! %IF OPND1_PTYPE&7#OPND2_PTYPE&7 %AND %C (1<>5) ->SW(JJ) SW(10): ! \ LOAD(OPND1,EVALREG,2) PLANT(X'8E7F'); ! NEQ -1 GRUSE(ACCR)=0 ! ABORT %UNLESS EVALREG=ACCR SUSE: OLINK(EVALREG)=OPERAND(COMM) STRES: STK(STPTR)=OPERAND(COMM); STPTR=STPTR+1 ->NEXT SW(11): ! NEGATE ! OPMASK STOPS US EVER GETTING HERE WITH EVALREG=BREG (PDS HOPES) LOAD(OPND1,EVALREG,2) %IF TYPE=2 %THEN OPCODE=OPCODE>>16 PSF1(OPCODE&255,0,0); ! IRSB 0 OR RRSB 0 GRUSE(ACCR)=0 ! ABORT %UNLESS EVALREG=ACCR ->SUSE SW(12): !ENTER LAB LOAD(OPND1,EVALREG,2) %IF XTRA>>16#0 ENTERLAB(XTRA&X'FFFF',0,LEVEL) ->SUSE SW(13): ! ENTIER %IF OPND1_PTYPE&7=1 %THEN FLOAT(OPND1) FIX(OPND1,XTRA); ->SUSE SW(14): ! SIGN LOAD(OPND1,EVALREG,2) %IF TYPE=2 %THEN C=63 %AND D=0 %ELSE C=31 %AND D=4 PF3(JAT,D,0,5); ! SIGN(0)=0 PSF1(USH,0,-C) PSF1(USH,0,1) PSF1(IRSB,0,1) GRUSE(ACCR)=0 %IF TYPE=2 %THEN %START %IF REGISTER(BREG)=0 %THEN PLANT(X'4B9C') %AND %C GRUSE(BREG)=0 %ELSE PLANT(X'3211') ! 4B9C== STUH BREG ! 3211== MPSR 17 %FINISH OPND1_PTYPE=1; OPND1_XB=ACCR<<4 OPND1_FLAG=9; OPND1_D=0 ! ABORT %UNLESS EVALREG=ACCR ->SUSE SW(15): ! ADD BINOP: LOAD(OPND1,EVALREG,2) %UNLESS %C OPND1_FLAG=9 %AND OPND1_XB>>4=EVALREG LOAD(OPND2,EVALREG,1) %IF OPND2_FLAG<=4 PUT; ->SUSE %UNLESS JJ=17 PLANT(X'8E7F'); ! NEQ -1 ->SUSE SW(16): ! SUBTRACT ->BINOP SW(17): ! EXCLUSIVE OR SW(18): ! OR SW(22): ! AND ->BINOP %IF OPND1_PTYPE&7=3=OPND2_PTYPE&7 FAULT(24,0) F25: JJ=15; OPCODE=MCINST(15); ->BINOP; ! CHANGE OPN TO + F26: FAULT(26,0); ->F25 SW(23): ! %IMPLIES LOAD(OPND1,EVALREG,2) PLANT(X'8E7F'); ! NEQ -1 SW(24): ! SLL SW(19): ! MULT ->BINOP SW(20): ! INTEGER DIVISION ->F26 %UNLESS OPND1_PTYPE&7=1=OPND2_PTYPE&7 ->BINOP SW(21): ! NORMAL DIVISION TYPE CHK(2); ->BINOP SW(25): ! EXP %IF OPND2_PTYPE&7=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(OPND1) %IF OPND2_PTYPE&7=1 %THEN STARSTAR %AND ->SUSE REXP; COMM=2; ->SUSE SW(26): ! COMPARISON TO BOOLEAN CONVERSION SW(27): ! COMPARISONS ->Z1 %IF OPND1_FLAG<=1 %AND OPND1_D=0 %AND JJ=27 ->Z2 %IF OPND2_FLAG<=1 %AND OPND2_D=0 %AND JJ=27 LOAD(OPND1,EVALREG,2) LOAD(OPND2,EVALREG,1) %IF JJ=26 %THEN %START PUT PLANT(X'6200'); ! LSS 0 GRUSE(ACCR)=0; LOADREG=ACCR %FINISH %ELSE %START PUT; LOADREG=-1 %FINISH MASK=REVERSE(FCOMP(XTRA+7*(COMM-1))) REGISTER(EVALREG)=0 %IF LOADREG=-1 %THEN NEST=-1 %AND %RETURN PF3(JCC,MASK,0,3) PLANT(X'627F'); ! LSS -1 OPND1_PTYPE=3; OPND1_XB=ACCR<<4 OPND1_FLAG=9; OPND1_D=0 TYPE=3 REGISTER(ACCR)=1 ->SUSE Z1: OPND3==OPND2; ->Z3 Z2: OPND3==OPND1 Z3: LOAD(OPND3,ACCR,2) MASK=REVERSE(FCOMP(XTRA+7*COMM+7)) %IF TYPE=1 %THEN MASK=MASK+4 NEST=-1; REGISTER(ACCR)=0 %RETURN SW(28): ! SPECIAL MH FOR ARRAY ACCESS C=OPND2_D>>16; ! CURRENT DIMENSION D=OPND2_D&31; ! TOTAL NO OF DIMENSIONS %IF OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR %THEN %START PLANT(X'4998'); ! ST TOS ! ACC CANNOT BE USED IN DVM CHANGE RD(ACCR) REGISTER(ACCR)=0 %FINISH ! %IF C=D %THEN %START; ! TOP DIMENSION LOAD DV DES BASE=OPND2_XTRA>>18; AREA=-1 GET IN ACC(DR,2,0,AREA CODE,OPND2_XTRA&X'1FFFF'+8) %FINISH ! LOAD(OPND1,EVALREG,0) AREA=OPND1_XB>>4; ACCESS=OPND1_XB&15 %IF C=D %AND REGISTER(BREG)>=1 %AND %C (OPND1_FLAG#9 %OR AREA#BREG) %THEN %START OPND3==RECORD(OLINK(BREG)) OPND3_D=0 REGISTER(BREG)=2 BOOT OUT(BREG) %FINISH ! ! TWO DIMENSIONAL UNCHECKED ARRAYS AVOID VMY ON FIRST DIMENSION WHERE ! THEMULTIPLIER IS 1. THE AVOIDS HAVING TO COPY BTO ACC ! %IF C=1 %AND D=2 %AND PARMARR=0 %START PLANT(X'23DC') %UNLESS XTRA=2;! SBB (%DR) DR POINTS AT LB OPCODE=ADB<<8 %FINISH ACCESS=OPND1_XB&15; AREA=OPND1_XB>>4 PSORLF1(OPCODE>>8&255,ACCESS,AREA,OPND1_D) GRUSE(BREG)=0 ! %IF D=1 %OR(D=2 %AND PARMARR=0) %THEN LOADREG=BREG %C %ELSE %START LOADREG=ACCR %IF C=D %THEN GET IN ACC(ACCR,1,0,7,0) %ELSE %C PLANT(X'E19C'); ! IAD BREG %IF C=1 %THEN %START PLANT(X'499C'); ! ST BREG REGISTER(ACCR)=0 LOADREG=BREG %FINISH %FINISH REGISTER(LOADREG)=1 OPND1_FLAG=9; OPND1_XB=LOADREG<<4 OLINK(LOADREG)=OPERAND(COMM) %IF C=1 %THEN ->STRES ->NEXT SW(29): ! ->LAB MASKS AND LAB AS OPND2 ABORT SW(30): ! ASSIGN(=) SW(31): ! ASSIGN(WITH MVC ALLOWED) PP=OPND2_D; ! SAVE POINTER TO NAME PT=OPND2_PTYPE; ! AND ITS ORIGINAL PTYPE D=OPND2_FLAG; ! SAVE NAME OR R-DESCRPTOR LOAD(OPND1,ACCR,2) %UNLESS OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR %IF D=2 %THEN %START; ! RHS= A NAME %IF OPND2_PTYPE<=3 %AND OPND2_UPTYPE=0 %START LCELL==ASLIST(OPND2_XTRA) D=LCELL_S3>>16 AREA=-1; C=0 BASE=LCELL_S1>>4&15 %IF BASE=RLEVEL %THEN JJJ=LNB %ELSE JJJ=AREA CODE %FINISH %ELSE %START P=PP; CNAME(1,0) D=DISP; C=ACCESS %IF AREA<0 %THEN AREA=AREA CODE;! ONLY NEEDED FOR BUM LHS JJJ=AREA %FINISH %FINISH %ELSE %START; ! LHS A FUNCTION DESIGNATOR %IF D=6 %START; ! SPECIAL FLAG FOR FN RESULTS C=0 BASE=OPND2_XB AREA=-1; JJJ=AREA CODE %FINISH %ELSE %START; ! ASSIGN TO TEMP (IN FORS) AREA=OPND2_XB>>4; JJJ=AREA ACCESS=OPND2_XB&15; C=ACCESS %FINISH D=PP %FINISH LOAD(OPND1,ACCR,2) %UNLESS OPND1_FLAG=9 PSORLF1(ST,C,JJJ,D) %IF OPND2_FLAG=2 %THEN NOTE ASSMENT(ACCR,A(PP)) %ELSE %C SET USE(ACCR,10,XTRA); ! NOTE FN RESULT %IF JJ=31 %THEN REGISTER(EVALREG)=0 COMM=1; ->SUSE SW(32): ! ARRAY ASSNMT XTRA=ARRNAME C=TAGS(XTRA) LCELL==ASLIST(C) D=LCELL_S1; ! XTRA=LPNAME JJJ=D>>4&15; D=D>>16&15; ! D=TYPE : JJJ=I C=LCELL_S3>>16; ! C=K %IF D=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(OPND1) %IF D=1 %AND OPND1_PTYPE&7=2 %THEN FIX(OPND1,0) LOAD(OPND1,ACCR,2) %UNLESS OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR;! RHS %IF GRUSE(DR)=7 %AND GRINF(DR)=XTRA %START %IF 7<=OPND2_FLAG<=8 %START ACCESS=1 %IF OPND2_FLAG=7 %THEN AREA=LNB %AND DISP=OPND2_D %C %ELSE AREA=TOS %AND DISP=0 %FINISH %ELSE %START LOAD(OPND2,BREG,2) %C %UNLESS OPND2_FLAG=9 %AND OPND2_XB>>4=BREG ACCESS=3; AREA=7; DISP=0 %FINISH PF1(ST,ACCESS,AREA,DISP) %FINISH %ELSE %START LOAD(OPND2,BREG,2) %C %UNLESS OPND2_FLAG=9 %AND OPND2_XB>>4=BREG;! SUBSCRIPT EXP TO B AREA=-1; BASE=JJJ %IF BASE=RLEVEL %THEN AREA=LNB %ELSE AREA=AREA CODE PF1(ST,3,AREA,C) %FINISH REGISTER(BREG)=0 GRUSE(DR)=7; GRINF(DR)=XTRA COMM=1; ->STRES FINISH: OPND1==RECORD(STK(STPTR-1)) %IF OPND1_PTYPE&7=1 %AND MODE=2 %THEN FLOAT(OPND1) %IF OPND1_PTYPE&7=2 %AND MODE=1 %THEN FIX(OPND1,0) LOAD(OPND1,REG,2) %UNLESS%C RDFORM#0 %OR (OPND1_FLAG=9 %AND OPND1_XB>>4=REG) PTYPE=OPND1_PTYPE TYPE=PTYPE&7 NEST=-1 %IF OPND1_FLAG=9 %THEN %START NEST=OPND1_XB>>4 REGISTER(NEST)=0 %FINISH %RETURN ! %ROUTINE LOAD(%RECORD(RD)%NAME OPND,%INTEGER REG, MODE) !*********************************************************************** !* LOAD OPERAND TO REGISTER CONDITIONALLY * !* MODE=0 LEAVE IN STORE IF POSSIBLE * !* MODE=1 LEAVE IN STORE IF SUITABLE FOR RX INSTRUCTIONS * !* MODE=2 LOAD TO REGISTER REGARDLESS * !*********************************************************************** %INTEGER J, K, C, D, HEAD1, HEAD2 %SWITCH SW(0:9) PTYPE=OPND_PTYPE; TYPE=PTYPE&7 K=OPND_FLAG ->SW(K) %IF MODE=2 %OR 2<=K<=4 %OR (K<2 %AND MODE=1) %RETURN SW(0):LITCONST: ! CONSTANT < 18 BITS AREA=0; ACCESS=0 DISP=OPND_D %IF MODE=2 %THEN %START; ! FETCH TO REG %IF GRUSE(REG)=5 %AND GRINF(REG)=DISP %AND TYPE=1 %START %IF REGISTER(REG)#0 %THEN BOOT OUT(REG) %FINISH %ELSE GETINACC(REG,BYTES(TYPE)>>2,ACCESS,AREA,DISP) %IF TYPE=1 %THEN GRUSE(REG)=5 %AND GRINF(REG)=DISP ->LDED %FINISH OPND_FLAG=7; OPND_XB=AREA<<4!ACCESS OPND_D=DISP %RETURN SW(1): ! LONG CONSTANT %IF OPND_D=0=OPND_XTRA %THEN ->LITCONST %IF TYPE=1 %AND IMOD(OPND_D)>>17=0 %THEN ->LITCONST STORE CONST(DISP,BYTES(TYPE),OPND_D,OPND_XTRA) %IF MODE#2 %START OPND_FLAG=7; AREA=PC; OPND_XB=AREA<<4 ACCESS=0; OPND_D=DISP; %RETURN %FINISH %IF GRUSE(REG)=6 %AND GRINF(REG)=DISP %START %IF REGISTER(REG)#0 %THEN BOOT OUT(REG) %FINISH %ELSE GETINACC(REG,BYTES(TYPE)>>2,0,PC,DISP) GRUSE(REG)=6; GRINF(REG)=DISP ->LDED SW(2): ! NAME P=OPND_D -> LOAD %IF MODE=2 %OR OPND_XB#0;! COMPLEX NAMES MUST BE LOADED CNAME(5,REG) ->LDED %IF NEST>=0 OPND_PTYPE=PTYPE OPND_FLAG=7 OPND_XB=AREA<<4!ACCESS OPND_D=DISP; %RETURN LOAD: CNAME(2,REG) LDED: REGISTER(REG)=1; ! CLAIM THE REGISTER OLINK(REG)=ADDR(OPND) OPND_FLAG=9; OPND_D=0; OPND_XB=REG<<4; %RETURN SW(4): ! CONDITIONAL EXPRSSN C=TYPE HEAD1=OPND_D>>16+RPBASE HEAD2=OPND_D&X'FFFF'+RPBASE SAVEIRS EXPOP(HEAD1,ACCR,2,3) %IF NEST>=0 %THEN MASK=20 PLABEL=PLABEL-1; J=PLABEL ENTER JUMP(MASK,J,B'11') EXPOP(HEAD2,REG,2,C) %IF REG>=0 %THEN D=REG %ELSE D=NEST PLABEL=PLABEL-1 ENTER JUMP(15,PLABEL,B'11') HEAD1=OPND_XTRA ENTER LAB(J,B'111',LEVEL) J=PLABEL EXPOP(HEAD1,D,2,C) ENTER LAB(J,B'11',LEVEL) GRUSE(D)=0; OLINK(REG)=ADDR(OPND) OPND_PTYPE=C; REGISTER(D)=1 OPND_FLAG=9; OPND_XB=REG<<4 OPND_D=0; %RETURN SW(6): ! SPECIAL FRIG FOR FN RESULTS ABORT; ! _XB = RLEVEL &_D =OFFSET SW(7): ! I-R IN A STACK FRAME AREA=OPND_XB>>4 ACCESS=OPND_XB&15 DISP=OPND_D PICKUP: GET IN ACC(REG,BYTES(TYPE)>>2,ACCESS,AREA,DISP) ->LDED SW(8): ! I-R THAT HAS BEEN STACKED AREA=TOS; ACCESS=0; DISP=0; ->PICK UP SW(9): ! I-R IN A REGISTER %IF OPND_XB>>4=REG %THEN ->LDED %IF REG#ACCR %THEN %START BOOTOUT(BREG) %IF REGISTER(BREG)#0 PLANT(X'499C'); ! ST BREG GRUSE(BREG)=GRUSE(ACCR) GRINF(BREG)=GRINF(ACCR) %FINISH %ELSE %START GET IN ACC(ACCR,1,0,7,0) GRUSE(ACCR)=GRUSE(BREG) GRINF(ACCR)=GRINF(BREG) %FINISH REGISTER(OPND_XB>>4)=0 OPND_XB=REG<<4 REGISTER(REG)=1 OLINK(REG)=ADDR(OPND) %END %ROUTINE PUT !*********************************************************************** !* THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC * !* OPERATION DEFINED BY OPND1,OPND2 & OPCODE * !*********************************************************************** %INTEGER CODE CODE=OPCODE %IF OPND2_PTYPE&7=2 %THEN CODE=CODE>>16 %IF COMM=1 %THEN CODE=CODE>>8 CODE=CODE&255 %IF EVALREG=BREG %THEN CODE=CODE-X'C0' AREA=OPND2_XB>>4 ACCESS=OPND2_XB&15 DISP=OPND2_D PSORLF1(CODE,ACCESS,AREA,DISP) GRUSE(EVALREG)=0 %UNLESS JJ=27 OLINK(EVALREG)=OPERAND(COMM) %END %ROUTINE CTOP(%INTEGERNAME FLAG) !*********************************************************************** !* THIS ROUTINE IS CALLED WHEN AN EXPRESSION OPERATION IS FOUND * !* BETWEEN TWO CONSTANTS. SOME OPERATIONS ARE INTERPRETED * !* ON EXIT FLAG=0 %IF OPERATION CARRIED OUT * !*********************************************************************** %INTEGER VAL1, VAL2, TYPEP, OP %LONGREAL RVAL1, RVAL2, X %SWITCH SW(10:28) OP=FLAG TYPEP=OPND1_PTYPE!OPND2_PTYPE %RETURN %IF OP>28 %OR TYPEP>=3 %IF OPND1_PTYPE=2 %THEN %START INTEGER(ADDR(RVAL1))=OPND1_D INTEGER(ADDR(RVAL1)+4)=OPND1_XTRA %IF MOD(RVAL1)SW(OP) INTEND: FLAG=0; OPND1_PTYPE=1 %IF 0<=VAL1<=4095 %THEN OPND1_FLAG=0 %ELSE OPND1_FLAG=1 OPND1_D=VAL1 %RETURN SW(11): ! NEGATE %IF TYPEP=1 %THEN VAL1=-VAL1 %AND ->INT END RVAL1=-RVAL1; ->REAL END SW(13): ! ENTIER %RETURN %IF MOD(RVAL1)>IMAX; ! TOO BIG VAL1=INT(RVAL1); ->INT END REAL END: OPND1_FLAG=1 OPND1_D=INTEGER(ADDR(RVAL1)) OPND1_XTRA=INTEGER(ADDR(RVAL1)+4) FLAG=0; OPND1_PTYPE=2 %RETURN SW(14): ! SIGN VAL1=0 %IF RVAL1>0 %THEN VAL1=1 %IF RVAL1<0 %THEN VAL1=-1 ->INTEND SW(15): ! ADD %IF TYPEP=1 %THEN VAL1=VAL1+VAL2 %AND ->INT END RVAL1=RVAL1+RVAL2; ->REAL END SW(16): ! MINUS %IF TYPEP=1 %THEN VAL1=VAL1-VAL2 %AND ->INT END RVAL1=RVAL1-RVAL2; ->REAL END SW(19): ! MULT SW(28): ! ARRAY BOUND MULT %IF TYPEP=1 %THEN VAL1=VAL1*VAL2 %AND ->INT END RVAL1=RVAL1*RVAL2; ->REAL END SW(21): ! REAL DIVISION %RETURN %IF RVAL2=0; ! AVOID DIV BY ZERO RVAL1=RVAL1/RVAL2; ->REAL END SW(20): ! '%DIV' DIVISION %RETURN %IF VAL2=0 %OR TYPEP#1 VAL1=VAL1//VAL2; ->INT END SW(25): ! EXP %RETURN %IF RVAL1<=0 %IF TYPEP=1 %AND 32>VAL2>0 %THEN %START X=RVAL1**VAL2 %IF MOD(X)>IMAX %THEN %RETURN VAL1=INT(X); ->INT END %FINISH %IF OPND2_PTYPE=1 %AND 63>IMOD(VAL2) %C %THEN RVAL1=RVAL1**VAL2 %AND ->REAL END SW(10): SW(12): SW(17): SW(18): SW(22): SW(23): SW(24): SW(26): SW(27): %END %ROUTINE FLOAT(%RECORD(RD)%NAME OPND1) !*********************************************************************** !* PLANT CODE TO CONERT OPERAND1 FROM FIXED TO FLOATING * !*********************************************************************** %IF OPND1_FLAG<=1 %THEN %START CVALUE=OPND1_D OPND1_D=INTEGER(ADDR(CVALUE)) OPND1_XTRA=INTEGER(ADDR(CVALUE)+4) OPND1_FLAG=1 %FINISH %ELSE %START LOAD(OPND1,ACCR,2) PLANT(X'A800'); ! FLT 0 GRUSE(ACCR)=0 %FINISH OPND1_PTYPE=2 TYPE=2 %END %ROUTINE TYPE CHK(%INTEGER MODE) !*********************************************************************** !* MODE=0 ARITHMETIC := MAKE BOTH REAL UNLESS BOTH INTEGER * !* MODE=1 ASSIGNMENT := FORCE OPERAND1 TO TYPE OF OPERAND 2 * !* MODE=2 REAL DIVISION := MAKE BOTH REAL * !*********************************************************************** %INTEGER PT1,PT2 PT1=OPND1_PTYPE&7 PT2=OPND2_PTYPE&7 %IF MODE#2 %AND PT1=1=PT2 %THEN %RETURN %IF MODE=1 %THEN %START %IF PT2=1 %AND PT1=2 %THEN FIX(OPND1,0) %AND %RETURN %FINISH %ELSE %START %IF PT2=1 %THEN FLOAT(OPND2) %FINISH %IF PT1=1 %THEN FLOAT(OPND1) %END %ROUTINE FIX(%RECORD(RD)%NAME OPND,%INTEGER 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 * !*********************************************************************** %IF OPND_FLAG=1 %THEN %START INTEGER(ADDR(CVALUE))=OPND_D INTEGER(ADDR(CVALUE)+4)=OPND_XTRA %IF MOD(CVALUE)>16 OPCODE=(OPCODE>>8)&255 VALUE=0 %IF OPND2_FLAG=0 %AND 1<=OPND2_D<=63*TYPE %THEN %C VALUE=OPND2_D; ! EXPONENT IS #0 AND CONSTANT LOAD(OPND1,ACCR,1); ! FETCH OPERAND TO ACC ! ! OPTIMISE **2 **3 AND **4 ! %IF 2<=VALUE<=4 %THEN %START %IF OPND1_FLAG=9 %OR OPND1_XB&3#0 %START LOAD(OPND1,ACCR,2) %UNLESS OPND1_FLAG=9 PLANT(X'4998'); ! ST TOS %IF VALUE=3 %THEN PLANT(X'4998');! ST TOS PLANT(OPCODE<<8!X'198'); ! OPCODE TOS %IF VALUE=4 %THEN PLANT(X'4998');! ST TOS %IF VALUE>2 %THEN PLANT(OPCODE<<8!X'198');! OPCODE TOS %FINISH %ELSE %START GET IN ACC(ACCR,BYTES(TYPEP)>>2,ACCESS,AREA,DISP) %CYCLE C=2,1,VALUE PSORLF1(OPCODE,ACCESS,AREA,DISP) %REPEAT OPND1_FLAG=9 OPND1_XB=ACCR<<4 OPND1_D=0 REGISTER(ACCR)=1 %FINISH GRUSE(ACCR)=0 %RETURN %FINISH %ELSE LOAD(OPND1,ACCR,2) ! ! OTHERWISE STORE OPERAND IN 'WORK' AND GET HOLD OF EXPONENT ! GET WSP(WORK,BYTES(TYPE)>>2) %IF TYPEP=2 %THEN GET WSP(EXPWORK,1) PSF1(ST,1,WORK) PLABEL=PLABEL-1; ! LABEL FOR JUMPING OUT LOAD(OPND2,BREG,2); ! EXPONENT TO ANY REGISTER %IF PARMOPT#0 %THEN %START %IF TYPEP=1 %AND VALUE=0 %THEN %C PPJ(30,7); ! J (B<0) TO ERROR ROUTINE PF3(JAT,13,0,4); ! J (B>0) ROUND NEXT JUMP PPJ(16,7); ! 0**0 IS ERROR IN ALGOL ! 0**(<0) GIVES DIVIDE ERROR %FINISH %IF TYPEP=2 %THEN PSF1(STB,1,EXPWORK) ! ! GET '1' INTO ACC IN APPROPIATE FORM ! %IF TYPEP=1 %THEN PLANT(X'6201') %ELSE %C PF1(X'60',0,PC,SPECIAL CONSTS(1)); ! LD(E) WORK,=D'1' ! ! IF EXPONENT NOT KNOWN AT COMPILE TIME TO BE +VE CONSTANT MUST ! ALLOW FOR ZERO :- XX**0=1 FOR ALL XX ! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N ! %IF VALUE=0 %THEN %START; ! NOT +VE CONSTANT ENTER JUMP(28,PLABEL,B'11');! J(B=0) END OF EXP ROUTINE %IF TYPEP=2 %THEN %START PF3(JAT,13,0,4); ! J*+4 IF B>0 PLANT(X'5200'); ! SLB 0 PLANT(X'2398'); ! SBB TOS %FINISH %FINISH C=CA PSF1(OPCODE,1,WORK) PSF1(DEBJ,0,(C-CA)//2) ! ! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE ! %IF VALUE=0 %AND TYPEP=2 %THEN %START PSF1(LB,1,EXPWORK); ! LB ON ORIGINAL EXPONENT ENTER JUMP(46,PLABEL,B'11');! BP END OF EXP ROUTINE PF1(RRDV,0,PC,SPECIAL CONSTS(1));! RRDV 1.0 %FINISH ! ! ALL OVER. RESULTS ARE IN ACC. FREE AND FORGET ANY OTHER REGISTERS ! TYPE=TYPEP REGISTER(BREG)=0; GRUSE(BREG)=0 GRUSE(ACCR)=0 OPND1_PTYPE=+TYPE OPND1_XB=0; OPND1_D=ACCR ENTER LAB(PLABEL,B'11',LEVEL);! LABEL AT END OF EXP ROUTINE %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** %IF REGISTER(BREG)>0 %THEN BOOT OUT(BREG) LOAD(OPND1,ACCR,2) %UNLESS OPND1_FLAG=8 LOAD(OPND2,ACCR,2) PPJ(0,14) %END %END %ROUTINE REDUCE ENV(%INTEGERNAME HEAD) !*********************************************************************** !* HEAD HAS AN ENVIRONMENT - THIS ROUTINE REMOVES ANYTHING * !* INCOMPATIBLE WITH THE CURRENT REGISTER STATE * !*********************************************************************** %INTEGER I,J,K,REG,USE %RECORD(LISTF)%NAME LCELL %INTEGERNAME OHEAD OHEAD==HEAD %WHILE OHEAD#0 %CYCLE LCELL==ASLIST(OHEAD) K=LCELL_S3 REG=K>>8; USE=K&255 %UNLESS USE=GRUSE(REG) %AND %C LCELL_S1=GRINF(REG) %THEN %C POP(OHEAD,I,J,K) %ELSE OHEAD==LCELL_LINK %REPEAT %END %INTEGERFN REVERSE(%INTEGER MASK) !*********************************************************************** !* REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31 * !*********************************************************************** %IF MASK>15 %THEN MASK=MASK!!X'30' %ELSE MASK=MASK!!15 %RESULT=MASK %END %ROUTINE ENTER LAB(%INTEGER LAB,FLAGS,LEVL) !*********************************************************************** !* ENTER A NEW LABEL ON THE LABEL LIST FOR THE CURRENT LEVEL * !* 2**0 OF FLAGS = 1 CONDITIONAL ENTRY * !* 2**1 OF FLAGS = 1 UPDATE ENVIRONMENT * !* 2**2 OF FLAGS = 1 REPLACE ENV =0 MERGE ENV * !* THE LABEL LIST * !* S1 = LABEL NO * !* S2 = ENVIRONMENT LIST << 16 ! UNFILLED JUMPS LIST * !* S3 = LEVEL <<24 ! LABEL ADDR * !*********************************************************************** %INTEGER CELL,AT,ENVHEAD,JUMPHEAD,INSTRN,L,OLDCELL %RECORD(LISTF)%NAME LCELL ! ! MAP CELL ONTO CORRECT LIST CELL =TAGSCELL FOR USER LABELS ! FLAGS=FLAGS&1 %IF PARMOPT#0 %IF LAB<=NNAMES %THEN CELL=TAGS(LAB) %ELSE %START CELL=LABEL(LEVL); OLDCELL=0 %WHILE CELL>0 %CYCLE %EXIT %IF ASLIST(CELL)_S1=LAB OLDCELL=CELL CELL=ASLIST(CELL)_LINK %REPEAT %FINISH %IF CELL<=0 %THEN %START; ! LABEL NOT KNOWN %IF FLAGS&1=0 %THEN %START;! UNCONDITIONAL ENTRY PUSH(LABEL(LEVL),LAB,0,LEVEL<<24!CA) %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE L=0,1,7 GRUSE(L)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH %FINISH %RETURN %FINISH ! ! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS ! LCELL==ASLIST(CELL) %IF LCELL_S3&X'FFFFFF'# 0 %THEN FAULT(2,LAB) %AND %RETURN LCELL_S3=LEVEL<<24!CA ! ! SORT OUT ENVIRONMENTS - AS DIRECTED BY FLAGS ! JUMPHEAD=LCELL_S2 ENVHEAD=JUMPHEAD>>16 JUMPHEAD=JUMPHEAD&X'FFFF' %IF FLAGS&2=0 %THEN %START %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE L=0,1,7 GRUSE(L)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH CLEAR LIST(ENVHEAD) %IF ENVHEAD#0 %FINISH %ELSE %START REMEMBER %IF FLAGS&4=0 RESTORE (ENVHEAD) ENVHEAD=0 MERGE INFO %IF FLAGS&4=0 %FINISH ! ! NOW FILL JUMPS TO THIS LABEL - JUMP LIST FORMAT GIVEN IN 'ENTER JMP' ! %WHILE JUMPHEAD#0 %CYCLE POP(JUMPHEAD,AT,INSTRN,L) FAULT(12,LAB) %IF L NNAMES %THEN %START %IF OLDCELL#0 %THEN POP(ASLIST(OLDCELL)_LINK,AT,AT,AT) %C %ELSE POP(LABEL(LEVL),AT,AT,AT) %FINISH %END %ROUTINE ENTER JUMP(%INTEGER MASK,LAB,FLAGS) !*********************************************************************** !* IF LAB HAS BEEN ENCOUNTERED THEN PLANT A JCC OTHERWISE ENTER * !* THE LABEL IN THE LABEL LIST AND ATTACH THE JUMP TO IT SO IT * !* CAN BE PLANTED WHEN THE LABEL IS FOUND * !* THE LABEL LIST IS DESCRIBED UNDER 'ENTER LAB' * !* THE JUMP SUB-LIST HAS THE FORM * !* S1= ADDR OF JUMP * !* S2=INSTRN * !* S3=LEVEL * !* * !* FLAGS BITS SIGNIFY AS FOLLOWS * !* 2**0 =1 JUMP IS KNOWN TO BE SHORT * !* 2**1 =1 ENVIRONMENT MERGEING REQUIRED * !*********************************************************************** %INTEGER AT,CELL,J,JJ,LABADDR,I,ENVHEAD,OLDENV,JCODE,LEVL %RECORD(LISTF)%NAME LCELL FLAGS=FLAGS&1 %IF PARMOPT#0 ENVHEAD=0; AT=CA; LEVL=LEVEL %IF LAB<21000 %THEN FLAGS=FLAGS&X'FE'; ! SF OR USER LAB=LONG %IF LAB<=NNAMES %THEN %START CELL=TAGS(LAB) LEVL=ASLIST(CELL)_S1>>8&63; ! OLDI FLAGS=FLAGS&X'FD'; ! NO MERGE %FINISH %ELSE %START CELL=LABEL(LEVL) %WHILE CELL#0 %CYCLE %EXIT %IF ASLIST(CELL)_S1=LAB CELL=ASLIST(CELL)_LINK %REPEAT %FINISH JCODE=OCODE(MASK) -> FIRSTREF %IF CELL<=0 LCELL==ASLIST(CELL) LABADDR=LCELL_S3&X'FFFFFF' -> NOT YET SET %IF LABADDR=0 I=(LABADDR-CA)//2 FAULT(12,LAB) %IF LCELL_S3>>24>LEVEL %IF JCODE>6 %THEN PSF1(JCODE,0,I) %ELSE %C PF3(JCODE,MASK&15,0,I) %RETURN FIRSTREF: ! FIRST REFERENCE TO A NEW LABEL %IF LAB>NNAMES %AND FLAGS&2#0 %THEN GET ENV(ENV HEAD) PUSH(LABEL(LEVL),LAB,ENVHEAD<<16,0) CELL=LABEL(LEVL) LCELL==ASLIST(CELL) -> CODE NOT YET SET: ! LABEL REFERENCED BEFORE %IF LAB>NNAMES %AND FLAGS&2#0 %THEN %START I=LCELL_S2 OLDENV=I>>16 REDUCE ENV(OLD ENV) LCELL_S2=OLDENV<<16!I&X'FFFF' %FINISH CODE: ! ACTUALLY PLANT THE JUMP %IF JCODE>6 %THEN I=JCODE<<24!3<<23 %C %ELSE I=JCODE<<24!(MASK&15)<<21 J=LCELL_S2 JJ=J&X'FFFF' PUSH(JJ,CA,I,LEVEL) LCELL_S2=J&X'FFFF0000'!JJ PCONST(I) %END %ROUTINE MERGE INFO !*********************************************************************** !* MERGE THE CURRENT STATUS OF THE REGISTERS WITH THE VALUES * !* AT THE START OF THE CONDITIONAL CLAUSE. THIS PERMITS THE * !* THE COMPILER TO REMEMBER UNCHANGED REGISTERS BUT NOT THOSE * !* WHICH DEPEND ON A PARTICULAR RUN TIME ROUTE BEING TAKEN * !*********************************************************************** %INTEGER I,J %CYCLE J=0,1,4; I=GRMAP(J) GRUSE(I)=0 %UNLESS SGRUSE(I)=GRUSE(I) %AND SGRINF(I)=GRINF(I) %REPEAT %END %ROUTINE REMEMBER %INTEGER I,J %CYCLE J=0,1,4; I=GRMAP(J) SGRUSE(I)=GRUSE(I) SGRINF(I)=GRINF(I) %REPEAT %END %ROUTINE CSNAME(%INTEGER Z,REG) !*********************************************************************** !* COMPILE A SPECIAL NAME - PTYPE=X'1006' (=%ROUTINE %LABEL) * !* THEIR TRUE PTYPE IS IN GLOBAL ARRAY TSNAME. * !* SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%BI FLAG,PTR, * !* %SI XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:- * !* 2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %SPEC * !* 2**6 SET FOR IOCP CALL * !* 2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE * !* 2**2-2**0 HOLD NUMBER OF PARAMS * !* * !* THE FULL SPECS ARE AS FOLLOWS:- * !* 0=%REALFN ABS(%REAL VALUE) * !* 1=%INTEGERFN IABS(%INTEGER VALUE) * !* 2=%INTEGERFN SIGN(%REAL VALUE) * !* 3=%INTEGERFN ENTIER(%REAL VALUE) * !* 4=%ROUTINE CLOSESTREAM(%INTEGER STRM) * !* 5=%LONGREALFN SQRT(%LONGREAL X) * !* 6=%LONGREALFN SIN(%LONGREAL X) * !* 7=%LONGREALFN COS(%LONGREAL X) * !* 8=%LONGREALFN ARCTAN(%LONGREAL X) * !* 9=%LONGREALFN LN(%LONGREAL X) * !* 10=%LONGREALFN EXP(%LONGREAL X) * !* 11=%REALFN MAXREAL * !* 12=%REALFN MINREAL * !* 13=%INTEGERFN MAXINT * !* 14=%REALFN EPSILON * !* 15=%ROUTINE FAULT(%STRINGNAME FNO,%REAL VALUE) * !* 16=%ROUTINE STOP * !* 17=%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 SKIPCH * !* 52=%ROUTINE MONITOR * !* 53=%ROUTINE OPENDA(%INTEGER CHANNEL) * !* 54=%ROUTINE OPENSQ(%INTEGER CHANNEL) * !* 55=%ROUTINE CLOSEDA(%INTEGER CHANNEL) * !* 56=%ROUTINE CLOSESQ(%INTEGER CHANNEL) * !* 57=%ROUTINE PUTDA(%INTEGER CH,%INTEGERNAME SECT,%GENERAL A) * !* 58=%ROUTINE GETDA(%INTEGER CH,%INTEGERNAME SECT,%GENERAL A) * !* 59=%ROUTINE PUTSQ(%INTEGER CH,%GENERALARRAY A) * !* 60=%ROUTINE GETSQ(%INTEGER CH,%GENERALARRAY A) * !* 61=%ROUTINE RWNDSQ(%INTEGER CHANNEL) * !* 62=%ROUTINE INCHAR==INSYMBOL * !* 63=%ROUTINE OUTCHAR==OUTSYMBOL * !* 64=%ROUTINE PAPERTHROW==NEWPAGE * !* 65=%ROUTINE PUTARRAY(%INTEGER CH,%INTEGERNAME S,%GENERAL A) * !* 65=%ROUTINE GETARRAY(%INTEGER CH,%INTEGERNAME S,%GENERAL A) * !*********************************************************************** %SWITCH ADHOC(1:7) %CONSTINTEGERARRAY SNINFO(0:LAST SNAME)=%C X'11010024',X'11020024',X'11030024',X'11050024', X'80190000',X'80010000'(3), X'80010000'(3),X'80000000', X'80000000'(3),X'802D0000', 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', X'80190000'(4), X'80260000'(2),X'802A0000'(2), X'80190000',X'80060000',X'800A0000',X'80000000', X'80260000'(2); ! ! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY ! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO ! DUPLICATES NEED TO BE RECORDED. ! FIRST WORD OF GROUP HAS (THUNKS&PSIMPLE)<<8! NO OF PARAMS ! THE REMAINDER ARE THE TYPE OF EACH PARAM ! %CONSTINTEGERARRAY SNPARAMS(0:47)=0, 1,2, 2,1,2, X'13',1,5,X'101', X'13',1,5,1, X'12',1,X'102', X'11',5, X'12',1,1, X'12',1,5, X'11',1, X'12',1,X'101',X'11',X'101', 3,2,1,1, 1,3, 3,1,X'101',X'110', 2,1,X'110', 2,5,2; ! KEY TO PARAMETER TABLE ! 0 X0 == (NO PARAMS) ! 1 X1 == (%LONGREAL X) ! 3 X3 == (%INTEGER I,%LONGREAL X) ! 6 X6 == (%INTEGER I,%STRING S,%INTEGERNAME J) ! 10 XA == (%INTEGER I,%STRING S,%INTEGERNAME J) ! 14 XE == (%INTEGER I,%LONGREALNAME X) ! 17 X11 == (%STRING S) ! 19 X13 == (%INTEGER I,J) ! 22 X16 == (%INTEGER I,%STRING S) ! 25 X19 == (%INTEGER I) ! 27 X1B == (%INTEGER I,%INTEGERNAME J) ! 30 X1E == (%INTEGERNAME I) ! 32 X20 == (%LONGREAL X,%INTEGER I,J) ! 36 X24 == (%BOOLEAN B) ! 38 X26 == (%INTEGER I,%INTEGERNAME J,%GENERALARRAY A) ! 42 X2A == (%INTEGER I,%GENERALARRAY A) ! 43 X2D == %STRING S,%LONGREAL VALUE) ! %CONSTSTRING(13)%ARRAY SNXREFS(0:LAST SNAME)=%C "ABS","IABS","SIGN", "INTPT","CLOSESTREAM","ISQRT","ISIN", "ICOS","AARCTAN","ILOG","IEXP", "MAXREAL","MINREAL","MAXINT","EPSILON", "AFAULT","STOP","INSYMBOL","OUTSYMBOL", "INREAL","OUTREAL","ININTEGER", "OUTTERMINATOR", "OUTINTEGER","OUTSTRING","LENGTH","CPUTIME", "ASELIN","ASELOU","ALGNWL","ALGSPC", "ALGNLS","ALGSPS","ANXTSY","APRSYM", "ARDSYM","ALREAD","ALGPTH","PRINT", "PRSTNG","AICODE","READ1900","PRINT1900", "OUTPUT","READBOOLEAN","WRITEBOOLEAN", "WRITETEXT","COPYTEXT","ALRDCH","ALNXCH", "ALPRCH","ALSKCH","ALGMON","OPENDA", "OPENSQ","CLOSEDA","CLOSESQ","PUTDA", "GETDA", "PUTSQ", "GETSQ", "RWNDSQ", "INSYMBOL","OUTSYMBOL","ALGPTH","PUTARRAY", "GETARRAY"; %CONSTLONGINTEGER ONE=1,CODED=X'C007C18E03068000';! BITMASK FOR CODE DEPENDENT ! %INTEGER ERRNO,FLAG,POINTER,OPHEAD,OPBOT,PIN,SNNO,SNNAME,NAPS, %C SNPTYPE,JJ,XTRA,B,D,SNINF,P0 %STRING(16)REFNAME ! SNNAME=A(P) SNNO=K; ! INDEX INTO SNINFO %IF EBCDIC=0 %OR ONE<>16)&255 FLAG=SNINF>>24 ! ! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH. ! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL ! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES ! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME. ! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER ! %IF Z=13 %AND FLAG&X'80'=0 %START; ! RT PARAM FLAG=X'80'; ! GIVE FORMAL PROCEDURE %IF SNNO=1 %THEN POINTER=25 %ELSE POINTER=1 %IF SNNO=16 %OR SNNO=52 %THEN POINTER=0 %IF SNNO=40 %THEN POINTER=16 %FINISH ! %IF FLAG&X'80'#0 %THEN %START CXREF(REFNAME,PARMDYNAMIC,2,JJ);! JJ SET WITH REF DISPLACEMENT %IF SNNO=9 %THEN LOGEPDISP=JJ %IF SNNO=10 %THEN EXPEPDISP=JJ OPHEAD=0; P0=SNPARAMS(POINTER) PUSH(OPHEAD,JJ,P0&15,P0>>4) OPBOT=OPHEAD K=OPHEAD; JJ=1; D=64 P0=P0&15 %WHILE JJ<=P0 %CYCLE PTYPE=SNPARAMS(POINTER+JJ) %IF PTYPE=2 %THEN ACC=8 %ELSE ACC=4 D=(D&X'FFFF'+ACC-1)&(-ACC) %IF PTYPE&X'F0'=0 %THEN D=D!(PTYPE&X'F00')<<8 BINSERT(OPHEAD,OPBOT,PTYPE,SNNAME,D) D=D+ACC JJ=JJ+1 %REPEAT I=9; J=14; KFORM=0 OLDI=0; PTYPE=SNPTYPE+4096 USEBITS=3 REPLACE TAG(SNNAME) P=PIN; CNAME(Z,REG); ! RECURSIVE CALL %RETURN %FINISH ! ! ALL ROUTINES EXCEPT THE IMPLICITS REQUIRE A CHECH THAT THE USE OF THE ! NAME IS LEGAL AND THAT THE CORRECT NO OF PARAMETERS(BOTTOM 2 BITS OF ! FLAG) HAS BEEN SUPPLIED. THE CHECK IS TRIVIAL - THE PROBLEM ! IS TO GET THE RIGHT ERROR NUMBER. ! XTRA HAS A BITMASK OF ALLOWED USES(IE ALLOWED Z VALUES) ! %IF NAPS#FLAG&3 %THEN ERRNO=19 %AND ->ERREXIT JJ=1<ERR EXIT %FINISH ! ! A NUMBER OF INPUT-OUTPUT ROUTINES ARE MAPPED ONTO CALLS OF IOCP. ! THIS ARRANGEMENT HAS THE ADVANTAGE OF REQUIRING ONL 1 EXTERNAL REF ! IN THE GLA BUT HAS THE DISADVANTAGE THAT THE I-O ROUTINES CAN NOT ! BE PASSED AS RT-TYPE PARAMETERS AS WELL AS REQUIRING MESSY CODE ! HEREABOUTS. SNINF_PTR HOLD EITHER:- ! 1) THE IOCP ENTRY POINT NO ! OR 2) THE SYMBOL TO BE OUTPUT WITH 2**7 BIT SET ! ! THIS SECTION DEALS WITH SELECT INPUT,SELECT OUTPUT,NEWLINE,NEWPAGE ! SPACE,SKIP SYMBOL,PRINT SYMBOL,PRINT STRING ! AND PRINT CH ! ! %IF FLAG&X'40'#0 %THEN %START ! IOCPEP=POINTER ! %IF FLAG&3#0 %THEN %START; ! RT HAS PARAMS ! P=P+1 ! %IF SNNO=37 %THEN CSTREXP(1,1) %ELSE CSEXP(1,1) ! %FINISH ! %IF IOCPEP>127 %THEN DUMP(X'41',1,IOCPEP&127,0,0) %AND IOCPEP=5 ! CIOCP(IOCPEP); ! PLANT CALL OF IOCP ! ->OKEXIT ! %FINISH ! ! ADHOC CODING IS REQUIRED FOR THE REMAINING ROUTINES APART FROM ! A CHECK FOR NAMETYPE PARAMETERS. THE SWITCH NO IS KEPT IN POINTER ! ERRNO=22 ->ADHOC(POINTER) ADHOC(1): ! ABS ADHOC(2): ! IABS B=3-POINTER; ! TYPE ->ERREXIT %UNLESS A(P)=2 D=A(P+2); P=P+3 ->ERREXIT %UNLESS 2<=D<=3 CSEXP(ACCR,B,D) REG=NEST %IF REG<0 %IF SNNO=1 %THEN %START PF3(JAT,5,0,3) PSF1(IRSB,0,0) %FINISH %ELSE %START PF3(JAT,1,0,3) PSF1(RRSB,0,0) %FINISH GRUSE(ACCR)=0 ->OKEXIT ADHOC(3): ! SIGN ADHOC(5): ! ENTIER ->ERREXIT %UNLESS A(P)=2 D=A(P+2); P=P+3 ->ERREXIT %UNLESS 2<=D<=3 CSEXP(ACCR,2,D) REGISTER(ACCR)=1 OPHEAD=RPPTR A(RPPTR)=2<<16!9 A(RPPTR+1)=0 A(RPPTR+3)=16-SNNO; ! 13 FOR ENTIER, 14 FOR SIGN A(RPPTR+4)=1 A(RPPTR+6)=100 RPPTR=RPPTR+9 P0=P; EXPOP(OPHEAD,ACCR,1,1) P=P0; RPPTR=OPHEAD ->OKEXIT ADHOC(4): ! STOP PPJ(15,16) ->OKEXIT ADHOC(6): ! CODE ->ERREXIT %UNLESS A(P)=2 %IF A(P+2)=2 %THEN ->CONAM ->ERREXIT %UNLESS A(P+2)=1 B=A(P+5); D=B>>16&255; B=B>>24;! FIRST 2 CHARS %IF A(P+4)=2 %THEN %START %IF B='E' %AND D='L' %THEN B=NL %AND ->COD %IF B='S'=D %THEN B='%' %AND ->COD %FINISH ->ERREXIT %UNLESS A(P+4)=1 %IF B='_' %THEN B=' ' %IF B='\' %THEN B=NL P=P-1 COD: %IF EBCDIC#0 %THEN B=ITOETAB(B) GET IN ACC(ACCR,1,0,0,B) GRUSE(ACCR)=5; GRINF(ACCR)=B P=P+6 ->OKEXIT CONAM: ! STRINGNAME PARAMETER P=P+3; SAVEIRS; CNAME(2,ACCR) ->ERREXIT %UNLESS TYPE=5 %IF CODEPDISP=0 %THEN CXREF(REFNAME,PARMDYNAMIC,2,CODEPDISP) PLANT(X'1804'); ! PRCL 4 PLANT(X'4998'); ! ST TOS PSF1(LXN,1,16) PLANT(X'6C07'); ! RALN 7 PF1(CALL,2,XNB,CODEPDISP) %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE JJ=0,1,7 GRUSE(JJ)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH ->OKEXIT ADHOC(7): ! MONITOR PLANT(X'6200'); ! LSS 0 PLANT(X'4998'); ! ST TOS PPJ(0,2) OKEXIT: ! NORMAL EXIT P=P+1 PTYPE=SNPTYPE %RETURN ERREXIT: ! ERROR EXIT FAULT(ERRNO,SNNAME) P=PIN+1; SKIP APP P=P-1; %RETURN %END; ! OF ROUTINE CSNAME %ROUTINE CALL THUNKS(%INTEGER Z, REG, B, D) !*********************************************************************** !* A THUNKS CONSISTS OF AN ESCAPE DESCRIPTOR AT D(B) WHICH POINTS* !* TO STORED VALUES OF PC & LNB FOR THE THUNKS. THE BOUND FIELD * !* IS SET TO NONZERO IF A STORE IS NOT ALLOWED * !*********************************************************************** BASE=B; AREA=-1 GET IN ACC(DR,2,0,AREA CODE,D) %IF Z=1 %AND PARMARR#0 %THEN PF3(JCC,14,0,4) %AND PPJ(43,9) %IF Z=0 %THEN PSF1(MODD,0,0) %AND %RETURN %IF Z#1 %THEN %START GET IN ACC(REG,BYTES(TYPE)>>2,2,7,0) %FINISH %END %ROUTINE CANAME(%INTEGER Z, BS, DP) !*********************************************************************** !* BS & DP DEFINE THE POSITION OF THE ARRAY HEAD * !* Z AS FOR CNAME. ON Z=1 (STORE INTO ARRAY) THE SUSBSCRIPTS * !* ARE EVALUATED AND LEFT AS A RESULT DESCRIPTOR. THIS IS * !* BECAUSE OF THE ALGOL DEFINITION OF LEFTPARTLIST * !* IN-LINE CODE IS PLANTED EVEN IF PARM=NOARRAY IS REQUESTED * !*********************************************************************** %INTEGER HEAD1, HEAD2, HEAD3, NOPS, PTYPEP, KK, PP, %C JJ, TYPEP, ARRNAME, Q, ELSIZE, ARRP, PARAMS PP=P; TYPEP=TYPE; ARRP=PTYPE>>4&15 JJ=J; PTYPEP=PTYPE ELSIZE=BYTES(TYPE) ARRNAME=A(P); ! NAME OF ENTITY PARAMS=A(P+1) TEST APP(Q); ! COUNT NO OF SUBSCRIPTS ! ! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES PASSED ! AS %ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE ! DIMENSION FROM THE FIRST USE OF THE NAME. ! %IF JJ=0 %THEN %START; ! 0 DIMENSIONS = NOT KNOWN ASLIST(TCELL)_S1=( ASLIST(TCELL)_S1!Q) ! DIMSN IS BOTTOM 4 BITS OF TAG JJ=Q KFORM=ASLIST(TCELL)_S3&X'FFFF' %IF KFORM#0 %THEN ASLIST(KFORM)_S2=(Q<<16!ASLIST(KFORM)_S2) %FINISH %IF JJ=Q %AND PARAMS=1 %START; ! CORRECT DIMENSIONALITY ! ! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO ! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND ! ADD THEM TOGETHER. ! P=PP+3 %IF ARRP=2 %AND JJ=1 %THEN %START CSEXP(BREG,1,0); P=P+1 %FINISH %ELSE %START HEAD3=0; NOPS=0 HEAD1=RPPTR ! ! NOW PROCESS THE SUBSCRIPTS CALLINR ETORP TO CONVERT THE EXPRESSIONS ! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS. ! %CYCLE KK=1, 1, JJ; ! THROUGH THE SUBSCRIPTS ETORP(HEAD2,NOPS, 1);! SUBSCRIPT TO REVERSE POLISH RPPTR=RPPTR-3 %IF TYPE=2 %THEN A(RPPTR)=13 %AND A(RPPTR+1)=0 %C %AND RPPTR=RPPTR+3 P=P+2 %REPEAT P=P-1 ! ! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS ! %CYCLE KK=JJ,-1,1 NOPS=(NOPS+1)!1<<24; ! TREAT DVM AS '*' A(RPPTR)=X'51'<<16 A(RPPTR+1)=KK<<16!JJ A(RPPTR+2)=BS<<18!DP A(RPPTR+3)=28 A(RPPTR+4)=ARRP RPPTR=RPPTR+6 %REPEAT ! ! ADD OPERATORS TO THE BACK OF OPERANDS AND EVALUATE ! A(RPPTR)=100 RPPTR=RPPTR+3 PP=P EXPOP(HEAD1, BREG, NOPS, 5);! EVALUATE THE REVERSE POLISH LIST P=PP RPPTR=HEAD1 %FINISH BASE=BS; DISP=DP ACCESS=3; AREA=-1; %FINISH %ELSE %START FAULT(18, ARRNAME) BASE=BS; DISP=DP ACCESS=3; AREA=-1; P=P+1; SKIP APP %FINISH ACC=ELSIZE PTYPE=PTYPEP; J=JJ %END; ! OF ROUTINE CANAME %ROUTINE CNAME(%INTEGER Z, REG) !*********************************************************************** !* THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME * !* AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS * !* OR SUBNAMES) ARE INDEXED BY P WHICH IS ADVANCED. * !* Z SPECIFIES ACTION AS FOLLOWS:- * !* Z=0 COMPILE A ROUTINE CALL * !* Z=1 SET BASE,INDEX AND DISP FOR A 'STORE' OPERATION * !* Z=2 FETCH NAME TO 'REG' * !* Z=3 SET ADDR(NAME) IN REG FOR PASSING BY NAME (TOP BYTE SET) * !* Z=5 IF NAME IS IN A REGISTER THEN AS Z=2 ELSE SET BASE ETC * !* Z=6->11 NOT NOW USED * !* Z=12 SET BASE AND DISP TO POINT TO ARRAYHEAD * !* Z=13 SET REG TO POINT TO 4 WORD ROUTINE DISCRIPTOR * !* (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR) * !* * !* REG (WHERE APPROPRIATE) IS SET AS FOLLOWS:- * !* >=0 A REGISTER * !* -1 MEANS CHOOSE ANY REGISTER * !* IF A REGISTER IS CHOSEN THEN NEST IS SET WITH CHOICE * !*********************************************************************** %INTEGER JJ, KK, RR, LEVELP, DISPP, NAMEP, FNAME %SWITCH SW, MOD(0:7) %RECORD(LISTF)%NAME LCELL FNAME=A(P); NAMEP=FNAME TCELL=TAGS(FNAME) %IF TCELL<=0 %THEN %START FAULT(16, FNAME) I=LEVEL; J=0; K=FNAME KFORM=0; SNDISP=0; ACC=4 PTYPE=7; STORE TAG(K, N) N=N+4; COPY TAG(FNAME) LEVELP=I; DISPP=K %FINISH %ELSE %START LCELL==ASLIST(TCELL) KK=LCELL_S1; LCELL_S1=KK!X'8000' PTYPE=KK>>16; TYPE=PTYPE&7 OLDI=KK>>8&15; I=KK>>4&15; LEVELP=I J=KK&15 K=LCELL_S3>>16; DISPP=K %FINISH JJ=J; JJ=0 %IF JJ=15 ->NOT SET %IF TYPE=7 %IF (Z=0 %OR Z=13) %AND PTYPE>>12=0 %THEN FAULT(17,FNAME) %C %AND ->NOT SET ->ARRHEAD %IF Z=12 ->RTNAME %IF Z=13 ->RTCALL %IF PTYPE>>12#0 ->SW(TYPE) SW(6): SW(0): SW(4): !RECORD FORMAT NAME ILLEGAL TYPE: FAULT(5, FNAME) SW(7): NOT SET: P=P+1; ! NAME NOT SET NEST=0; BASE=I; DISP=K; ACCESS=0 PTYPE=1; TYPE=1 SKIP APP; %RETURN ARRHEAD: ! SET BASE & DISP FOR ARRAYHEAD BASE=I; ACCESS=0; DISP=K; AREA=-1 NO APP; %RETURN RTNAME: ! LOAD ADDR FOR RT-TYPE %IF PTYPE=SNPT %THEN CSNAME(Z, REG) %AND P=P+1 %AND %RETURN DISP=ASLIST(K)_S1; BASE=I %IF PTYPE&X'100'#0 %THEN %START;! TEST NAM BIT SET FORFORMAL PROCS AREA=-1 GET IN ACC(REG,4,0,AREA CODE,DISP) %FINISH %ELSE %START %IF J=14 %THEN %START; ! EXTERNAL ROUTINE PASSED GET IN ACC(REG,2,0,0,0); ! ZERO ENVIRONMENT PF1(LUH,0,SET XORYNB(-1,-1),DISP) %FINISH %ELSE %START %IF BASE=0 %AND CPRMODE=2 %START PLANT(X'7883'); ! LD LNB+12 PLT DESRCPTR PSF1(INCA,0,DISP) %UNLESS DISP=0 GRUSE(DR)=0 GET IN ACC(ACCR,2,0,0,0) %FINISH %ELSE %START PSF1(JLK,0,1); ! GET PC TO TOS RTJUMP(LDA,ASLIST(K)_S1); ! ADD N TO POINT @ ENTRY PLANT(X'1598'); ! INCA TOS - TO DR STORE CONST(JJ,4,X'E1000000',0) PF1(LDTB,0,PC,JJ) GRUSE(DR)=0 GET IN ACC(ACCR,1,0,LNB,PTR OFFSET(BASE)) PSF1(LUH,0,0); ! SPARE FIELD IN RT HDDR %FINISH PLANT(X'5998'); ! STD TOS DR TO STACKTOP PLANT(X'6B98'); ! LUH TOS DR TO TOP OF ACC %FINISH %FINISH NO APP; %RETURN ! ! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL ! RTCALL: ! FIRST CHECK %IF TYPE=0 %AND Z#0 %THEN FAULT(23, FNAME) %AND ->NOT SET ! RT NAME IN EXPRSN %IF PTYPE=SNPT %THEN CSNAME(Z,REG) %AND %RETURN CRCALL(K); ! DEAL WITH PARAMS %RETURN %IF PTYPE=X'1000' %OR PTYPE=X'1100' %UNLESS Z=0 %OR Z=2 %OR Z=5 %THEN %START; ! FUNCTIONS BASE=0; ACCESS=0; AREA=-1; DISP=0 %FINISH %IF REG=BREG %THEN PLANT(X'499C');! ST BREG %RETURN SW(5): ! TYPE=STRING ->ILLEGAL TYPE %UNLESS Z=2; ! ONLY FETCH ALLOWED BASE=I; AREA=-1 GET IN ACC(REG,2,0,AREA CODE,K) NO APP; %RETURN SW(1): ! TYPE =INTEGER SW(2): ! TYPE=REAL SW(3): ! BOOLEAN %IF PTYPE&X'F0'=0 %THEN %START BASE=I; DISP=K ACCESS=0; AREA=-1 %IF A(P+1)=3 %THEN P=P+1 %ELSE NO APP %FINISH %ELSE %START CANAME(Z, I, K) PTYPE=PTYPE&X'F0FF'; ! NAM=0 TYPE=PTYPE&7 %IF GRUSE(DR)=7 %AND GRINF(DR)=NAMEP %THEN AREA=7 %FINISH KK=Z; KK=2 %IF Z=5 NAM=PTYPE>>8&15 ->MOD(NAM<<2!KK&3) MOD(1): ! SCALAR STORE %IF PTYPE&X'F0'=0 %THEN %START %IF BASE=RLEVEL %THEN AREA=LNB %ELSE AREA=AREA CODE %FINISH %RETURN MOD(6): ! SCALARNAME FETCH CALL THUNKS(2, REG, BASE, DISP) TEST ASS(REG) %IF PARMCHK#0 NEST=REG; %RETURN MOD(2): ! SCALAR FETCH %IF BASE=RLEVEL %AND AREA<0 %THEN AREA=LNB %ELSE AREA=AREA CODE %IF ACCESS=0 %AND GRUSE(REG)=9 %AND GRINF(REG)=NAMEP %START %IF REGISTER(REG)=0 %OR Z#5 %START %IF REGISTER(REG)>0 %THEN BOOT OUT(REG) NEST=REG; %RETURN %FINISH %FINISH %IF PARMCHK=0 %AND Z=5 %THEN NEST=-1 %AND %RETURN GET IN ACC(REG,BYTES(TYPE)>>2,ACCESS,AREA,DISP) %IF ACCESS=3 %THEN GRUSE(DR)=7 %AND GRINF(DR)=NAMEP %IF ACCESS=0 %THEN GRUSE(REG)=9 %AND GRINF(REG)=NAMEP %IF PARMCHK=1 %THEN %START %IF REG=BREG %THEN JJ=CPB %ELSE JJ=UCP PF1(JJ,0,PC,PLABS(1)) PCONST(JCC<<24!8<<21!((PLABS(5)-CA)//2)&X'3FFFF') %FINISH NEST=REG %RETURN MOD(7): ! SCALAR NAME FETCH POINTER GET IN ACC(REG,2,0,AREA CODE,DISP) %RETURN MOD(3): ! SCALAR FETCH ADDR %IF ACCESS=3 %THEN %START GET IN ACC(DR,2,0,AREA CODE,DISP) %UNLESS AREA=7 PLANT(X'179C'); ! MODD BREG GRUSE(DR)=0 COPY DR %IF REG#DR %FINISH %ELSE %START %IF REG#DR %THEN %START GET INACC(ACCR,1,0,LNB,PTR OFFSET(BASE)) PSF1(IAD,0,DISP) PF1(LUH,0,PC,PARAM DES(TYPE)) %FINISH %ELSE %START GET IN ACC(DR,2,0,PC,PARAM DES(TYPE)) PSF1(LDA,1,PTR OFFSET(BASE)) PSF1(INCA,0,DISP) %FINISH %FINISH NEST=REG %RETURN MOD(5): ! SCALAR NAME STORE CALL THUNKS(1,-1,BASE,DISP) DISP=0; ACCESS=2; AREA=7 %END %ROUTINE NO APP !*********************************************************************** !* CHECK FOR APP AND FAULT IF FOUND * !*********************************************************************** P=P+1 %IF A(P)=3 %THEN P=P+1 %ELSE %START FAULT(19,A(P-1)) SKIP APP %FINISH %END %ROUTINE GTHUNKS(%INTEGER PTYPEP,PNAME) !*********************************************************************** !* GENERATE A THUNKS FOR THE ACTUAL PARAMETER INDEXED BY P * !* PTYPEP IF THE FORMAL PARAMETER TYPE. * !*********************************************************************** %INTEGER TYPEP, APALT, D, TOPREG, PL, NOSTORE, CTYPE, ICONST, AD, D1, D2 %LONGREAL RCONST %SWITCH PARTYPE(0:7) ! ! FIRST CHECK FOR THUNKS PASSED ON AS THUNKS. IF FOUND THEN IT IS ! SUFFICIENT TO COPY THE THUNKS POINTER ! APALT=A(P); NOSTORE=0 TYPEP=PTYPEP&7; TOPREG=15 %IF APALT=2 %AND A(P+2)=3 %START; ! NAME,NO APP COPYTAG(A(P+1)) %IF ROUT=0 %AND TYPE=TYPEP %AND (ARR=0 %OR TYPE=6) %START BASE=I; AREA=-1 %IF NAM=1 %THEN GETINACC(ACCR,2,0,AREA CODE,K) %ANDRETURN ! ! A SIMPLE LOCAL NAME DOES NOT REQUIRE A PROPER THUNKS ! A NORMAL DESCRIPTOR IS MORE THAN ADEQUATE ! %IF TYPEP<=3 %THEN P=P+1 %AND CNAME(3,ACCR) %AND %RETURN %FINISH %FINISH ! ! CHECK FOR A SIMPLE CONSTANT BEING PASSED BY NAME. IF FOUND IT IS OK ! TO PASS A DESCRIPTOR TO THE CONSTANT AREA. ! %IF APALT=3 %AND A(P+1)=2 %AND A(P+2+A(P+2))=2 %AND %C A(P+4)=2 %AND 1<=TYPEP<=2 %AND PARMOPT=0 %START CTYPE=A(P+5) ICONST=0; RCONST=0 %IF CTYPE=1 %THEN %START ICONST=A(P+6) RCONST=ICONST %FINISH %ELSE %START INTEGER(ADDR(RCONST))=A(P+6) INTEGER(ADDR(RCONST)+4)=A(P+7) ICONST=INT(RCONST) %IF TYPEP=1 %FINISH ! %IF A(P+3)=2 %THEN ICONST=-ICONST %AND RCONST=-RCONST %IF TYPEP=1 %THEN AD=ADDR(ICONST) %ELSE AD=ADDR(RCONST) STORE CONST(D2,BYTES(TYPEP),INTEGER(AD),INTEGER(AD+4)) D2=D2&X'7FFFFFFF'; !N REMOVE CTABLE BIT D1=SIZE CODE(TYPEP)<<27+1 PGLA(4,8,ADDR(D1)) D=GLACA-8 RELOCATE(D+4,D2,1) PUSH(GLARELOCS,D+4,D2,0); ! REMEMBER ADDR IN GLA FOR UPADTING AREA=-1; BASE=0 GET IN ACC(ACCR,2,0,AREA CODE,D) %RETURN %FINISH ! ! A PROPER THUNKS IS NEEDED ! %IF REGISTER(ACCR)#0 %THEN BOOT OUT(ACCR) PLABEL=PLABEL-1; PL=PLABEL ENTER JUMP(0,PL,B'11') ! PF1(STLN,0,TOS,0) ! PF1(ST,0,TOS,0) ! PF1(STB,0,TOS,0) ! PF1(CPSR,0,BREG,0) ! PSF1(ADB,0,16) ! PF1(STB,0,TOS,0) ! PF1(STXN,0,TOS,0) ! PF1(STCT,0,TOS,0) ! PF1(LLN,1,0,4) PCLOD(118,122) %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE D=0,1,7 GRUSE(D)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH ->PARTYPE(TYPEP) PARTYPE(0): PARTYPE(4): PARTYPE(5): PARTYPE(7): ERROR: FAULT(22, PNAME) %RETURN PARTYPE(3): ! BOOLEAN FORMAL ->ERROR %UNLESS APALT=2 %OR APALT=4 ->COM PARTYPE(1): ! INTEGER FORMAL PARTYPE(2): ! REAL FORMAL ->ERROR %UNLESS 2<=APALT<=3 COM: %IF APALT=2 %THEN %START; ! ACTUAL= COPYTAG(A(P+1)) %IF ROUT=0 %AND TYPE=TYPEP %START P=P+1; CNAME(3, DR) ->THUNKSEND %FINISH %FINISH P=P+1 CSEXP(ACCR, TYPEP, APALT) GET WSP(D, BYTES(TYPEP)>>2); ! 1 OR 2 WORDS PSF1(ST,1,D) PF1(LDTB,0,PC,PARAM DES(TYPEP)) PSF1(LDA,1,PTR OFFSET(RLEVEL)) PSF1(INCA,0,D) NOSTORE=4 THUNKSEND: ! EXIT SEQUENCE ! PF1(LCT,0,TOS,0) ! PF1(LXN,0,TOS,0) ! PF1(MPSR,0,TOS,0) ! PF1(LB,0,TOS,0) ! PF1(X'60',0,TOS,0); ! L =LOAD ACS ! PF1(LLN,0,TOS,0) ! PSF1(ESEX,0,0) PCLOD(124,127) PASS DES:ENTER LAB(PL,B'111',LEVEL) GET WSP(D,2) PLANT(X'6398'); ! LSS TOS PSF1(ST,1,D) PSF1(STLN,1,D+4) PSF1(LSS,1,PTR OFFSET(RLEVEL)) PSF1(IAD,0,D) PF1(LUH,0,PC,SPECIAL CONSTS(2)+NOSTORE) GRUSE(ACCR)=0 %RETURN PARTYPE(6): ! LABEL AND SWITCH %IF PTYPEP&255>16 %START ->ERROR %UNLESS APALT=2 %AND A(P+2)=3 P=P+1; GOTOLAB(3) ->PASS DES %FINISH %IF APALT=3 %OR APALT=5 %THEN %START P=P+1; CDE(11-APALT<<1); ! MODE = 5 OR 3 ->PASS DES %FINISH ->ERROR %UNLESS APALT=2 P=P+1; GOTOLAB(1) ->PASS DES %END %ROUTINE FETCH STRING(%INTEGER REG) !*********************************************************************** !* FETCH A STRING POINTER FOR PASSING.P TO ALT OF ACTUAL PARAM * !*********************************************************************** %INTEGER I %IF A(P)=1 %THEN %START I=A(P+1)+EBCDIC PF1(LDRL,0,PC,STRLINK) PSF1(INCA,0,I) %UNLESS I=0 %IF EBCDIC#0 %THEN PSF1(LDB,0,A(P+2)) %IF REG#DR %THEN COPY DR %FINISH %ELSE P=P+1 %AND CNAME(2,REG) %END %INTEGERFN CHECK FPROCS(%INTEGER ACTHEAD,FORMALHEAD) !*********************************************************************** !* CHECK THAT THE PARAMETERLIST OF A ROUTINE BEING PASSED AS * !* A PAREMETER IS THE SAME AS THAT GIVEN (VIA A COMMENT) FOR THE * !* FORMAL PROCEDURE. REGRETABLY IF THE FORMAL IS OF A PROCEDURE * !* WHICH IS ITSELF A FORMAL PROCEDURE THEN NO CHECK CAN BE MADE * !* %IN MIXED LANGUAGE SITUATIONS NAM=1 (SUBSTITUTION),NAM=2 (REF) * !* AND NAM=3 (FORTRAN RESULT) MUST BE TREATED AS EQUIVALENT * !*********************************************************************** %INTEGER NPS,FPTYPE,APTYPE NPS=ASLIST(FORMALHEAD)_S2 %RESULT=1 %IF 0<=NPS#ASLIST(ACTHEAD)_S2 ! %WHILE NPS>0 %CYCLE MLINK(ACTHEAD) MLINK(FORMALHEAD) APTYPE=ASLIST(ACTHEAD)_S1 FPTYPE=ASLIST(FORMALHEAD)_S1 %RESULT=1 %UNLESS FPTYPE=APTYPE %OR %C (APTYPE&X'F00'#0 %AND FPTYPE&X'F00'#0 %AND %C APTYPE&X'F0FF'=FPTYPE&X'F0FF') NPS=NPS-1 %REPEAT %RESULT=0; ! CORRESPONDENCE COMPLETE %END %ROUTINE CRCALL(%INTEGER CLINK) !*********************************************************************** !* COMPILE A ROUTINE OR FN CALL * !* THE PROCEDURE CONSIST OF THREE PARTS:- * !* A) PLANT THE PARAMETER (IF ANY) * !* B) ENTER THE ROUTINE OR FN * !* C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE * !* ALTERED BY THE CALLED PROCEDURE. * !*********************************************************************** %INTEGER II,PXTRA,DLINK,JJJ,NPARMS,PT,LP,PSIZE,III,RDISP, %C RTNAME,TL,MOVEPTR,PP,PNAM,NP,ALT,JJ %RECORD(LISTF)%NAME LCELL JJJ=J; LP=I; DLINK=CLINK; TL=OLDI LCELL==ASLIST(CLINK) RTNAME=A(P);PT=PTYPE ! ! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED ! TEST APP(NPARMS) P=P+1 RDISP=LCELL_S1 %IF LCELL_S2#NPARMS %THEN %START FAULT(19,RTNAME); ! WRONG NO OF PARAMETERS GIVEN SKIP APP %RETURN %FINISH ! SAVE IRS %UNLESS REGISTER(ACCR)!REGISTER(BREG)=0 PLANT(X'1804'); ! PRCL 4 P=P+1 MOVEPTR=5 -> ENTRY SEQ %IF NPARMS=0; ! NO PARAMETERS TO BE PLANTED NP=0; PP=P-2 ! NEXT PARM:CLINK=LCELL_LINK NP=NP+1 P=PP+1 ->ENTRY SEQ %IF CLINK=0 LCELL==ASLIST(CLINK) PSIZE=LCELL_S3>>16 PNAM=LCELL_S2 PXTRA=PNAM>>16 PNAM=PNAM&X'FFF' PTYPE=LCELL_S1 P=PP+2; PP=P+A(P) P=P+1 ROUT=PTYPE>>12 NAM=PTYPE>>8&15 ARR=PTYPE>>4&15 TYPE=PTYPE&15 II=TYPE ALT=A(P); ! SYNTACTIC ALTERNATIVE OF APP %IF PSIZE<=0 %AND((ROUT!ARR#0 %AND ALT#2) %OR %C (TYPE=5 %AND ALT>2) %OR (NAM=2 %AND ALT#2) %OR %C (PTYPE&X'F0F0'#0 %AND TYPE<=2 %AND(ALT=1 %OR ALT>3))%OR %C (PTYPE&X'F0FF'=3 %AND ALT&1=1) %C %OR (PTYPE&X'F0FF'<=2 %AND (ALT=1 %OR ALT>=4))) %THEN %C FAULT(22,PNAM) %AND ->NEXT PARM ! ! FOR RT TYPE PARAMS, PASS 1 WORD POINTING TO 4 WORDS SET ! UP AS CODE,GLA,EP ADDR & ENVIRONMENT ! %IF ROUT=1 %THEN %START II=PTYPE; P=P+1 CNAME(13,ACCR); ! SET UP 4 WDS & SET PTR FAULT(21,PNAM) %IF PTYPE>>12#0 %AND %C (II&15#PTYPE&15 %OR CHECK FPROCS(K,PXTRA)#0);! TYPE SIMILAR P=P+1 MOVEPTR=MOVEPTR+4 STUFF: REGISTER(ACCR)=3 ->NEXT PARM %FINISH ! %IF ARR=0 %AND (NAM=2 %OR(NAM=3 %AND ALT=2)) %START P=P+1; CNAME(3,ACCR) FAULT(22,PNAM) %UNLESS II=PTYPE&7 %AND PTYPE&X'F00'=0 MOVEPTR=MOVEPTR+2 ->STUFF %FINISH ! %IF PSIZE>0 %THEN %START; ! A THUNKS HAS BEEN SET GTHUNKS(PTYPE,PNAM) MOVEPTR=MOVEPTR+2 ->STUFF %FINISH ! ! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS ! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM2 OF THE PARAMETER ! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN ! BE PASSED ! %IF ARR=1 %THEN %START III=NAM; ! 0 FOR ARRAY BY VALUE %IF A(P)=2 %AND A(P+2)=3 %THEN %START P=P+1; CNAME(12,ACCR); TYPE=PTYPE&7 FAULT(22,PNAM) %IF (PTYPE&X'F0') = 0; ! FAULT IF ACTUAL NOT ARRAY %IF III=3 %THEN JJ=2 %ELSE JJ=4 GET IN ACC(ACCR,JJ,0,AREA CODE,DISP) %IF ARR#0 %AND (II=0 %OR II=TYPE %OR %C (III=0 %AND II#3#TYPE))%START %IF II#0 %THEN %START; ! NOT GENERAL ARRAY NAME %IF PXTRA=0 %THEN PXTRA=J %AND %C LCELL_S2=PXTRA<<16!PNAM %IF J=0 %THEN %START;! ACTUAL DIMENSN UNKNOWN FNAME=A(P-2) J=PXTRA; II=TAGS(FNAME) ASLIST(II)_S1=(ASLIST(II)_S1!PXTRA) %FINISH FAULT(20,PNAM) %IF 0#J#PXTRA %AND III#3 %FINISH MOVEPTR=MOVEPTR+JJ ->STUFF %FINISH %FINISH FAULT(22,PNAM) ->NEXT PARM %FINISH ! %IF TYPE=5 %THEN %START; ! STRINGS FETCH STRING(ACCR) FAULT(22,PNAM) %UNLESS TYPE=5 MOVEPTR=MOVEPTR+2 ->STUFF %FINISH ! ! %IF TYPE=6 %THEN %START; ! LABEL BY VALUE ! %MONITOR ! %STOP ! %FINISH %IF TYPE<=3 %THEN %START P=P+1; III=NAM CSEXP(ACCR,TYPE,ALT) JJ=BYTES(II)>>2 %IF III=0 %THEN MOVEPTR=MOVEPTR+JJ %ELSE %START GET WSP(III,JJ) PSF1(ST,1,III) PSF1(LSS,0,III) PSF1(IAD,1,PTR OFFSET(RLEVEL)) PF1(LUH,0,PC,PARAM DES(II)) GRUSE(ACCR)=0 MOVEPTR=MOVEPTR+2 %FINISH ->STUFF %FINISH -> NEXT PARM ENTRY SEQ: ! CODE FOR RT ENTRY ! %IF REGISTER(ACCR)=3 %THEN PLANT(X'4998') %C %AND REGISTER(ACCR)=0; ! ST TOS PTYPE=PT; J=JJJ ! ! ORDINARY ROUTINES WILL AND RT PARAMS MAY REQUIRE AN EXTRA PARAMETER ! BEING LNB FOR THE LEVEL OF ROUTINE DECLARATION TO BE STACKED ! %IF JJJ=14 %THEN %START; ! EXTERNAL II=SET XORYNB(-1,-1); ! XNB TO PLT PSF1(RALN,0,MOVEPTR) PF1(CALL,2,II,RDISP) %FINISH %ELSE %START %IF PTYPE&X'100'=0 %THEN %START;! INTERNAL RT CALLS %IF LP=0 %THEN %START PLANT(X'7883'); ! LD LNB+12 PLT DESRCPTR PSF1(INCA,0,RDISP) %UNLESS RDISP=0 PSF1(RALN,0,MOVEPTR) PLANT(X'1FDC'); ! CALL (%DR) %FINISH %ELSE %START II=SET XORYNB(XNB,LP) PSF1(RALN,0,MOVEPTR) RT JUMP(CALL,ASLIST(DLINK)_S1) %FINISH %FINISH %ELSE %START AREA=-1; BASE=LP AREA=AREA CODE GET IN ACC(DR,2,0,AREA,RDISP) PSORLF1(LB,0,AREA,RDISP+12) PSORLF1(LSS,0,AREA,RDISP+8) PSF1(RALN,0,MOVEPTR); ! RAISE FOR NORMAL PARAMS PPJ(0,17); ! STACK EXTRA PARAM IF NEEDED PLANT(X'1FDC'); ! AND ENTER VIA DESCRPTR IN DR %FINISH %FINISH %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE II=0,1,7 GRUSE(II)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH %END %ROUTINE SKIP EXP(%INTEGER MODE) !*********************************************************************** !* SKIP OVER AN EXPRESSION WHICH IS EITHER A CONDITIOAL EXPR * !* OR A SIMPLE EXPRESSION. MODE AS FOR SKIP SEXP * !* P:='%IF''%THEN''%ELSE', * !* P:='%IF''%THEN''%ESLE' * !*********************************************************************** %INTEGER ALT, PIN PIN=P ALT=A(P); P=P+1; ! ALT OF EXPRESSION %IF ALT=2 %THEN SKIP SEXP(MODE) %ELSE %START SKIP EXP(1) SKIP SEXP(MODE) SKIP EXP(MODE) %FINISH %END %ROUTINE SKIP SEXP(%INTEGER MODE) !*********************************************************************** !* SKIPS OVER A BOOLEAN EXPRESSION * !* MODE=0 FOR ARITHMETIC, =1 FOR BOOLEAN EXPRESSIO * !* P TO HOLE IN <+'> * !* OR P TO WHERE :- * !* P:= * !*********************************************************************** %INTEGER BOP, PIN, J %SWITCH ALT(1:8) PIN=P %UNTIL BOP#1 %CYCLE BOP=A(P+2); P=P+3; ! BOP =ALT OF P ->ALT(BOP+MODE<<2) ALT(1): ! ALT(6): ! P=P+1; SKIP APP; ->END ALT(2): ! P=P+A(P)+1 ->END ALT(7): ! P=P+1; ->END ALT(3): ! '('')' ALT(8): ! '('')' SKIP EXP(MODE); ->END ALT(5): ! SKIP EXP(0); P=P+1; SKIP EXP(0) END: ! ANY MORE RESTOF BEXP? BOP=A(P) P=P+1 %IF MODE#0 %REPEAT P=P+1 %IF MODE=0 %END %ROUTINE SKIP APP !*********************************************************************** !* SKIP OVER ARRAY OR RT ACTUAL PARAMETER PART * !* P POINTS TO THE ALT OF P. * !*********************************************************************** %INTEGER ALT, PIN PIN=P; ALT=A(P) %IF ALT#3 %THEN %START %IF ALT=2 %THEN %START P=P+1+A(P+1) %WHILE A(P)=1 %CYCLE; P=A(P+2)+P+2; %REPEAT %FINISH %ELSE %START %WHILE A(P)=1 %CYCLE; P=P+1; P=P+A(P); %REPEAT %FINISH %FINISH P=P+1 %END %ROUTINE TEST APP(%INTEGERNAME NUM) !*********************************************************************** !* THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS * !* WHICH IT RETURNS IN NUM. * !*********************************************************************** %INTEGER PP, Q Q=0; PP=P; P=P+1; ! P ON NAME AT ENTRY %IF A(P)=2 %THEN %START Q=1; P=P+1+A(P+1) %WHILE A(P)=1 %CYCLE; Q=Q+1; P=P+2+A(P+2); %REPEAT %FINISH %ELSE %START %WHILE A(P)=1 %CYCLE; ! NO (MORE) PARAMETERS P=P+1; Q=Q+1 P=P+A(P) %REPEAT %FINISH P=PP; NUM=Q %END %ROUTINE TEST ASS(%INTEGER REG) !*********************************************************************** !* TEST ACC OR B FOR THE UNASSIGNED PATTERN * !*********************************************************************** %INTEGER OPCODE %IF REG=BREG %THEN OPCODE=CPB %ELSE OPCODE=UCP PF1(OPCODE,0,PC,PLABS(1)) PCONST(JCC<<24!8<<21!((PLABS(5)-CA)//2)&X'3FFFF') %END %ROUTINE CBPAIR(%INTEGERNAME LB,UB) !*********************************************************************** !* EXTRACT UPPER AND LOWER BOUNDS FROM A CONSTANT BOUND PAIR * !*********************************************************************** %INTEGER KK,KKK,JJ,BP P=P+1; KK=0 %CYCLE JJ=1,1,2 KKK=KK %IF A(P)=2 %THEN KK=-1 %ELSE KK=1; ! EXTRACT SIGN BP=A(P+2) KK=KK*BP P=P+3 %REPEAT %IF KKK>KK %THEN FAULT(43,0) %AND KK=KKK LB=KKK; UB=KK %END %ROUTINE GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) !*********************************************************************** !* FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS * !*********************************************************************** %INTEGER J,K,L %IF SIZE>4 %THEN SIZE=0 POP(AVL WSP(SIZE,LEVEL),J,K,L) %IF K<=0 %THEN %START; ! MUST CREATE TEMPORARY %IF SIZE>1 %AND N&7=0 %THEN ODD ALIGN K=N %IF SIZE=0 %THEN N=N+268 %ELSE N=N+SIZE<<2 %FINISH PLACE=K PUSH(TWSPHEAD,K,SIZE,0) %UNLESS SIZE=0 %END %ROUTINE RETURN WSP(%INTEGER PLACE,SIZE) %IF SIZE>4 %THEN SIZE=0 PUSH(AVL WSP(SIZE,LEVEL),0,PLACE,0) %END %ROUTINE SET LINE !*********************************************************************** !* UPDATE THE STATEMENT NO * !*********************************************************************** PCONST(X'63800000'!LINE) PSF1(ST, 1, DIAGINF(LEVEL)+4) GRUSE(ACCR)=5; GRINF(ACCR)=LINE %END %ROUTINE SET USE(%INTEGER R,U,I) !*********************************************************************** !* NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I' * !*********************************************************************** GRUSE(R)=U ; GRINF(R)=I GRAT(R)=CA %END %ROUTINE SAVE IRS !*********************************************************************** !* DUMP ACC AND-OR B ONTO THE STACK. USED BEFORE CALLING FNS * !* IN EXPRESSIONS. * !*********************************************************************** %IF REGISTER(BREG)>=1 %THEN BOOT OUT(BREG) %IF REGISTER(ACCR)>=1 %THEN BOOT OUT(ACCR) %IF REGISTER(DR)>=1 %THEN BOOT OUT(DR) %END %ROUTINE BOOT OUT(%INTEGER REG) !*********************************************************************** !* REMOVE TEMPORARIES FROM REG INTO LOCAL OR ONTO STACK * !* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR * !* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY * !* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS * !*********************************************************************** %CONSTBYTEINTEGERARRAY BOOTCODE(0:7)=X'48',X'58',X'5C',0(4),X'5A'; %INTEGER CODE,RR %RECORD(RD)%NAME R CODE=BOOTCODE(REG) RR=REGISTER(REG) ! ABORT %UNLESS 1<=RR<=3 %AND CODE#0 R==RECORD(OLINK(REG)) %IF RR=2 %THEN %START %IF R_D=0 %THEN GET WSP(R_D,BYTES(R_PTYPE&7)>>2) PSF1(CODE,1,R_D) R_FLAG=7; R_XB=LNB<<4 %FINISH %ELSE %START %IF REG#ACCR %AND (REGISTER(ACCR)=1 %OR REGISTER(ACCR)=3)%C %THEN BOOT OUT(ACCR) PLANT(CODE<<8!X'198'); ! "CODE" TOS %IF RR=1 %THEN R_FLAG=8 %AND R_XB=TOS<<4 %FINISH REGISTER(REG)=0 %END %ROUTINE COPY DR !*********************************************************************** !* COPY THE DR TO ACC SAVING ANYTHING IN ACC * !*********************************************************************** %IF REGISTER (ACCR)#0 %THEN BOOT OUT(ACCR) PSF1(CYD,0,0) GRUSE(ACCR)=0 %END %ROUTINE CHANGE RD(%INTEGER REG) !*********************************************************************** !* CHANGE A RESULT DESCRIPTOR WHEN OPERAND IS STACKED * !*********************************************************************** %INTEGER I,RR %RECORD(RD)NAME OPND RR=REGISTER(REG) ! ABORT %UNLESS 1<=RR<=3 OPND==RECORD(OLINK(REG)) %IF RR=1 %THEN %START; ! CHANGE RESULT DESCRIPTOR ! ABORT %UNLESS OPND_FLAG=9 %AND OPND_XB>>4=REG OPND_FLAG=8; ! CHANGE TO 'STACKED' OPND_XB=TOS<<4 %FINISH %IF RR=2 %START OPND_FLAG=7; OPND_XB=LNB<<4 %FINISH %END %ROUTINE STORE TAG(%INTEGER KK, SLINK) %INTEGER Q, QQ, QQQ, I %RECORD(LISTF)%NAME LCELL Q=TAGS(KK) %IF ASLIST(Q)_S1>>8&63=LEVEL %THEN FAULT(7,KK) %ELSE %START Q=PTYPE<<16!LEVEL<<8!RLEVEL<<4!J ! ABORT %UNLESS (KFORM!ACC)>>16=0 QQQ=SLINK<<16!KFORM QQ=SNDISP<<16!ACC I=ASL %IF I=0 %THEN I=MORE SPACE LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_LINK=TAGS(KK)!NAMES(LEVEL)<<18 LCELL_S1=Q; LCELL_S2=QQ; LCELL_S3=QQQ TAGS(KK)=I NAMES(LEVEL)=KK %FINISH %END %ROUTINE COPY TAG(%INTEGER KK) %INTEGER QQ,QQQ %RECORD(LISTF)%NAME LCELL TCELL=TAGS(KK) %IF TCELL=0 %THEN %START; ! NAME NOT SET TYPE=7; PTYPE=7 ROUT=0; NAM=0; ARR=0; ACC=4 I=-1; J=-1; K=-1; OLDI=-1 KFORM=0; SNDISP=0 %FINISH %ELSE %START LCELL==ASLIST(TCELL) KK=LCELL_S1 LCELL_S1=KK!X'8000'; ! SET 'NAME USED' BIT QQ=LCELL_S2 QQQ=LCELL_S3 PTYPE=KK>>16; USEBITS=KK>>14&3 OLDI=KK>>8&63; I=KK>>4&15; J=KK&15 SNDISP=QQ//X'10000' ACC=QQ&X'FFFF' K=QQQ//X'10000' KFORM=QQQ&X'FFFF' TYPE=PTYPE&15 ARR=PTYPE>>4&15 NAM=PTYPE>>8&15 ROUT=PTYPE>>12 %FINISH %END %ROUTINE REDUCE TAG !*********************************************************************** !* AS COPY TAG FOR NAME AT A(P) EXCEPT:- * !* 1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED * !*********************************************************************** COPY TAG(A(P)) %IF PTYPE=SNPT %THEN %START PTYPE=TSNAME(K); UNPACK ROUT=1 %FINISH; ! TO AVOID CHECKING PARAMS %END %ROUTINE REPLACE TAG(%INTEGER KK) %INTEGER P, Q P=TAGS(KK) Q=PTYPE<<16!USEBITS<<14!OLDI<<8!I<<4!J ASLIST(P)_S1=( Q) ASLIST(P)_S3=( K<<16!KFORM) %END %ROUTINE UNPACK TYPE=PTYPE&15 ARR=PTYPE>>4&15 NAM=PTYPE>>8&15 ROUT=PTYPE>>12 %END %ROUTINE PACK(%INTEGERNAME PTYPE) PTYPE=ROUT<<12!NAM<<8!ARR<<4!TYPE %END %ROUTINE PPJ(%INTEGER MASK,N) !*********************************************************************** !* PLANT A 'JCC MASK,PERMENTRY(N)' * !* IF MASK=0 THEN PLANT A JLK * !* IF MASK=-1 THEN PLANT A CALL TO PERM * !*********************************************************************** %INTEGER VAL, INSTRN, CODE CODE=OCODE(MASK) INSTRN=CODE<<24 VAL=PLABS(N) %IF CODE>6 %THEN INSTRN=INSTRN!3<<23 %ELSE %C INSTRN=INSTRN!(MASK&15)<<21 %IF VAL>0 %THEN INSTRN=INSTRN!((VAL-CA)//2)&X'3FFFF' %ELSE %C PUSH(PLINK(N),CA,INSTRN,0) PCONST(INSTRN) %IF CODE>6 %START %IF INCLUDE HANDCODE=NO %THEN %START %CYCLE VAL=0,1,7 GRUSE(VAL)=0 %REPEAT %FINISH %ELSE %START *LSQ_0 *LCT_GRUSE+4 *ST_(%CTB+0) *ST_(%CTB+4) %FINISH %FINISH %END %INTEGERFN XORYNB(%INTEGER USE,INF) !*********************************************************************** !* CHECKS IF XNB OR YNB SET UP. IF NOT DECIDES WHICH TO OVERWRITE * !*********************************************************************** %IF GRUSE(XNB)=USE %AND GRINF(XNB)=INF %THEN GRAT(XNB)=CA %C %AND %RESULT=XNB %IF GRUSE(CTB)=USE %AND GRINF(CTB)=INF %THEN GRAT(CTB)=CA %C %AND %RESULT=CTB %IF GRUSE(XNB)!GRUSE(CTB)=0 %THEN %START;! BOTH REGS ARE FREE %IF USE=3 %THEN %RESULT=CTB %RESULT=XNB %FINISH ! ! IF ONLY ONE FREE THEN NO PROBLEM %IF GRUSE(XNB)=0 %THEN %RESULT=XNB %IF GRUSE(CTB)=0 %THEN %RESULT=CTB ! ! BOTH ARE IN USE. THIS IS WORTH CAREFUL CONSIDERATION AND EXPERIMENT ! A VALUE TABLE MAY BE USE AS MAY LOOK AHEAD. CURRENTLY TRY LRU ! %IF GRAT(XNB)>24&15 %CYCLE I=0,7,7; ! ONLY ACC &BREG RELEVANT %IF GRUSE(I)=9 %AND (GRINF(I)=VAR %OR NAM#0) %THEN %C GRUSE(I)=0 %REPEAT %IF NAM=0 %AND GRUSE(REG)<=3 %THEN %C GRUSE(REG)=9 %AND GRINF(REG)=VAR %END %ROUTINE GET IN ACC(%INTEGER REG,SIZE,ACCESS,AREA,DISP) !*********************************************************************** !* LOADS THE REGISTER SPECIFIED ARRANGING FOR AUTOMATIC * !* STACKING WHEN THIS IS NEEDED * !* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR * !* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY * !* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS * !*********************************************************************** %INTEGER OPCODE %CONSTINTEGERARRAY GETCODE(0:7)=X'62',X'76',0(5),X'7A'; OPCODE=GETCODE(REG)+SIZE&6 ! %IF REGISTER(REG)>0 %THEN %START %IF REGISTER(REG)=2 %THEN BOOT OUT(REG) %ELSE %START %IF REG#ACCR %AND(REGISTER(ACCR)=1 %OR REGISTER(ACCR)=3)%C %THEN BOOT OUT(ACCR) CHANGE RD(REG) REGISTER(REG)=0 %IF REG=ACCR %THEN OPCODE=OPCODE-32 %ELSE OPCODE=OPCODE-40 %FINISH %FINISH PSORLF1(OPCODE,ACCESS,AREA,DISP) %IF ACCESS>=2 %THEN GRUSE(DR)=0 GRUSE(REG)=0 %END %END %IF ALLOW CODELIST=YES %THEN %START %ROUTINE PRINT USE %CONSTSTRING(3)%ARRAY REGS(0:7)="ACC"," DR","LNB","XNB", " PC","LTB","TOS"," B"; %CONSTSTRING(15)%ARRAY USES(0:15) =" NOT KNOWN "," I-RESULT ", " TEMPORARY "," PLTBASE ", " NAMEBASE "," LIT CONST ", " TAB CONST "," DESC FOR ", " RECD BASE "," LOCAL VAR ", " FN RESULT ", " ??? "(3)," SST BASE ", " RT PARAM "; %CONSTSTRING(11)%ARRAY STATE(-1:3)=%C " LOCKED "," FREE ", " I-RESULT "," TEMPORARY ", " RT-PARAM "; %INTEGER I %CYCLE I=0,1,7 %IF REGISTER(I)!GRUSE(I)#0 %START PRINTSTRING(REGS(I).STATE(REGISTER(I)). %C " USE = ".USES(GRUSE(I))) %IF 7<=GRUSE(I)<=10 %THEN PRINTNAME(GRINF(I)) %ELSE %C WRITE(GRINF(I),1) NEWLINE %FINISH %REPEAT %END %FINISH %END; ! OF BLOCK CONTAINING PASS3 %ROUTINE MESSAGE(%INTEGER N) !*********************************************************************** !* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT * !* 2 (LABEL INVALID OR SET TWICE) * !* 4 (SWITCH NAME NOT SET) * !* 5 (LABEL NAME IN EXPRSSN) * !* 7 (NAME SET TWICE) * !* 8 (INVALID NAME IN VALUE LIST) * !* 9 (INVALID PARAMETER SPECIFICATION) * !* 10 (PARAMETER INCORRECTLY SPECIFIED) * !* 11 (LABEL NOT SET) * !* 12 (LABEL NOT ACCESSIBLE) * !* 14 (TOO MANY ENDS) * !* 15 (MISSING ENDS) * !* 16 (NAME NOT SET) * !* 17 (NOT PROCEDURE NAME) * !* 18 (WRONG NO OF SUBSCRIPTS) * !* 19 (WRONG NO OF PARAMETERS) * !* 20 (PARAMETRIC ARRAY WRONG DIMENSION) * !* 21 (PARAMETRIC PROCEDURE NOT VALID) * !* 22 (ACTUAL PARAMETER NOT PERMITTED) * !* 23 (PROCEDURE NAME IN EXPRSSN) * !* 24 (VARIABLE IN BOOLEAN EXPRSSN) * !* 25 (FOR VARIABLE INCORRECT) * !* 26 (DIV OPERANDS NOT INTEGER) * !* 27 (LOCAL IN ARRAY BOUND) * !* 29 (INVALID NAME IN LEFTPART LIST) * !* 34 (TOO MANY LEVELS) * !* 35 (TOO MANY PROCEDURE LEVELS) * !* 37 (ARRAY TOO MANY DIMENSIONS) * !* 40 (DECLN MISPLACED) * !* 42 (BOOLEAN VARIABLE IN EXPRSSN) * !* 43 (ARRAY INSIDE OUT) * !* 47 (ILLEGAL ELSE) * !* 48 (SUB CHAR IN STMNT) * !* 57 (BEGIN MISSING) * !* 71 (UNACCEPTABLE SYMBOL) * !* 72 (NAME NOT IN DICTIONARY) * !* 73 (SUBSCRIPT UNACCEPTABLE) * !* 74 (NAME ALREADY IN DICTIONARY) * !* 75 (SPURIOUS DECIMAL POINT) * !* 76 (UNACCEPTABLE EXPONENT) * !* 77 (INTEGER CONSTANT TOO LARGE) * !* 78 (REAL CONSTANT TOO LARGE) * !* 79 (DECLN MISPLACED) * !* 80 (TYPE MISMATCH) * !* 98 (ADDRESSABILITY) * !* 99 (ADDRESSABILITY) * !* 102 (WORKFILE TOO SMALL) * !* 103 (NAMES TOO LONG) * !* 104 (TOO MANY NAMES) * !* 105 (PROGRAM WITH EXTERNAL PROCEDURE) * !* 106 (STRING CONST TOO LONG) * !* 107 (ASL EMPTY) * !* 108 (TOO MANY LEVELS) * !* 127 (SEE ALGOL MANUAL) * !*********************************************************************** %CONSTBYTEINTEGERARRAY WORD(0: 265)=0,%C 2, 1, 2, 4, 5, 4, 6, 7, 8, 4, 5, 1, 7, 9, 10, 7, 7, 4, 5, 0, 8, 12, 7, 9, 14, 9, 12, 16, 18, 0, 10, 16, 21, 23, 0, 11, 1, 8, 4, 0, 12, 1, 8, 25, 0, 14, 27, 28, 29, 0, 15, 30, 29, 0, 0, 16, 7, 8, 4, 0, 17, 8, 32, 7, 0, 18, 34, 35, 36, 37, 19, 34, 35, 36, 39, 20, 41, 43, 34, 44, 21, 41, 32, 8, 46, 22, 47, 16, 8, 48, 23, 32, 7, 9, 10, 24, 50, 9, 52, 10, 25, 54, 50, 55, 0, 26, 57, 58, 8, 60, 27, 62, 9, 43, 63, 29, 12, 7, 9, 64, 34, 27, 28, 67, 0, 35, 27, 28, 32, 67, 37, 43, 27, 28, 68, 40, 70, 71, 0, 0, 42, 52, 50, 9, 10, 43, 43, 73, 74, 0, 47, 75, 77, 0, 0, 48, 78, 79, 9, 80, 57, 81, 30, 0, 0, 71, 82, 84, 0, 0, 72, 7, 8, 9, 85, 73, 87, 82, 0, 0, 74, 7, 89, 9, 85, 75, 91, 93, 95, 0, 76, 82, 96, 0, 0, 77, 60, 98, 27, 100, 78, 101, 98, 27, 100, 79, 70, 71, 0, 0, 80, 102, 103, 0, 0, 98, 105, 0, 0, 0, 99, 105, 0, 0, 0, 102, 108, 27, 110, 0, 103, 111, 27, 112, 0, 104, 27, 28, 111, 0, 105, 113, 115, 116, 32, 106, 118, 119, 27, 112, 107, 120, 121, 0, 0, 108, 27, 28, 67, 0, 127, 122, 0, 0, 0 %CONSTINTEGERARRAY LETT(0: 124)=0,%C X'30222B00',X'25D60B13',X'13EF9000',X'4CB40000', X'52E91940',X'4EE9A0D0',X'382D2800',X'39F40000', X'25C00000',X'171094E7',X'38000000',X'25D60B13', X'10000000',X'582CA97F',X'3133A000',X'40320B4B', X'50B20000',X'4E051A4D',X'2461A25F',X'38000000', X'25C37CA5',X'14746640',X'4E051A4D',X'24A40000', X'04632CE7',X'244C2800',X'51EF0000',X'342EC800', X'15C49800',X'35339A5D',X'1C000000',X'424F1949', X'56450000',X'5E4F71C0',X'39E00000',X'3CC00000', X'4EA298E5',X'26149800',X'40320B4B',X'50B29800', X'40320B4B',X'52491800',X'06520E40',X'112D2BA7', X'25EE0000',X'582C4900',X'0474A858',X'40B26A69', X'50A40000',X'58324845',X'30A00000',X'09EF6143', X'38000000',X'19F20000',X'25C37CA5',X'14740000', X'11360000',X'3E05905D',X'12600000',X'25D429CB', X'48000000',X'31E30B00',X'09F57100',X'30A6A403', X'4A9F6267',X'50000000',X'30B62B26',X'112D2BA7', X'25EE9800',X'10A36380',X'35338303',X'0CA40000', X'25D3490A',X'3EB40000',X'258C29C3',X'30000000', X'15932800',X'4EA20000',X'0D019000',X'4E8D7500', X'08A74B80',X'55C118CB',X'4281130A',X'4F2D13D8', X'1123A25F',X'3832C800',X'4EA298E5',X'26140000', X'05922849',X'64000000',X'4E15925F',X'56600000', X'10A34B43',X'30000000',X'41E97500',X'17107B8B', X'3A800000',X'0DEE9D03',X'3A800000',X'30323940', X'48A16000',X'53302800',X'35336869',X'0D000000', X'04849167',X'4C224B13',X'53200000',X'5DF25993', X'30A00000',X'4DA16300',X'382D2CC0',X'31EE3800', X'424F3C83',X'34000000',X'5D344000',X'17142C9D', X'05800000',X'4E924B8E',X'0DEE9D00',X'066C0000', X'15B0A640',X'4CA5F859',X'1DECFB43',X'3AA16000' %INTEGER I,J,K,M,Q,S PRINTSTRING(" (") I=-4 %UNTIL N=WORD(I) %OR I= 261 %CYCLE; I=I+5; %REPEAT %CYCLE J=1,1,4 K=WORD(I+J) %IF K=0 %THEN %EXIT SPACE %UNLESS J=1 %UNTIL M&1=0 %CYCLE M=LETT(K); S=26 %UNTIL S<0 %CYCLE Q=M>>S&31; %IF Q=31 %THEN Q=-32 %IF Q\=0 %THEN PRINT SYMBOL(Q+64) S=S-5 %REPEAT K=K+1 %REPEAT %REPEAT PRINTSTRING(") ") %END %ROUTINE FAULT(%INTEGER N, FNAME) %INTEGER I, J, QP QP=Q NEWLINE %IF VMEB=YES %THEN FAULTMK(2); ! IDENTIFY ERROR MESSAGE %IF N=100 %THEN %START %WHILE CCLINES(LINE+1)<=QMAX %CYCLE; LINE=LINE+1; %REPEAT PRINTSTRING("* FAILED TO ANALYSE LINE ") WRITE(LINE, 2) %IF FNAME#0 %THEN MESSAGE(FNAME+70) NEWLINE; SPACES(5) FAULTY=FAULTY+1 T=0; J=0; S=0 %UNTIL (J=';' %AND Q>QMAX) %OR Q=LENGTH %OR %C (CC(Q)='E'+128 %AND CC(Q+1)='N'+128 %AND %C CC(Q+2)='D'+128) %OR(CC(Q)='B'+128 %AND %C CC(Q+1)='E'+128 %AND CC(Q+2)='G'+128 %AND CC(Q+3)= %C 'I'+128 %AND CC(Q+4)='N'+128 %AND Q>QMAX)%CYCLE I=J; J=CC(Q) %IF J>128 %AND I<128 %START SPACE PRINTSYMBOL(KYCHAR1) T=T+2 %FINISH %IF I>128 %AND J<128 %START PRINTSYMBOL(KYCHAR2) T=T+1 %FINISH T=T+1 %IF Q=QMAX %THEN %START S=T %IF S>=115 %THEN PRINTSYMBOL('!') %FINISH PRINT SYMBOL(J) Q=Q+1 %REPEAT %IF I>128 %THEN PRINTSYMBOL(KYCHAR2) %AND T=T+1 %IF Q=QMAX %THEN S=T+1; ! CASE OF POINTER AT END ! %IF S<115 %THEN %START NEWLINE; SPACES(S+4) PRINT SYMBOL('!') %FINISH NEWLINE %FINISH %ELSE %START PRINTSTRING("*"); WRITE(LINE, 4) I=3; I=3*LEVEL %IF LIST=0; SPACES(I) PARMOPT=1; FAULTY=FAULTY+1 INHCODE=1; ! STOP GENERATING CODE PRINTSTRING("FAULT"); WRITE(N, 2) MESSAGE(N) %IF N>100 %THEN %START PRINTSTRING(" DISASTER ") %STOP %FINISH PRINTNAME(FNAME) %UNLESS FNAME=0 %FINISH %IF VMEB=YES %THEN %START NEWLINE FAULTMK(1); ! ENDOFERROR MESSAGE %FINISH %ELSE %START %IF TTOPUT>=0 %THEN %START Q=QP SELECT OUTPUT(TTOPUT) TTOPUT=TTOPUT!X'80000000' FAULT(N, FNAME) FAULTY=FAULTY-1 NEWLINE SELECT OUTPUT(82) TTOPUT=TTOPUT&X'FFFF' %FINISH %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(DICTBASE+WRD(V)) %C .T %ELSE S=MESS(N) PRINTSTRING(" ? WARNING :- ".S." AT LINE NO") WRITE(LINE,1) %END %ROUTINE PRINTNAME(%INTEGER N) %INTEGER V, K SPACE; V=WRD(N) K=BYTEINTEGER(DICTBASE+V) %IF K=0 %THEN PRINTSTRING("???") %ELSE %C PRINTSTRING(STRING(DICTBASE+V)) %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 %INTEGERFN MORE SPACE !*********************************************************************** !* FORMATS UP SOME MORE OF THE ASL * !*********************************************************************** %INTEGER I,N N=ASL CUR BTM-1 ASL CUR BTM=ASL CUR BTM-(NNAMES+1)//8 %IF ASL CUR BTM<=1 %THEN ASL CUR BTM=1 CONST LIMIT=4*ASL CUR BTM-8 %IF ASL CUR BTM>=N %OR CONST PTR>CONST LIMIT %THEN FAULT(107,0) %CYCLE I=ASL CUR BTM,1,N-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(ASL CUR BTM)_LINK=0 ASL=N; %RESULT=N %END %ROUTINE PUSH(%INTEGERNAME CELL, %INTEGER S1, S2, S3) !*********************************************************************** !* PUSH A CELL CONTAINING THE 3 STREAMS OF INFORMATION GIVEN * !* ONTO THE TOP OF THE LIST POINTED AT BY CELL. * !*********************************************************************** %RECORD(LISTF)%NAME LCELL %INTEGER I I=ASL %IF I=0 %THEN I=MORE SPACE %IF INCLUDE HANDCODE=NO %THEN %START LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_LINK=CELL CELL=I LCELL_S1=S1 LCELL_S2=S2 LCELL_S3=S3 %FINISH %ELSE %START *LB_I *MYB_16 *ADB_ASLIST+4 *LCT_%B *LSS_(%CTB+3) *ST_ASL *LB_I *LSS_(CELL) *STB_(%DR) *LUH_S3 *LUH_S1 *ST_(%CTB+0) %FINISH %END %ROUTINE POP(%INTEGERNAME CELL, S1, S2, S3) !*********************************************************************** !* COPY THE INFORMATION FROM THE TOP CELL OF LIST 'CELL' INTO * !* S1,S2&S3 AND THEN POP THE LIST UP 1 CELL. EMPTYLIST GIVE -1S* !*********************************************************************** %RECORD(LISTF)%NAME LCELL %INTEGER I %IF INCLUDE HANDCODE = NO %THEN %START I=CELL LCELL==ASLIST(I) S1=LCELL_S1 S2=LCELL_S2 S3=LCELL_S3 %IF I# 0 %THEN %START CELL=LCELL_LINK LCELL_LINK=ASL ASL=I %FINISH %FINISH %ELSE %START *LB_(CELL) *STB_I *MYB_16 *ADB_ASLIST+4 *LCT_%B *LSD_(%CTB+0) *STUH_(S1) *LB_I *ST_(S2) *LSD_(%CTB+2) *STUH_(S3) *JAT_12, *ST_(CELL) *LSS_ASL *ST_(%CTB+3) *STB_ASL %FINISH END: %END %ROUTINE BINSERT(%INTEGERNAME TOP,BOT,%INTEGER S1,S2,S3) !*********************************************************************** !* INSERT A CELL AT THE BOTTOM OF A LIST * !* UPDATING TOP AND BOTTOM POINTERS APPROPIATELY * !*********************************************************************** %INTEGER I %RECORD(LISTF)%NAME LCELL I=ASL %IF I=0 %THEN I=MORE SPACE LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_S1=S1; LCELL_S2=S2 LCELL_S3=S3; LCELL_LINK=0 J=BOT %IF J=0 %THEN BOT=I %AND TOP=BOT %ELSE %START ASLIST(J)_LINK=I BOT=I %FINISH %END !%ROUTINE REPLACE123(%INTEGER CELL,S1,S2,S3) ! ASLIST(CELL)_S1=S1 ! ASLIST(CELL)_S2=S2 ! ASLIST(CELL)_S3=S3 !%END %ROUTINE MLINK(%INTEGERNAME CELL) CELL=ASLIST(CELL)_LINK %END %INTEGERFN FIND(%INTEGER LAB, LIST) !*********************************************************************** !* THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND * !* RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN * !* SCANNING LABEL LISTS. * !*********************************************************************** %WHILE LIST#0 %CYCLE %RESULT=LIST %IF LAB=ASLIST(LIST)_S2 LIST=ASLIST(LIST)_LINK %REPEAT %RESULT=-1 %END !%INTEGERFN FIND3(%INTEGER S3, LIST) !!*********************************************************************** !!* SEARCHES LIST FOR S3 IN STREAM 3 * !!* RETURNS CELL NO AS RESULT * !!*********************************************************************** ! %WHILE LIST#0 %CYCLE ! %RESULT=LIST %IF S3=ASLIST(LIST)_S3 ! LIST=ASLIST(LIST)_LINK ! %REPEAT ! %RESULT=-1 !%END %ROUTINE FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) !*********************************************************************** !* ALL THE FROMS RETURN INFO FROM CELLS OF A LIST WITHOUT * !* AFFECTING THE LIST IN ANY WAY. * !*********************************************************************** %RECORD(LISTF)%NAME LCELL LCELL==ASLIST(CELL) S1=LCELL_S1 S2=LCELL_S2 S3=LCELL_S3 %END %ROUTINE CLEAR LIST(%INTEGERNAME OPHEAD) !*********************************************************************** !* THROW AWAY A COMPLETE LIST (MAY BE NULL!) * !*********************************************************************** %INTEGER I, J I=OPHEAD; J=I %WHILE I#0 %CYCLE; J=I; I=ASLIST(J)_LINK; %REPEAT %IF J#0 %START ASLIST(J)_LINK=ASL ASL=OPHEAD; OPHEAD=0 %FINISH %END !%ROUTINE CONCAT(%INTEGERNAME LIST1, LIST2) !!*********************************************************************** !!* ADDS LIST2 TO BOTTOM OF LIST1 * !!*********************************************************************** !%INTEGER I,J ! I=LIST1; J=I ! %WHILE I#0 J=I %AND I=ASLIST(J)_LINK ! %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2 ! LIST2=0 !%END !%ROUTINE RETURN LIST(%INTEGERNAME TOP,BOT) !!*********************************************************************** !!* RETURN A WHOLE LIST TO ASL * !!*********************************************************************** !%INTEGER CELL,J ! %IF TOP#0 %START !! CELL=TOP !! %WHILE CELL#0 J=CELL %AND CELL=ASLIST(CELL)_LINK !! ABORT %IF J#BOT ! CELL=ASL ! ASL=TOP ! ASLIST(BOT)_LINK=CELL ! TOP=0 ! %FINISH !%END %ENDOFPROGRAM