!
! 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