compilers/algol/algol60fs.imp
!
! 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=YES
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',C
LLN=X'7C',LSS=X'62',SLSS=X'42',MPSR=X'32',STSF=X'5E',C
LUH=X'6A',STUH=X'4A',LSD=X'64',SLSD=X'44',PRCL=X'18', C
LSQ=X'66',SLSQ=X'46',STXN=X'4C',LCT=X'30',STCT=X'36'
CONSTINTEGER JUNC=X'1A',JLK=X'1C',CALL=X'1E',EXIT=X'38',JCC=2, C
JAT=4,JAF=6,DEBJ=X'24',CPSR=X'34',ESEX=X'3A'
CONSTINTEGER IAD=X'E0',ICP=X'E6',USH=X'C8',ISB=X'E2',IRSB=X'E4',C
OR=X'8C',UCP=X'C6',IMY=X'EA',IMDV=X'AE',AND=X'8A', C
ISH=X'E8',NEQ=X'8E'
CONSTINTEGER RAD=X'F0',RSB=X'F2',RRSB=X'F4',FLT=X'A8',RRDV=X'BC', C
RSC=X'F8',FIX=X'B8',RMY=X'FA',RCP=X'F6'
!
CONSTINTEGER MVL=X'B0',MV=X'B2'
CONSTBYTEINTEGERARRAY OCODE(-1:47)=X'1E',X'1C',2(14),X'1A',4(16),6(16);
! JLK=1C,J=1A,JCC=2,JAT=4,JAF=6
!
! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS
!
CONSTINTEGER ACCR=0,DR=1,LNB=2,XNB=3,PC=4,CTB=5,TOS=6,BREG=7
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
RECORDARRAY ASLIST(0:ASL)(LISTF)
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 THEN LINE=LINE+1
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<SIZE<MAXSIZE START
I=KEYCHK(WORD(1)&X'5F')
IF I&X'80000000'>>((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,<IMP>
*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,<OUT>
*INCA_=-1
*J_<BACK>
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,<NEXTBR>
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,<NOTLIT>
*LB_Q
*ICP_(CC+B )
*JCC_7,<FAIL1>
*ADB_1
*STB_Q
*J_<SUCC>
NOTLIT:
*ICP_1300
*JCC_10,<NOTBIP>
*ST_ITEM
->BIP(ITEM)
NOTBIP:
*ST_P
*LSQ_RA
*SLSQ_RR
*SLSQ_MARKER
*ST_TOS
*JLK_<SUBENTRY>
*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,<MCL1>
*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,<EXIT>
*STB_I
*LSS_B ; ! I TO ACC
*LB_TT
*CPB_7
*JCC_2,<SKIP>
*IMY_(HASH+B )
*IAD_JJ
*ST_JJ
SKIP:
*ADB_1
*STB_TT
*LSS_I
*ADB_NEXT
*ST_(LETT+B )
*J_<CYC>
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,<HOLE>
*LSD_ACCDES
*LD_DRDES
*INCA_B
*CPS_L =DR
*JCC_8,<FND>
*LB_KK
*CPIB_NNAMES
*JCC_7,<CYC1>
*LB_0
CYC2:
*STB_KK
*LB_(WRD+B )
*JAT_12,<HOLE>
*LSD_ACCDES
*LD_DRDES
*INCA_B
*CPS_L =DR
*JCC_8,<FND>
*LB_KK
*CPIB_JJ
*JCC_7,<CYC2>
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,<OFLOW>; ! 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<<KPP)&B'101100'#0 THEN N=N//4
IF INCLUDE HANDCODE=NO THEN START
CODE(PPCURR)=OPCODE!1
CODE(PPCURR+1)=X'80'!KP<<5!KPP<<2!(N>>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<<KPP)&B'101100'#0 THEN N=N//4
IF INCLUDE HANDCODE=NO THEN START
CODE(PPCURR)=OPCODE!1
CODE(PPCURR+1)=((4!KP)<<3!KPP)<<2!(N>>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 *
!***********************************************************************
RECORDNAME CELL (LISTF)
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-GLACABUFC
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<CONST PTR CYCLE
IF CTABLE(K)=C1 AND CONSTHOLE#K C
THEN D=4*K!X'80000000' AND RETURN
K=K+1
REPEAT
FINISH ELSE START
*LD_CTABLE
*LB_K
*SBB_1
*LSS_C1
AGN1:
*ADB_1
*CPB_CONSTPTR
*JCC_10,<SKIP>
*ICP_(DR +B )
*JCC_7,<AGN1>
*CPB_CONSTHOLE
*JCC_8,<AGN1>
*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 OR 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,<SKIP>
*ICP_(DR +B )
*JCC_8,<ON2>
*ADB_2
*J_<AGN2>
ON2:
*STB_K
*ADB_1
*LSS_(DR +B )
*ICP_C2
*JCC_8,<ON2A>
BACK2:
*ADB_1
*J_<AGN2A>
ON2A:
*LSS_K
*ICP_CONSTHOLE
*JCC_8,<BACK2>
*CPB_CONSTHOLE
*JCC_8,<BACK2>
*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
RECORDNAME CELL(LISTF)
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): ! <STMNT><S>
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): ! <TYPE'>%PROCEDURE<FPP><ETC>
->VDEC UNLESS A(P+2)=1
FAULT(40,0) UNLESS NMDECS(LEVEL)=0
BEGIN
RECORDNAME LCELL(LISTF)
INTEGER PNAME, EXTRN, Q, PP, PTYPEP, PARN, DISP, TYPEP, LINK, NP,C
LINEP, PE, PL, OPHEAD, AVHEAD, OPBOT
P=P+1
PP=P; PNAME=A(P+4); ! PROCEDURE NAME
EXTRN=P+3+A(P+3); ! TO OLABEL
PL=EXTRN
WHILE A(EXTRN)=1 THEN EXTRN=EXTRN+3
PE=EXTRN+1; ! TO ALT OF PROCSTMNT
EXTRN=A(PE)
IF LEVEL=1 AND CPRMODE=0 THEN CPRMODE=2 AND MAKE DECS(0,-1)
COPY TAG(PNAME); Q=K
LINEP=SNDISP
P=PP
UNLESS ROUT=1 AND OLDI=LEVEL THEN DECLARE PROC
P=PP
->L99 IF EXTRN<=3 OR J=14
IF LEVEL=1 THEN START
CPRMODE=2 IF CPRMODE=0
FAULT(105, PNAME) IF CPRMODE#2
JJ=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 THEN P=P+1; ! 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 <NAME>:=<DE><RESTOFDELIST>
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): ! <OLAB>:<SS>
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): ! <S>
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 <DECLIST>
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<OADEC>:=<DECLIST><CBPAIR><RESTOFOADEC> *
!* P<RESTOFOADEC>:=','<OADEC>,%NULL *
!***********************************************************************
P=P+1; PP=P; NNAMES=1; ! P TO START OF DECLIST
APARM=A(P)
WHILE A(P+1)=1 THEN APARM=APARM!A(P) AND C
P=P+2 AND NNAMES=NNAMES+1
APARM=1-APARM>>16
P=P+2; BP=ACC; PTYPEPP=PTYPEP
!
! NOW OUTPUT A DOPE VECTOR
!
AH4=DOPE VECTOR(BP, APARM, LENGTH, LB)+12
IF LB=0 AND J=1 THEN PTYPEPP=PTYPEPP+16;! SET ARR=2 NO DVM NEEDED
UNTIL NNAMES=0 CYCLE
K=A(PP)&X'FFFF'
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
SPEC DECLARE
QQ=A(Q)
WHILE QQ#0 CYCLE
Q=Q+QQ-1
IF LN=0 THEN LINE=SAVELINE C
ELSE LINE=A(Q-LN)
P=Q; DECLARE
Q=Q+INC
QQ=A(Q)
REPEAT
END
END
ROUTINE DECLARE LAB
!***********************************************************************
!* THIS ROUTINE DECLARES ALL THE LABELS SO THAT A %GOTO CAN *
!* BE CLASSIFIED AS INTERNAL OR EXTERNAL IMMEDIATELY *
!***********************************************************************
K=A(P+2); ! K IS NAME
PTYPE=6; SNDISP=0
KFORM=0; J=0; ACC=0
! TEST NST
STORE TAG(K, 0)
END
ROUTINE DECLARE SWITCH
!***********************************************************************
!* P IS TO ALT OF P(SS) *
!* THIS ROUTINE RESERVES SPACE IN THE SST FOR THE SWITCH AND *
!* DECLARES THE NAME BUT NO CODE IS GENERERATED *
!***********************************************************************
INTEGER I, N, MARK, D0, D1, SIMPLE, SWNAME
SWNAME=A(P+2)&X'FFFF'; N=0; SIMPLE=1
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 THEN P=P+3; ! 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
RECORDNAME LC(LISTF)
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 *
!***********************************************************************
RECORDNAME LC(LISTF)
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<ADECLN> IN *
!* *
!* P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN> *
!* P<BPAIR> = <CBPAIR>,'('<EXPR>':'<EXRR><RESTOFBP>*')' *
!* *
!* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR *
!* DOPE-VECTOR IN THE CONSTANT AREA AND MAY HAVE THEIR SPACE *
!* ALLOCATED AT COMPILE TIME AMONG THE SCALARS *
!* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET *
!* THEIR SPACE OFF THE STACK AT RUN TIME *
!* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS *
!* SYSTEM STANDARDS *
!***********************************************************************
ROUTINESPEC CLAIM AS
INTEGER DVDISP, PP, DVF, ELSIZE, TOTSIZE, R, LBND, PTYPEPP, C
PTYPEP, ARRP, NN, ND, II, JJ, QQ, CDV, D0, D1, DESC, APARM
SET LINE IF PARMLINE#0
SAVE AUX STACK(1)
TYPE=A(P)
TYPE=2 IF TYPE=4
NAM=0; ROUT=0; ADFLAG=1
P=P+5
ARRP=1; ARR=ARRP; PACK(PTYPEP)
ELSIZE=BYTES(TYPE)
DESC=SIZECODE(TYPE)<<27
START: NN=1; APARM=A(P); ! FIND NO OF NAMES IN NAMELIST
PP=P; CDV=0; PTYPEPP=PTYPEP
WHILE A(P+1)=1 THEN P=P+2 AND APARM=APARM!A(P) AND NN=NN+1
APARM=1-APARM>>16; ! 0 IS PASSED ,1 NOT PASSED
P=P+2; ! TO ALT OF P<BPAIR>
IF A(P)=1 THEN ->CONSTDV; ! P<BPAIR> =<CBPAIR>
!
! 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<X'1FFFF' THEN PSF1(LSS,0,TOTSIZE) ELSESTART
STORE CONST(D,4,TOTSIZE,0)
PF1(LSS,0,PC,D)
FINISH
FINISH ELSE PSF1(LSS,1,DVDISP+8)
GRUSE(ACCR)=0; GRINF(ACCR)=0
IF PARMCHK#0 THEN START
PLANT(X'4998'); ! ST TOS
PSF1(LB,2,AUXSBASE(LEVEL)&X'3FFFF')
PLANT(X'E19C'); ! IAD BREG
GRUSE(BREG)=0; GRINF(BREG)=0
FINISH ELSE PSF1(IAD,2,AUXSBASE(LEVEL)&X'3FFFF')
PLANT(X'49DC'); ! ST (%DR) STORE UPDATED POINTER
IF PARMOPT#0 THEN PF1(ICP,1,0,2) AND PPJ(2,8)
IF PARMCHK#0 START
PF1(LDTB,0,PC,PARAM DES(5))
PLANT(X'7798'); ! LDB TOS
PLANT(X'739C'); ! LDA BREG
PF2(MVL,1,1,0,0,UNASSPAT&255)
FINISH
END
END
INTEGERFN DOPE VECTOR(INTEGER ELSIZE, APARM, INTEGERNAME ASIZE, LB)
!***********************************************************************
!* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE *
!* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT*
!* EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE *
!* P IS TO ALT (MUST BE 1!) OF P<CBPAIR> *
!* 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
RECORDNAME LCELL(LISTF)
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
RECORDNAME LCELL(LISTF)
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<X'3FFF' CYCLE
LCELL==ASLIST(TAGS(JJ))
S1=LCELL_S1; S2=LCELL_S2
S3=LCELL_S3; S4=LCELL_LINK
LCELL_LINK=ASL; ASL=TAGS(JJ)
TAGS(JJ)=S4&X'3FFFF'
IF S1&X'C000'=0 THEN WARN(2,JJ)
PTYPE=S1>>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<J<=ASLMAX CYCLE
POP(J, INSRN, AT, W1)
EXIT UNLESS 0<AT<CA
W3=CA-AT
W3=W3//2+1 IF INSRN>>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 <NAME> IN <NAME><HOLE> *
!***********************************************************************
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<OLABEL> *
!***********************************************************************
WHILE A(P)=1 THEN P=P+1 AND CLABEL
P=P+1
END
ROUTINE CBLK(INTEGER BLKTYPE)
!***********************************************************************
!* SUCK IN A BLOCK OCCURRING IN IF..THEN ETC *
!***********************************************************************
INTEGER I,OLDLEV,KK
KK=0
CYCLE I=P,1,P+5; KK=KK+A(I); REPEAT
IF KK=0 THEN BLKTYPE=-3
PTYPE=BLKTYPE
OLDLEV=LEVEL; RHEAD(-1)
IF BLKTYPE=-3 THEN START
AUXSBASE(LEVEL)=AUXSBASE(LEVEL-1)
FINISH ELSE START
RDISPLAY(-1)
MAKE DECS(P,-1)
FINISH
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 THEN P=P+1 AND CLABEL
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 <OPTCOM> IN THE SEQUENCE:- *
!* '%BEGIN'<OPTCOM><OLABEL><STMNT> *
!***********************************************************************
INTEGER I,OLDLEVEL
OLDLEVEL=LEVEL
WHILE A(P)=1 THEN P=P+1; ! PAST ANY COMMENTS
P=P+1; COLABEL
! LINE=LINE+1
SET LINE IF PARMLINE#0
CSTMNT
CYCLE
I=NEXTP; NEXTP=NEXTP+A(NEXTP)
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 THEN P=P+1 AND CLABEL
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 THEN FBP=FBP+3
FBP=FBP+1
FINISH
FORNAME=A(P+3)
FP=P+3; P=FP+1
COPYTAG(FORNAME)
FCMPLX=ROUT!NAM!ARR!PARMCHK!(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 <EXPR><RESTOFFLE> *
!***********************************************************************
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 <BE>
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 <BE> %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
RECORDNAME LCELL(LISTF)
->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<NAME> UP ONE PLACE TO OVERWRITE THE ALT OF P<ASS>
! SO THAT IT IS NEXT TO P<APP> 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 <DE>
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<DE> 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<SDE>:=<NAME><LABAPP>,'('<DE>')' *
!* 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<DE>:-%IF<BEXP>%THEN<SDE>%ELSE<DE>,<SDE> *
!* 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<OP>
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)
RECORDNAME OPND1, OPND2, OPND3(RD)
RECORDNAME LCELL(LISTF)
INTEGER C, D, KK, JJ, OPCODE, COMM, XTRA, STPTR, RDFORM, EVALREG, C
PP, PT, JJJ, LOADREG
ROUTINESPEC FLOAT(RECORDNAME OPND)
ROUTINESPEC TYPE CHK(INTEGER MODE)
ROUTINESPEC FIX(RECORDNAME OPND,INTEGER MODE)
ROUTINESPEC CTOP(INTEGERNAME A)
ROUTINESPEC PUT
ROUTINESPEC STARSTAR
ROUTINESPEC REXP
ROUTINESPEC LOAD(RECORDNAME 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<<JJ)&X'CC098000'#0 THEN TYPE CHK((JJ+2)>>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(RECORDNAME 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
RECORDSPEC OPND(RD)
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)<IMAX THEN VAL1=INT(RVAL1)
FINISH ELSE VAL1=OPND1_D AND RVAL1=VAL1
IF OPND2_PTYPE=2 THEN START
INTEGER(ADDR(RVAL2))=OPND2_D
INTEGER(ADDR(RVAL2)+4)=OPND2_XTRA
IF MOD(RVAL2)<IMAX THEN VAL2=INT(RVAL2)
FINISH ELSE VAL2=OPND2_D AND RVAL2=VAL2
->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(RECORDNAME OPND1)
!***********************************************************************
!* PLANT CODE TO CONERT OPERAND1 FROM FIXED TO FLOATING *
!***********************************************************************
RECORDSPEC OPND1(RD)
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(RECORDNAME 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 *
!***********************************************************************
RECORDSPEC OPND(RD)
IF OPND_FLAG=1 THEN START
INTEGER(ADDR(CVALUE))=OPND_D
INTEGER(ADDR(CVALUE)+4)=OPND_XTRA
IF MOD(CVALUE)<IMAX START
OPND_D=INT(CVALUE)
TYPE=1; OPND_PTYPE=1
RETURN
FINISH
FINISH
LOAD(OPND,ACCR,2); ! LOAD TO ANY FP REG
IF REGISTER(BREG)#0 THEN BOOT OUT(BREG)
IF MODE=0 THEN PF1(RAD,0,PC,SPECIAL CONSTS(0));! 0.5
! PSF1(RSC,0,55) %IF PARMOPT#0
! PSF1(RSC,0,-55) %IF PARMOPT#0
! PF1(X'B8',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)
PCLOD(100-PARMOPT,103)
GRUSE(ACCR)=0; GRUSE(BREG)=0
OPND_PTYPE=1; TYPE=1
END
ROUTINE STARSTAR
!***********************************************************************
!* PLANT IN-LINE CODE FOR EXPONENTIATION *
!***********************************************************************
INTEGER TYPEP,WORK,C,EXPWORK,VALUE
PTYPE=OPND1_PTYPE; ! INSPECT THE OPERAND
TYPE=PTYPE&7
TYPEP=TYPE
IF TYPEP=2 THEN OPCODE=OPCODE>>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
RECORDNAME LCELL(LISTF)
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
RECORDNAME LCELL(LISTF)
!
! 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<LEVEL
PLUG(1,AT,INSTRN!(CA-AT)//2)
REPEAT
LCELL_S2=0
IF LAB> 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
RECORDNAME LCELL(LISTF)
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<<SNNO&CODED=0 THEN C
REFNAME="S#" ELSE REFNAME="S#E"
REFNAME=REFNAME.SNXREFS(SNNO)
TESTAPP(NAPS); ! COUNT ACTUAL PARAMETERS
PIN=P; P=P+1
SNPTYPE=TSNAME(SNNO)
SNINF=SNINFO(SNNO)
XTRA=SNINF&X'FFFF'
POINTER=(SNINF>>16)&255
FLAG=SNINF>>24
!
! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH.
! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL
! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES
! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME.
! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER
!
IF Z=13 AND FLAG&X'80'=0 START ; ! RT PARAM
FLAG=X'80'; ! GIVE FORMAL PROCEDURE
IF SNNO=1 THEN POINTER=25 ELSE POINTER=1
IF SNNO=16 OR SNNO=52 THEN POINTER=0
IF SNNO=40 THEN POINTER=16
FINISH
!
IF FLAG&X'80'#0 THEN START
CXREF(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<<Z
IF JJ&XTRA=0#Z THEN START ; ! ILLEGAL USE
ERRNO=23
->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 %<TYPE>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)
RECORDNAME LCELL(LISTF)
FNAME=A(P); NAMEP=FNAME
TCELL=TAGS(FNAME)
IF TCELL<=0 THEN START
FAULT(16, FNAME)
I=LEVEL; J=0; K=FNAME
KFORM=0; SNDISP=0; ACC=4
PTYPE=7; STORE TAG(K, N)
N=N+4; COPY TAG(FNAME)
LEVELP=I; DISPP=K
FINISH ELSE START
LCELL==ASLIST(TCELL)
KK=LCELL_S1; LCELL_S1=KK!X'8000'
PTYPE=KK>>16; TYPE=PTYPE&7
OLDI=KK>>8&15; I=KK>>4&15; LEVELP=I
J=KK&15
K=LCELL_S3>>16; DISPP=K
FINISH
JJ=J; JJ=0 IF JJ=15
->NOT SET IF TYPE=7
IF (Z=0 OR Z=13) AND PTYPE>>12=0 THEN FAULT(17,FNAME) C
AND ->NOT SET
->ARRHEAD IF Z=12
->RTNAME IF Z=13
->RTCALL IF PTYPE>>12#0
->SW(TYPE)
SW(6):
SW(0):
SW(4): !RECORD FORMAT NAME
ILLEGAL TYPE:
FAULT(5, FNAME)
SW(7):
NOT SET: P=P+1; ! NAME NOT SET
NEST=0; BASE=I; DISP=K; ACCESS=0
PTYPE=1; TYPE=1
SKIP APP; RETURN
ARRHEAD: ! SET BASE & DISP FOR ARRAYHEAD
BASE=I; ACCESS=0; DISP=K; AREA=-1
NO APP; RETURN
RTNAME: ! LOAD ADDR FOR RT-TYPE
IF PTYPE=SNPT THEN CSNAME(Z, REG) AND P=P+1 AND RETURN
DISP=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=<NAME><APP>
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
RECORDNAME LCELL(LISTF)
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<EXP>:='%IF'<BEXPR>'%THEN'<SIMPEXP>'%ELSE'<EXP>,<SIMPEXP> *
!* P<BEXP>:='%IF'<BEXPR>'%THEN'<SBEXPR>'%ESLE'<BEXPR> *
!***********************************************************************
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 <HOLE><+'><OPERAND><RESTOFEXRN> *
!* OR P TO <SBEXPR> WHERE :- *
!* P<SBEXPR>:=<BTERM><RESTOFSBEXPR> *
!***********************************************************************
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<BOPERAND>
->ALT(BOP+MODE<<2)
ALT(1): ! <NAME> <APP>
ALT(6): ! <BOOLEAN NAME><APP>
P=P+1; SKIP APP; ->END
ALT(2): ! <ARIRHMETIC CONSTANT>
P=P+A(P)+1
->END
ALT(7): ! <BOOLEAN CONSTANT>
P=P+1; ->END
ALT(3): ! '('<EXPRN>')'
ALT(8): ! '('<BEXPR>')'
SKIP EXP(MODE); ->END
ALT(5): ! <EXPR><COMP><EXPR>
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<APP>. *
!***********************************************************************
INTEGER ALT, PIN
PIN=P; ALT=A(P)
IF ALT#3 THEN START
IF ALT=2 THEN START
P=P+1+A(P+1)
WHILE A(P)=1 THEN P=A(P+2)+P+2
FINISH ELSE START
WHILE A(P)=1 THEN P=P+1 AND P=P+A(P)
FINISH
FINISH
P=P+1
END
ROUTINE TEST APP(INTEGERNAME NUM)
!***********************************************************************
!* THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS *
!* WHICH IT RETURNS IN NUM. *
!***********************************************************************
INTEGER PP, Q
Q=0; PP=P; P=P+1; ! P ON NAME AT ENTRY
IF A(P)=2 THEN START
Q=1; P=P+1+A(P+1)
WHILE A(P)=1 THEN Q=Q+1 AND P=P+2+A(P+2)
FINISH ELSE START
WHILE A(P)=1 CYCLE ; ! NO (MORE) PARAMETERS
P=P+1; Q=Q+1
P=P+A(P)
REPEAT
FINISH
P=PP; NUM=Q
END
ROUTINE TEST ASS(INTEGER REG)
!***********************************************************************
!* TEST ACC OR B FOR THE UNASSIGNED PATTERN *
!***********************************************************************
INTEGER OPCODE
IF REG=BREG THEN OPCODE=CPB ELSE OPCODE=UCP
PF1(OPCODE,0,PC,PLABS(1))
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
RECORDNAME R(RD)
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
RECORDNAME OPND(RD)
RR=REGISTER(REG)
! ABORT %UNLESS 1<=RR<=3
OPND==RECORD(OLINK(REG))
IF RR=1 THEN START ; ! CHANGE RESULT DESCRIPTOR
! ABORT %UNLESS OPND_FLAG=9 %AND OPND_XB>>4=REG
OPND_FLAG=8; ! CHANGE TO 'STACKED'
OPND_XB=TOS<<4
FINISH
IF RR=2 START
OPND_FLAG=7; OPND_XB=LNB<<4
FINISH
END
ROUTINE STORE TAG(INTEGER KK, SLINK)
INTEGER Q, QQ, QQQ, I
RECORDNAME LCELL(LISTF)
Q=TAGS(KK)
IF 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
RECORDNAME LCELL(LISTF)
TCELL=TAGS(KK)
IF TCELL=0 THEN START ; ! NAME NOT SET
TYPE=7; PTYPE=7
ROUT=0; NAM=0; ARR=0; ACC=4
I=-1; J=-1; K=-1; OLDI=-1
KFORM=0; SNDISP=0
FINISH ELSE START
LCELL==ASLIST(TCELL)
KK=LCELL_S1
LCELL_S1=KK!X'8000'; ! SET 'NAME USED' BIT
QQ=LCELL_S2
QQQ=LCELL_S3
PTYPE=KK>>16; USEBITS=KK>>14&3
OLDI=KK>>8&63; I=KK>>4&15; J=KK&15
SNDISP=QQ//X'10000'
ACC=QQ&X'FFFF'
K=QQQ//X'10000'
KFORM=QQQ&X'FFFF'
TYPE=PTYPE&15
ARR=PTYPE>>4&15
NAM=PTYPE>>8&15
ROUT=PTYPE>>12
FINISH
END
ROUTINE REDUCE TAG
!***********************************************************************
!* AS COPY TAG FOR NAME AT A(P) EXCEPT:- *
!* 1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED *
!***********************************************************************
COPY TAG(A(P))
IF PTYPE=SNPT THEN START
PTYPE=TSNAME(K); UNPACK
ROUT=1
FINISH ; ! TO AVOID CHECKING PARAMS
END
ROUTINE REPLACE TAG(INTEGER KK)
INTEGER P, Q
P=TAGS(KK)
Q=PTYPE<<16!USEBITS<<14!OLDI<<8!I<<4!J
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)<GRAT(CTB) THEN RESULT =XNB
RESULT =CTB
END
INTEGERFN SET XORYNB(INTEGER WHICH,RLEV)
!***********************************************************************
!* SET EXTRA NAME BASE TO ADDRESS ROUTINE LEVEL 'RLEV' *
!* RLEV=0 FOR OWNS, =-1 FOR THE PLT THESE ARE THE SAME! BUT CODED*
!* SEPARATELY SO THAT THEY CAN BE SEPARATED IF NECESSARY *
!***********************************************************************
INTEGER USE,INF,OFFSET
ABORT UNLESS -1<=RLEV<=RLEVEL
IF RLEV<=0 THEN USE=3 AND INF=0 ELSE USE=4 AND INF=RLEV
IF WHICH<=0 THEN WHICH=XORYNB(USE,INF)
IF GRUSE(WHICH)=USE AND GRINF(WHICH)=INF THEN C
GRAT(WHICH)=CA AND RESULT =WHICH
OFFSET=PTR OFFSET(RLEV)
PSF1(LDCODE(WHICH),1,OFFSET)
GRUSE(WHICH)=USE; GRINF(WHICH)=INF; GRAT(WHICH)=CA
RESULT =WHICH
END
ROUTINE ODDALIGN
!***********************************************************************
!* SETS N TO ODD WORD BOUNDARY. SINCE PRECALL ALSO SETS SF TO ODD *
!* WORD BOUNDARY THIS MEANS 64 BIT QUANTITIES ARE 64 BIT ALIGNED *
!* AND CAN BE REFERNCED IN A SINGL CORE CYCLE *
!***********************************************************************
IF N&7=0 THEN RETURN WSP(N,1) AND N=N+4
END
INTEGERFN PTROFFSET(INTEGER RLEV)
!***********************************************************************
!* RETURNS OFFSET FROM LNB OF RELEVANT ITEM IN THE CURRENT DISPLAY *
!* WHICH ENABLES TEXTTUAL LEVEL 'RLEV' TO BE ADDRESSED *
!* A FUNCTION IS USED TO ALLOW CHANGES IN THE DISPLAY FORMAT *
!***********************************************************************
IF RLEV<=0 THEN RESULT =16
RESULT =DISPLAY(RLEVEL)+(RLEV-1)<<2
END
INTEGERFN AREA CODE
!***********************************************************************
!* RETURNS THE AREA CODE FOR ROUTINE LEVEL 'BASE' LOADING *
!* XNB WHERE THIS IS NEEDED *
!***********************************************************************
IF AREA<0 THEN START
IF BASE=RLEVEL THEN AREA=LNB AND RESULT =LNB;! LOCAL LEVEL
AREA=SET XORYNB(-1,BASE)
FINISH
RESULT =AREA
END
ROUTINE NOTE ASSMENT(INTEGER REG,VAR)
!***********************************************************************
!* NOTES THE ASSIGNMENT TO SCALAR VARIABLE 'VAR'. REMOVES ALL *
!* OLD COPIES FROM THE REGISTERS. IF VAR IS A SUBSTITUION *
!* PARAMETER ALL VARIABLES ARE REMOVED BECAUSE OF POSSIBLE SIDE *
!* EFFECTS. *
!***********************************************************************
INTEGER I,NAM
I=TAGS(VAR)
NAM=ASLIST(I)_S1>>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 THEN I=I+5
CYCLE J=1,1,4
K=WORD(I+J)
IF K=0 THEN EXIT
SPACE UNLESS J=1
UNTIL M&1=0 CYCLE
M=LETT(K); S=26
UNTIL S<0 CYCLE
Q=M>>S&31;
IF Q=31 THEN Q=-32
IF Q¬=0 THEN PRINT SYMBOL(Q+64)
S=S-5
REPEAT
K=K+1
REPEAT
REPEAT
PRINTSTRING(") ")
END
ROUTINE FAULT(INTEGER N, FNAME)
INTEGER I, J, QP
QP=Q
NEWLINE
IF VMEB=YES THEN FAULTMK(2); ! IDENTIFY ERROR MESSAGE
IF N=100 THEN START
WHILE CCLINES(LINE+1)<=QMAX THEN LINE=LINE+1
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. *
!***********************************************************************
RECORDNAME LCELL(LISTF)
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*
!***********************************************************************
RECORDNAME LCELL(LISTF)
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,<END>
*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
RECORDNAME LCELL(LISTF)
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. *
!***********************************************************************
RECORDNAME LCELL(LISTF)
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 THEN J=I AND I=ASLIST(J)_LINK
IF J#0 START
ASLIST(J)_LINK=ASL
ASL=OPHEAD; OPHEAD=0
FINISH
END
!%ROUTINE CONCAT(%INTEGERNAME LIST1, LIST2)
!!***********************************************************************
!!* ADDS LIST2 TO BOTTOM OF LIST1 *
!!***********************************************************************
!%INTEGER I,J
! I=LIST1; J=I
! %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK
! %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2
! LIST2=0
!%END
!%ROUTINE RETURN LIST(%INTEGERNAME TOP,BOT)
!!***********************************************************************
!!* RETURN A WHOLE LIST TO ASL *
!!***********************************************************************
!%INTEGER CELL,J
! %IF TOP#0 %START
!! CELL=TOP
!! %WHILE CELL#0 %THEN J=CELL %AND CELL=ASLIST(CELL)_LINK
!! ABORT %IF J#BOT
! CELL=ASL
! ASL=TOP
! ASLIST(BOT)_LINK=CELL
! TOP=0
! %FINISH
!%END
ENDOFPROGRAM