/*
THIS IS THE OPTIMIZING VERSION OF THE XPL COMPILER, PREPARED BY R. A. VOWELS

 X          X          CCCCC               OOOOO            M         M
  X        X          C     C             O     O           MM       MM
   X      X          C       C           O       O          M M     M M
    X    X          C         C         O         O         M  M   M  M
     X  X           C                   O         O         M   M M   M
      XX            C                   O         O         M    M    M
      XX            C                   O         O         M         M
     X  X           C                   O         O         M         M
    X    X          C         C         O         O         M         M
   X      X          C       C           O       O          M         M
  X        X          C     C             O     O           M         M
 X          X          CCCCC               OOOOO            M         M


                       THE COMPILER FOR   X P L


W. M. MCKEEMAN         J. J. HORNING           D. B. WORTMAN

INFORMATION &          COMPUTER SCIENCE        COMPUTER SCIENCE
COMPUTER SCIENCE,      DEPARTMENT,             DEPARTMENT,

UNIVERSITY OF          STANFORD                STANFORD
CALIFORNIA AT          UNIVERSITY,             UNIVERSITY,

SANTA CRUZ,            STANFORD,               STANFORD,
CALIFORNIA             CALIFORNIA              CALIFORNIA
95060                  94305                   94305

DEVELOPED AT THE STANFORD COMPUTATION CENTER, CAMPUS FACILITY,   1966-69
AND THE UNIVERSITY OF CALIFORNIA COMPUTATION CENTER, SANTA CRUZ, 1968-69.

The Optimizing version of XPL was delevoped by:

R. A. Vowels, formerly of
Department of Computer Science
Royal Melbourne Institute of Technology,
124 La Trobe Street,
MELBOURNE 3000
Victoria
AUSTRALIA.

email address is now: robin_v@bigpond.com

Outline:
        This optimizing XCOM compiler is a standard implementation of XPL and is
        based on McKeeman, Horning, and Wortman's improved XCOM (which employs
        hashed symbol table generation).  It includes the extra built-in
        function COREHALFWORD.

        The following areas have been optimized:  procedure calls when the
        argument and corresponding parameter are of the same type, and when the
        argument is a constant; constant subscripts; use of CORELHALFWORD and
        COREWORD; string constants of length one; iterative DO statements by
        transferring code to the end of the loop.

        String constants of length one do not require a descriptor, hence more
        descriptors are available for string variables.  Comparison operations
        are treated as commutative, and an improved Commute algorithm is used.
        Halfword instructions are generated for BIT(16) variables.

        These areas have been improved or re-written:  calls on OUTPUT,
        catenation, integer-to-string conversion, multiply, divide, and MOD.  An
        emitter for SS-type instructions has been added.

        The compiler achieves an 11% reduction in object code compiling itself,
        an 11% increase in compilation rate, a 55% increase in compilation speed
        when the $ E toggle is set.  Special treatment for catenating a string to
        an integer substantially decreases consumption of the free string area,
        and decreases string moves.  The latter improvement is most noticeable
        on small core machines.

        Core requirements:  less than the improved XCOM on which it is based
        (approx.  98000 bytes).  Symbol table size is 468.

ports:        IBM System 370
portability:  The compiler is written in XPL.  The code generators are
              machine-specific.

This version distributed by Robin Vowels.  Date: 11 November 1993.
                                                 11 December 1998.

DISTRIBUTED THROUGH THE SHARE ORGANIZATION.
                                                                              */

   /*  FIRST WE INITIALIZE THE GLOBAL CONSTANTS THAT DEPEND UPON THE INPUT
      GRAMMAR.  THE FOLLOWING CARDS ARE PUNCHED BY THE SYNTAX PRE-PROCESSOR  */

   DECLARE NSY LITERALLY '91', NT LITERALLY '42';
   DECLARE V(NSY) CHARACTER INITIAL ('<ERROR: TOKEN = 0>', ';', ')', '(', ',',
      ':', '=', '|', '&', '^', '<', '>', '+', '-', '*', '/', 'IF', 'DO', 'TO',
      'BY', 'GO', '||', '_|_', 'END', 'BIT', 'MOD', 'THEN', 'ELSE', 'CASE',
      'CALL', 'GOTO', 'WHILE', 'FIXED', 'LABEL', 'RETURN', 'DECLARE', 'INITIAL',
      '<STRING>', '<NUMBER>', 'PROCEDURE', 'LITERALLY', 'CHARACTER',
      '<IDENTIFIER>', '<TYPE>', '<TERM>', '<GROUP>', '<GO TO>', '<ENDING>',
      '<PROGRAM>', '<REPLACE>', '<PRIMARY>', '<VARIABLE>', '<BIT HEAD>',
      '<CONSTANT>', '<RELATION>', '<STATEMENT>', '<IF CLAUSE>', '<TRUE PART>',
      '<LEFT PART>', '<ASSIGNMENT>', '<EXPRESSION>', '<GROUP HEAD>',
      '<BOUND HEAD>', '<IF STATEMENT>', '<WHILE CLAUSE>', '<INITIAL LIST>',
      '<INITIAL HEAD>', '<CASE SELECTOR>', '<STATEMENT LIST>',
      '<CALL STATEMENT>', '<PROCEDURE HEAD>', '<PROCEDURE NAME>',
      '<PARAMETER LIST>', '<PARAMETER HEAD>', '<LOGICAL FACTOR>',
      '<SUBSCRIPT HEAD>', '<BASIC STATEMENT>', '<GO TO STATEMENT>',
      '<STEP DEFINITION>', '<IDENTIFIER LIST>', '<LOGICAL PRIMARY>',
      '<RETURN STATEMENT>', '<LABEL DEFINITION>', '<TYPE DECLARATION>',
      '<ITERATION CONTROL>', '<LOGICAL SECONDARY>', '<STRING EXPRESSION>',
      '<DECLARATION ELEMENT>', '<PROCEDURE DEFINITION>',
      '<DECLARATION STATEMENT>', '<ARITHMETIC EXPRESSION>',
      '<IDENTIFIER SPECIFICATION>');
   DECLARE V_INDEX(12) BIT(16) INITIAL (1,16,22,26,31,34,35,37,39,42,
      42, 42, 43);
   DECLARE C1(NSY) BIT(86) INITIAL (
      "(2) 00000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 02000 00000 00000 02200 20220 00202 20002 20000 002",
      "(2) 02222 02222 22222 20022 02003 22000 00330 02000 030",
      "(2) 00030 00003 00330 00000 00000 00000 00000 00330 003",
      "(2) 00030 00002 00220 00000 00000 00000 00000 00220 003",
      "(2) 02000 00000 00000 02200 20020 00002 20002 20002 002",
      "(2) 00020 00002 00220 00000 00000 00000 00000 00220 002",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 00010 01000 11110 00000 00000 00000 00000 00110 001",
      "(2) 00020 01000 00220 00000 00000 00000 00000 00220 002",
      "(2) 00020 01000 00220 00000 00000 00000 00000 00220 002",
      "(2) 00010 00000 00000 00000 00000 00000 00000 00110 001",
      "(2) 00010 00000 00000 00000 00000 00000 00000 00110 001",
      "(2) 00010 00000 00000 00000 00000 00000 00000 00110 001",
      "(2) 00010 00000 00000 00000 00000 00000 00000 00110 001",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 01000 00000 00000 00000 00000 00010 01000 00000 001",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 003",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 00000 00000 00000 00010 00000 00000 00000 00000 000",
      "(2) 00010 00000 00110 00000 00000 00000 00000 00110 001",
      "(2) 01000 00000 00000 01100 10000 00001 10001 10000 001",
      "(2) 02000 00000 00000 00000 00000 00000 00000 00000 001",
      "(2) 00010 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 00010 00000 00000 00000 00000 00000 00000 00110 001",
      "(2) 02000 00000 00000 02200 20000 00002 20002 20000 002",
      "(2) 02000 00000 00000 02200 20000 00002 20002 20000 002",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00000 001",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00000 002",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 02002 00000 00000 00000 00000 00000 00000 02000 000",
      "(2) 02002 00000 00000 00000 00000 00000 00000 02000 000",
      "(2) 02010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 00010 00000 00000 00000 00000 00000 00000 00000 001",
      "(2) 00010 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 02202 02222 22222 20022 02000 22000 00000 00000 000",
      "(2) 02302 02222 22222 20022 02000 22000 00000 00000 000",
      "(2) 02020 00000 00000 00000 00002 00000 00220 00000 020",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00100 000",
      "(2) 02002 00000 00000 00000 00000 00000 00000 02000 000",
      "(2) 02333 12222 22222 20022 02002 22000 00220 00000 120",
      "(2) 03002 00000 00000 00000 00000 00000 00000 02000 000",
      "(2) 02202 02222 22221 10022 02000 12000 00000 00000 000",
      "(2) 01000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00000 001",
      "(2) 02000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 02202 02222 22222 20022 02000 22000 00000 00000 000",
      "(2) 02203 03222 22222 20022 02000 22000 00000 00000 000",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00010 000",
      "(2) 02303 02222 22222 20022 02000 22000 00000 00000 000",
      "(2) 00010 00000 00110 00000 00000 00000 00000 00110 001",
      "(2) 02000 00000 00000 02200 20220 00002 20002 20000 002",
      "(2) 01000 00000 00000 01100 10000 00001 10001 10000 001",
      "(2) 01000 00000 00000 01100 10000 00001 10001 10000 001",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00000 001",
      "(2) 03000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 02101 00100 00000 00011 00000 01000 00000 00000 000",
      "(2) 01000 00000 00000 01100 10010 00001 10001 10000 001",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00010 000",
      "(2) 02000 00000 00000 02200 20220 00002 20002 20000 002",
      "(2) 01000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 02002 00000 00000 00000 00000 00000 00000 02000 000",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00110 000",
      "(2) 01000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 01000 00000 00000 01100 10210 00001 10001 10000 001",
      "(2) 01000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 01000 00000 00000 01100 10000 00001 10001 10000 001",
      "(2) 01010 00000 00000 00000 00001 00000 00110 00000 010",
      "(2) 01000 00000 00000 00000 00001 00000 00110 00000 010",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00000 001",
      "(2) 02202 00210 00000 00022 00000 02000 00000 00000 000",
      "(2) 00010 00001 00110 00000 00000 00000 00000 00110 001",
      "(2) 02000 00000 00000 02200 20220 00302 20002 20000 002",
      "(2) 01000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 01000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 00000 00000 00000 00000 00000 00000 00000 00000 001",
      "(2) 02202 00220 00000 00022 00000 02000 00000 00000 000",
      "(2) 01000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 01000 00000 00000 01100 10010 00001 10001 10001 001",
      "(2) 02002 00000 00000 00000 00000 00000 00000 01000 000",
      "(2) 02000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 02202 00220 00000 00022 00000 02000 00000 00000 000",
      "(2) 02202 01221 11000 00022 01000 02000 00000 00000 000",
      "(2) 02002 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 01000 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 01001 00000 00000 00000 00000 00000 00000 00000 000",
      "(2) 02202 02222 22110 00022 02000 02000 00000 00000 000",
      "(2) 00010 00000 00000 00000 00001 00000 00110 00000 010");
   DECLARE NC1TRIPLES LITERALLY '203';
   DECLARE C1TRIPLES(NC1TRIPLES) FIXED INITIAL (197379, 197385, 197388, 197389,
      197413, 197414, 197418, 207363, 459523, 459529, 459532, 459533, 459557,
      459558, 459562, 469507, 525059, 525065, 525068, 525069, 525093, 525094,
      525098, 535043, 590595, 590601, 590604, 590605, 590629, 590630, 590634,
      600579, 787203, 787209, 787212, 787213, 787237, 787238, 787242, 797187,
      852739, 852745, 852748, 852749, 852773, 852774, 852778, 862723, 918275,
      918281, 918284, 918285, 918309, 918310, 918314, 928259, 983811, 983817,
      983820, 983821, 983845, 983846, 983850, 993795, 1049347, 1049353, 1049356,
      1049357, 1049381, 1049382, 1049386, 1059331, 1124867, 1127174, 1180419,
      1180425, 1180428, 1180429, 1180453, 1180454, 1180458, 1190403, 1245955,
      1245961, 1245964, 1245965, 1245989, 1245990, 1245994, 1255939, 1377027,
      1377033, 1377036, 1377037, 1377061, 1377062, 1377066, 1387011, 1452547,
      1454852, 1454854, 1456897, 1639171, 1639177, 1639180, 1639181, 1639205,
      1639206, 1639210, 1649155, 1835779, 1835785, 1835788, 1835789, 1835813,
      1835814, 1835818, 1845763, 1911299, 2032387, 2032393, 2032396, 2032397,
      2032421, 2032422, 2032426, 2042371, 2228995, 2229001, 2229004, 2229005,
      2229029, 2229030, 2229034, 2238979, 2490904, 2490912, 2490913, 2490921,
      3212035, 3212041, 3212044, 3212045, 3212069, 3212070, 3212074, 3222019,
      3417602, 3539715, 3539721, 3539724, 3539725, 3539749, 3539750, 3539754,
      3549699, 3680771, 3683076, 3683078, 3685121, 3689499, 3746307, 3748612,
      3748614, 3750657, 3811843, 3814148, 3814150, 3936810, 4008451, 4010756,
      4010758, 4012801, 4072962, 4338946, 4338948, 4467203, 4469508, 4469510,
      4471553, 4598275, 4600580, 4600582, 4602625, 4664065, 4729601, 4794882,
      4794884, 4915971, 4915977, 4915980, 4915981, 4916005, 4916006, 4916010,
      4925955, 5188098, 5188100, 5384707, 5387012, 5387014, 5389057, 5833731,
      5833770);
   DECLARE PRTB(109) FIXED INITIAL (0, 4671531, 18219, 18248, 4430, 4416, 4419,
      71, 17, 59, 45, 88, 81, 69, 77, 89, 0, 16949, 18730, 13350, 20266, 828,
      19260, 91, 36, 24, 42, 0, 0, 18730, 20266, 16949, 19260, 51, 42, 9, 10,
      11, 0, 0, 9, 0, 9, 0, 20, 0, 4156, 76, 0, 0, 0, 0, 10792, 0, 0, 82, 0, 23,
      46, 0, 0, 4072962, 91, 23052, 23053, 12, 13, 0, 17988, 82, 61, 11278,
      11279, 11289, 0, 29, 0, 0, 14393, 68, 61, 56, 0, 58, 1195027, 13105, 18,
      31, 28, 34, 82, 0, 83, 0, 15367, 0, 82, 0, 9, 0, 0, 3354940, 18952, 0,
      22070, 0, 22788, 35, 22037, 0);
   DECLARE PRDTB(109) BIT(8) INITIAL (0, 35, 33, 34, 22, 23, 24, 32, 21, 6, 7,
      8, 9, 10, 11, 12, 13, 67, 37, 60, 64, 103, 105, 62, 68, 61, 106, 38, 65,
      39, 66, 69, 107, 73, 43, 85, 88, 89, 82, 72, 86, 83, 87, 84, 48, 40, 18,
      19, 49, 57, 59, 44, 53, 108, 109, 36, 58, 41, 47, 63, 104, 55, 54, 93, 94,
      95, 96, 92, 31, 42, 20, 98, 99, 100, 97, 46, 102, 101, 16, 3, 25, 15, 2,
      71, 28, 70, 27, 29, 30, 45, 17, 5, 56, 1, 75, 74, 14, 4, 79, 78, 52, 26,
      77, 76, 81, 80, 51, 50, 91, 90);
   DECLARE HDTB(109) BIT(8) INITIAL (0, 70, 70, 70, 61, 61, 61, 70, 61, 76, 76,
      76, 76, 76, 76, 76, 76, 65, 72, 43, 91, 50, 51, 62, 66, 52, 75, 73, 79,
      73, 79, 66, 75, 58, 82, 54, 54, 54, 54, 49, 54, 54, 54, 54, 46, 47, 56,
      57, 46, 43, 43, 81, 87, 53, 53, 71, 43, 47, 77, 91, 51, 83, 83, 90, 90,
      90, 90, 90, 88, 47, 45, 44, 44, 44, 44, 69, 50, 50, 63, 68, 61, 63, 68,
      59, 84, 59, 84, 64, 67, 81, 63, 55, 83, 48, 60, 60, 76, 55, 85, 85, 87,
      78, 74, 74, 80, 80, 89, 89, 86, 86);
   DECLARE PRLENGTH(109) BIT(8) INITIAL (0, 4, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2,
      2, 2, 2, 1, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 1, 1, 3, 3, 3, 3, 2, 2, 2, 2, 2,
      1, 1, 2, 1, 2, 1, 2, 1, 3, 2, 1, 1, 1, 1, 3, 1, 1, 2, 1, 2, 2, 1, 1, 4, 2,
      3, 3, 2, 2, 1, 3, 2, 2, 3, 3, 3, 1, 2, 1, 1, 3, 2, 2, 2, 1, 2, 4, 3, 2, 2,
      2, 2, 2, 1, 2, 1, 3, 1, 2, 1, 2, 1, 1, 4, 3, 1, 3, 1, 3, 2, 3, 1);
   DECLARE CONTEXT_CASE(109) BIT(8) INITIAL (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
   DECLARE LEFT_CONTEXT(1) BIT(8) INITIAL (86, 71);
   DECLARE LEFT_INDEX(49) BIT(8) INITIAL (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2,
      2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2);
   DECLARE CONTEXT_TRIPLE(0) FIXED INITIAL (0);
   DECLARE TRIPLE_INDEX(49) BIT(8) INITIAL (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1);
   DECLARE PR_INDEX(91) BIT(8) INITIAL (1, 17, 23, 29, 34, 35, 40, 40, 40, 40,
      42, 44, 44, 44, 44, 44, 44, 44, 45, 45, 45, 45, 45, 46, 46, 46, 47, 48,
      48, 48, 49, 49, 50, 51, 52, 52, 52, 54, 55, 56, 56, 57, 61, 63, 68, 68,
      68, 71, 71, 71, 75, 77, 77, 78, 78, 83, 83, 83, 83, 84, 90, 90, 90, 92,
      92, 93, 93, 93, 94, 94, 94, 94, 94, 94, 96, 96, 98, 98, 98, 98, 100, 100,
      100, 101, 102, 104, 106, 108, 108, 108, 110, 110);

   /*  END OF CARDS PUNCHED BY SYNTAX                                      */

   /*  DECLARATIONS FOR THE SCANNER                                        */

   /* TOKEN IS THE INDEX INTO THE VOCABULARY V() OF THE LAST SYMBOL SCANNED,
      CH IS THE LAST CHARACTER SCANNED (HEX CODE),
      CP IS THE POINTER TO THE LAST CHARACTER SCANNED IN THE CARDIMAGE,
      BCD IS THE LAST SYMBOL SCANNED (LITERAL CHARACTER STRING). */
   DECLARE TOKEN BIT(16), CH BIT(8), CP BIT(16), BCD CHARACTER, CH2 BIT(8);

   /* SET UP SOME CONVENIENT ABBREVIATIONS FOR PRINTER CONTROL */
   DECLARE EJECT_PAGE LITERALLY 'OUTPUT(1) = PAGE',
      PAGE CHARACTER INITIAL ('1'), DOUBLE CHARACTER INITIAL ('0'),
      DOUBLE_SPACE LITERALLY 'OUTPUT(1)=DOUBLE';

   /* LENGTH OF LONGEST SYMBOL IN V */
   DECLARE (RESERVED_LIMIT, MARGIN_CHOP) FIXED;

   /* CHARTYPE() IS USED TO DISTINGUISH CLASSES OF SYMBOLS IN THE SCANNER.
      TX() IS A TABLE USED FOR TRANSLATING FROM ONE CHARACTER SET TO ANOTHER.
      CONTROL() HOLDS THE VALUE OF THE COMPILER CONTROL TOGGLES SET IN $ CARDS.
      NOT_LETTER_OR_DIGIT() IS SIMILIAR TO CHARTYPE() BUT USED IN SCANNING
      IDENTIFIERS ONLY.

      ALL ARE USED BY THE SCANNER AND CONTROL() IS SET THERE.
   */
   DECLARE TX(255) BIT(1),
      CHARTYPE(255) BIT(1) INITIAL(
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1),
      CONTROL(255) BIT(1),
      NOT_LETTER_OR_DIGIT(255) BIT(1) INITIAL(
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1);
   /* TRT USED FOR SCANNING BLANKS */
   IF 0 THEN
TRT:  CALL INLINE("DD",0,0,3,0,CHARTYPE);        /* TRT 0(0,3),CHARTYPE  */

   /* ALPHABET CONSISTS OF THE SYMBOLS CONSIDERED ALPHABETIC IN BUILDING
      IDENTIFIERS     */

   /* BUFFER HOLDS THE LATEST CARDIMAGE,
      TEXT HOLDS THE PRESENT STATE OF THE INPUT TEXT (INCLUDING MACRO
      EXPANSIONS AND NOT INCLUDING THE PORTIONS DELETED BY THE SCANNER),
      TEXT_LIMIT IS A CONVENIENT PLACE TO STORE THE POINTER TO THE END OF TEXT,
      CARD_COUNT IS INCREMENTED BY ONE FOR EVERY XPL SOURCE CARD READ,
      ERROR_COUNT TABULATES THE ERRORS AS THEY ARE DETECTED DURING COMPILE,
      SEVERE_ERRORS TABULATES THOSE ERRORS OF FATAL SIGNIFICANCE.
   */
   DECLARE (BUFFER, TEXT, CURRENT_PROCEDURE, INFORMATION) CHARACTER,
      (TEXT_LIMIT, CARD_COUNT, ERROR_COUNT, SEVERE_ERRORS, PREVIOUS_ERROR) FIXED
      ;

   /* NUMBER_VALUE CONTAINS THE NUMERIC VALUE OF THE LAST CONSTANT SCANNED,
      JBASE CONTAINS THE FIELD WIDTH IN BIT STRINGS (DEFAULT VALUE = 4),
      BASE IS  2**JBASE   (I.E., SHL(1,JBASE) ).
   */
   DECLARE (NUMBER_VALUE, JBASE, BASE) FIXED;

   /* EACH OF THE FOLLOWING CONTAINS THE INDEX INTO V() OF THE CORRESPONDING
      SYMBOL.   WE ASK:    IF TOKEN = IDENT    ETC.    */
   DECLARE (IDENT, STRING, NUMBER, DIVIDE, EOFILE, ORSYMBOL,
      CONCATENATE) FIXED;

   /* THE FOLLOWING ARE USED IN THE MACRO EXPANDER.  CONSIDERABLE LOGIC
      IS DEVOTED TO AVOIDING CREATING STRINGS OF LENGTH > 256, THE STRING LIMIT.
   */
   DECLARE BALANCE CHARACTER, LB FIXED;
   DECLARE MACRO_LIMIT LITERALLY '45',
      MACRO_NAME(MACRO_LIMIT) CHARACTER,
      MACRO_TEXT(MACRO_LIMIT) CHARACTER,
      MACRO_INDEX(256) BIT(8),
      TOP_MACRO FIXED INITIAL ("FFFFFFFF");
   DECLARE EXPANSION_COUNT FIXED, EXPANSION_LIMIT LITERALLY '300';

   /* STOPIT() IS A TABLE OF SYMBOLS WHICH ARE ALLOWED TO TERMINATE THE ERROR
      FLUSH PROCESS.  IN GENERAL THEY ARE SYMBOLS OF SUFFICIENT SYNTACTIC
      HIERARCHY THAT WE EXPECT TO AVOID ATTEMPTING TO START COMPILING AGAIN
      RIGHT INTO ANOTHER ERROR PRODUCING SITUATION.  THE TOKEN STACK IS ALSO
      FLUSHED DOWN TO SOMETHING ACCEPTABLE TO A STOPIT() SYMBOL.
      FAILSOFT IS A BIT WHICH ALLOWS THE COMPILER ONE ATTEMPT AT A GENTLE
      RECOVERY.   THEN IT TAKES A STRONG HAND.   WHEN THERE IS REAL TROUBLE
      COMPILING IS SET TO FALSE, THEREBY TERMINATING THE COMPILATION.
      MAINLOC IS THE SYMBOL TABLE LOCATION OF COMPACTIFY FOR USE IN ERROR().
   */
   DECLARE STOPIT(NT) BIT(1), (FAILSOFT, COMPILING) BIT(1), MAINLOC FIXED;

   DECLARE S CHARACTER;  /* A TEMPORARY USED VARIOUS PLACES */

   /* THE ENTRIES IN PRMASK() ARE USED TO SELECT OUT PORTIONS OF CODED
      PRODUCTIONS AND THE STACK TOP FOR COMPARISON IN THE ANALYSIS ALGORITHM */
   DECLARE PRMASK(5) FIXED INITIAL (0, 0, "FF", "FFFF", "FFFFFF", "FFFFFFFF");

   /* HEXCODES & ALPHABET OVERLAP */
   DECLARE REST CHARACTER; /* UNREAD PORTION OF SOURCE STATEMENT */
   /* SUBSTR(HEXCODES, I, 1) is the hexadecimal letter code for I */
   DECLARE HEXCODES CHARACTER INITIAL ('0123456789');
   DECLARE ALPHABET CHARACTER INITIAL ('ABCDEFGHIJKLMNOPQRSTUVWXYZ_$@#');
   /* To obtain upper & lower case, comment the previous line, and uncomment
      the following statement (this statement has not been tested):           */
/* DECLARE ALPHABET CHARACTER INITIAL
      ( 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_$@#' );         */

   DECLARE CATNUMNTRY FIXED;

   /*THE PROPER SUBSTRING OF POINTER IS USED TO PLACE AN  |  UNDER THE POINT
      OF DETECTION OF AN ERROR DURING COMPILATION.  IT MARKS THE LAST CHARACTER
      SCANNED.  */
   DECLARE X70 CHARACTER INITIAL(' ');
   DECLARE POINTER CHARACTER INITIAL ('
                                           |');
   DECLARE (COUNT#STACK, COUNT#SCAN, COUNT#RR, COUNT#RX, COUNT#FORCE,
      COUNT#ARITH, COUNT#STORE, COUNT#FIXBFW, COUNT#FIXD, COUNT#FIXCHW,
      STACKMAX,
      COUNT#GETD, COUNT#GETC, COUNT#FIND) FIXED;

   /* RECORD THE TIMES OF IMPORTANT POINTS DURING COMPILATION */
   DECLARE CLOCK(5) FIXED;

   /* COUNT THE NUMBER OF COMPARISONS OF IDENTIFIERS IN SYMBOL TABLE LOOK-UPS
      THIS CAN, IN GENERAL, BE EXPECTED TO BE A SUBSTANTIAL PART OF RUN TIME.
   */
   DECLARE IDCOMPARES FIXED, STATEMENT_COUNT FIXED;
   DECLARE TRUELOC FIXED;  /* ADDRESS OF INTEGER 1 IN DATA AREA */
   DECLARE COMPLOC FIXED; /*  THE ADDRESS OF ALL ONES MASK FOR COMPLEMENT */
   DECLARE CATCONST FIXED;   /* ADDRESS OF 2**24  */
   DECLARE BASEDATA FIXED;   /*  BASE REGISTER INITIALIZATION ADDRESS */

   /*  THE EMITTER  ARRAYS  */


 /******************************************************************************

      WARNING:  THE EMITTER ARRAYS "CODE", "DATA", AND "STRINGS" ARE
   DEPENDENT ON THE HARDWARE DEVICES AVAILABLE FOR SCRATCH STORAGE.  THE
   LITERAL CONSTANT "DISKBYTES" SHOULD BE EQUAL TO THE BLOCKSIZE OF THESE FILES
   AS ESTABLISHED IN DCB'S IN THE SUBMONITOR.

   SUGGESTED VALUES:
            FOR LARGE CORE:             FOR SMALL CORE DISKBYTES = 400.

      2311     DISKBYTES = 3600
      2314     DISKBYTES = 7200
      2321     DISKBYTES = 2000

      THIS VERSION OF XCOM NEEDS THREE SCRATCH FILES:
      1        COMPILED CODE TEMPORARY
      2        COMPILED DATA TEMPORARY
      3        CHARACTER STRING TEMPORARY
      1        BINARY PROGRAM OUTPUT

 ******************************************************************************/

DECLARE DISKBYTES LITERALLY '3600';    /*  2311  DISKS  */
      /* SIZE OF SCRATCH FILE BLOCKS IN BYTES */
   DECLARE CODEMAX FIXED;        /* FORCES CODE TO WORD BOUNDARY */
   DECLARE CODE (DISKBYTES) BIT(8);
   DECLARE DATAMAX FIXED;     /* FORCES DATA TO WORD BOUNDARY */
   DECLARE DATA (DISKBYTES) BIT(8);
   DECLARE STRNGMX FIXED;            /*  AND FORCE STRINGS TO BE ALIGNED  */
   DECLARE STRINGS (DISKBYTES) BIT(8); /* BUFFER FOR COMPILED STRINGS  */


   /*  CODEMAX  IS THE # OF RECORDS OF CODE GENERATED
       DATAMAX IS THE NUMBER OF RECORDS OF DATA GENERATED
   */

   DECLARE CODEFILE FIXED INITIAL(1);    /* FILE FOR BINARY CODE, AND */
   DECLARE BINARYFILE FIXED INITIAL(1);  /* COLLECTION OF ALL COMPILED OUTPUT */
   DECLARE DATAFILE FIXED INITIAL (2);    /* SCRATCH FILE FOR DATA */
   DECLARE STRINGFILE FIXED INITIAL (3);
      /* SCRATCH FILE FOR CHARACTER STRINGS */

   DECLARE (PPORG, PPLIM, DPORG, DPLIM, CURCBLK, CURDBLK, CURSBLK, CHPORG,
      CHPLIM, STRINGMAX, SHORTDFIX, SHORTCFIX, LONGDFIX, LONGCFIX, FCP) FIXED;

      /* ARRAYS TO HOLD FIXUPS DURING COMPILATION */

   /* FCLIM IS THE NUMBER OF FIXUPS THAT CAN BE RECORDED BEFORE THEY ARE MADE */
   DECLARE FCLIM LITERALLY '100';
   DECLARE FIXCADR (FCLIM) FIXED;      /* ADDRESS OF CODE FIXUP  */
   DECLARE FIXCB1 (FCLIM) BIT(8);      /* 1ST BYTE OF CODE FIXUP  */
   DECLARE FIXCB2 (FCLIM) BIT(8);      /* 2ND BYTE OF CODE FIXUP  */

   DECLARE LIMITWORD FIXED;
   DECLARE STRING_RECOVER FIXED;

   DECLARE CATENTRY FIXED;   /*  ENTRY TO CATENATE ROUTINE */
   DECLARE STRL FIXED;  /* ADDRESS OF LAST STRING COMPUTED FOR OPTIMIZING || */
   DECLARE STRN FIXED;  /* ADDRESS OF TEMP IN STRING TO NUMBER ROUTINE */
   DECLARE DESCL FIXED;
   DECLARE IO_SAVE FIXED;
   DECLARE NMBRNTRY  FIXED;     /*  ENTRY TO BINARY TO CHAR. CONVERSION */
   DECLARE TSA FIXED;  /* INTEGER ADDRESS OF TOP-OF-STRINGS  */
   DECLARE MOVER FIXED;   /*  ADDRESS OF MOVE TEMPLATE  */
   DECLARE BASES (15) FIXED;    /*  THE VALUE OF THE BASE REGISTERS */
   DECLARE AVAIL FIXED INITIAL (2);
   DECLARE INSTRUCT (255) BIT(16);  /*  INSTRUCTION USE COUNTERS */
   DECLARE DESC(1024) FIXED;  /* STRING DESCRIPTORS, REG 13 RELATIVE */

   /*  360 REGISTER ASSIGNMENTS:
            0     SCRATCH
            1-3   ACCUMULATORS
            4-11  DATA ADDRESSING
            12    BRANCH REGISTER
            13    STRING DESCRIPTOR AREA BASE
            14    PROGRAM BASE
            15    POINTS TO ENTRY OF I/O PACKAGE
   */

   DECLARE IOREG LITERALLY '"F"';  /* REGISTER FOR IO ROUTINES OF SUBMONITOR */
   DECLARE PBR LITERALLY '"E"';  /* PROGRAM BASE REGISTER POINTS TO CODE  */
   DECLARE SBR LITERALLY '"D"';  /* STRING BASE REGISTER TO ADDRESS DESCRIPT. */
   DECLARE BRCHREG LITERALLY '"C"';  /* REGISTER FOR BRANCHING  */
   DECLARE DBR LITERALLY '"B"';  /* FIRST DATA BASE REGISTER  */
   DECLARE PROGRAMSIZE LITERALLY '25';  /* NUMBER OF 4096 BYTE PAGES ALLOWED */
   DECLARE LASTBASE FIXED;   /*  KEEP TRACK OF ALLOCATION OF REG 11 - 4 */
   DECLARE TARGET_REGISTER FIXED;
   DECLARE MASKF000 BIT(32);
   DECLARE ADREG BIT(8), ADRDISP BIT(16); /* GLOBALS FOR FINDADDRESS */
   DECLARE RTNADR FIXED;  /*  WHERE THE PRESENT RETURN ADDRESS IS STORED */
   DECLARE RETURNED_TYPE BIT (8);
      DECLARE TEMP(3) BIT(16);
   DECLARE (DP, PP, CHP, DSP, NEWDP, NEWDSP) FIXED; /* EMITTER POINTERS */
   DECLARE ITYPE FIXED;   /*  INITIALIZATION TYPE  */
   DECLARE STILLCOND FIXED;  /*  REMEMBER CONDITION CODE TEST FOR PEEPHOLE */
   /* REMEMBER        FOR PEEP HOLE OPTIMISATION OF LENGTH FUNCTION */
   DECLARE SAVEADR FIXED, LENGTHPP FIXED, LENGTHPP2 FIXED;
   DECLARE NEG_INCREMENT BIT(8);
   DECLARE M FIXED; /* A TEMPORARY */

   /*  COMMON  IBM  360  OP-CODES  */
   DECLARE OPNAMES(1) CHARACTER INITIAL(
                                      '    BALRBCTRBCR LPR LNR LTR LCR NR  CLR O
R  XR  LR  CR  AR  SR  MR  DR  ALR SLR LA  STC IC  EX  BAL BCT BC  CVD CVB ST  N
   CL  O   X   L   C   A   S   M   D   AL  SL  SRL SLL SRA SLA SRDLSLDLSRDASLDAS
TM TM  MVI NI  CLI OI  XI  LM  MVC STH LH  CH  AH  SH  ',
   /* THIS STRING, THOUGH NOT FORMALLY REFERENCED, FOLLOWS OPCODES IN MEMORY */
      'MH  EDMKCLC ');
   DECLARE OPER(255) BIT(8) INITIAL(
 /*0**/   0,  0,  0,  0,  0,  1,  2,  3,  0,  0,  0,  0,  0,  0,  0,  0,
 /*1**/   4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
 /*2**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
 /*3**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
 /*4**/  59, 20, 21, 22, 23, 24, 25, 26, 60, 61, 62, 63, 64,  0, 27, 28,
 /*5**/  29,  0,  0,  0, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
 /*6**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
 /*7**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
 /*8**/   0,  0,  0,  0,  0,  0,  0,  0, 42, 43, 44, 45, 46, 47, 48, 49,
 /*9**/  50, 51, 52,  0, 53, 54, 55, 56, 57,  0,  0,  0,  0,  0,  0,  0,
 /*A**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
 /*B**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
 /*C**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
 /*D**/   0,  0, 58,  0,  0, 66,  0,  0,  0,  0,  0,  0,  0,  0,  0, 65,
 /*E**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
 /*F**/   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0);
 /*      *0  *1  *2  *3  *4  *5  *6  *7  *8  *9  *A  *B  *C  *D  *E  *F  */
   DECLARE OP_CODE CHARACTER;  /* FOR DEBUG PRINTOUT */
   DECLARE COMMUTATIVE(63) BIT(1);  /* RECORD WHICH OPERATORS ARE COMMUTATIVE */

   /* COMMONLY USED /360 OPERATION CODES */
   DECLARE BC LITERALLY '"47"', BCR LITERALLY '"07"',
           LOAD LITERALLY '"58"', STORE LITERALLY '"50"',
         BAL LITERALLY '"45"',      BALR  BIT(8) INITIAL("05") ,
           CMPR BIT(8) INITIAL("59"), CMPRR BIT(8) INITIAL ("19"),
           LA   BIT(8) INITIAL("41");

   /* THE FOLLOWING ARE USED TO HOLD ADDRESS PAIRS IN THE EMITTER FOR || */
   DECLARE (A1, A2, T1) BIT(8),(B1, B2, T2) BIT(16);

   /* COMMONLY USED STRINGS */
   DECLARE X1 CHARACTER INITIAL(' '), X4 CHARACTER INITIAL('    ');
   DECLARE EQUALS CHARACTER INITIAL (' = '), PERIOD CHARACTER INITIAL ('.');
   DECLARE
      CODEQ  CHARACTER INITIAL(': CODE = '),
      DATAQ  CHARACTER INITIAL(': DATA = '),
      VBAR   CHARACTER INITIAL('|'),    X1VBAR CHARACTER INITIAL(' |'),
      COLON  CHARACTER INITIAL(':'),    COMMA  CHARACTER INITIAL(','),
      LPAR   CHARACTER INITIAL('('),    RPAR   CHARACTER INITIAL(')'),
      FIXUPM CHARACTER INITIAL(': FIXUP =');

   /* TEMPORARIES USED THROUGHOUT THE COMPILER */
   DECLARE CHAR_TEMP CHARACTER;
   DECLARE (I, J, K, L) FIXED;

   DECLARE TRUE LITERALLY '1', FALSE LITERALLY '0', FOREVER LITERALLY 'WHILE 1';

   /*  SYMBOL  TABLE  VARIABLES  */

   DECLARE HALFWORD     LITERALLY  '1',
           LABELTYPE    LITERALLY  '2',
           ACCUMULATOR  LITERALLY  '3',
           VARIABLE     LITERALLY  '4',
           CONSTANT     LITERALLY  '5',
           CONDITION    LITERALLY  '6',
           CHRTYPE      LITERALLY  '7',
           FIXEDTYPE    LITERALLY  '8',
           BYTETYPE     LITERALLY  '9',
           FORWARDTYPE  LITERALLY '10',
           DESCRIPT     LITERALLY '11',
           SPECIAL      LITERALLY '12',
           FORWARDCALL  LITERALLY '13' ,
           CHAR_PROC_TYPE LITERALLY '14'
           ;
   DECLARE TYPENAME(14) CHARACTER INITIAL ('', 'BIT(16)  ', 'LABEL    ', '', '',
      '', '', 'CHARACTER', 'FIXED    ', 'BIT(8)   ', '', '', '', '',
      'CHARACTER PROCEDURE');
   DECLARE PROCMARK FIXED;  /* START OF LOCAL VARIABLES IN SYMBOL TABLE */
   DECLARE PARCT FIXED;  /* NUMBER OF PARAMETERS TO CURRENT PROCEDURE */
   DECLARE NDECSY FIXED;     /* CURRENT NUMBER OF DECLARED SYMBOLS */
   /* MAXNDECSY IS THE MAXIMUM OF NDECSY OVER A COMPILATION.  IF MAXNDECSY
      BEGINS TO APPROACH SYTSIZE THEN SYTSIZE SHOULD BE INCREASED */
   DECLARE MAXNDECSY FIXED;

   DECLARE SYTSIZE LITERALLY '470';

   /*  THE SYMBOL TABLE IS INITIALIZED WITH THE NAMES OF ALL
       BUILTIN FUNCTIONS AND PSEUDO VARIABLES.  THE PROCEDURE
       INITIALIZE DEPENDS ON THE ORDER AND PLACEMENT OF THESE
       NAMES.  DUE CAUTION SHOULD BE OBSERVED WHILE MAKING CHANGES .
   */

   DECLARE SYT (SYTSIZE) CHARACTER          /*  VARIABLE NAME */
      INITIAL ('','','MONITOR_LINK','TIME_OF_GENERATION',
         'DATE_OF_GENERATION','COREWORD','COREBYTE','FREEPOINT',
         'DESCRIPTOR','NDESCRIPT', 'LENGTH','SUBSTR','BYTE','SHL',
         'SHR','INPUT','OUTPUT','FILE','INLINE','TRACE','UNTRACE',
         'EXIT','TIME','DATE','CLOCK_TRAP','INTERRUPT_TRAP',
            'MONITOR', 'ADDR', 'COREHALFWORD', 'COMPACTIFY', '', '');
   DECLARE SYTYPE (SYTSIZE) BIT (8)   /* TYPE OF THE VARIABLE */
      INITIAL (0,0,FIXEDTYPE,FIXEDTYPE,FIXEDTYPE,FIXEDTYPE,
         BYTETYPE,FIXEDTYPE,FIXEDTYPE,FIXEDTYPE,SPECIAL,SPECIAL,
         SPECIAL,SPECIAL,SPECIAL,SPECIAL,SPECIAL,SPECIAL,SPECIAL,
         SPECIAL,SPECIAL,SPECIAL,SPECIAL,SPECIAL,SPECIAL,SPECIAL,
         SPECIAL,SPECIAL,HALFWORD,FORWARDCALL,0,0);
   DECLARE SYBASE(SYTSIZE) BIT(4) INITIAL(0, 0, PBR, DBR, DBR, 0, 0,
      DBR,SBR,DBR,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
   DECLARE SYDISP (SYTSIZE) BIT (12)  /* DISPLACEMENT FOR VARIABLE */
      INITIAL (0,0,0,0,0,0,0,0,0,0,1,2,3,4,5,6,7,8,  10,11,12,13,14,
         15,16,17,18,19,0,0);
   DECLARE SYTCO(SYTSIZE) BIT (16);     /* COUNT OF REFERENCES TO SYMBOLS */
   DECLARE DECLARED_ON_LINE(SYTSIZE) BIT(16);
   /* HASHING SYMBOL TABLE STUFF */
   DECLARE IDX BIT (16),
      PTR(SYTSIZE) BIT(16),
      HASH("FF") BIT(16);

   /*  THE COMPILER STACKS DECLARED BELOW ARE USED TO DRIVE THE SYNTACTIC
      ANALYSIS ALGORITHM AND STORE INFORMATION RELEVANT TO THE INTERPRETATION
      OF THE TEXT.  THE STACKS ARE ALL POINTED TO BY THE STACK POINTER SP.  */

   DECLARE STACKSIZE LITERALLY '75';  /* SIZE OF STACK  */
   DECLARE PARSE_STACK (STACKSIZE) BIT(8); /* TOKENS OF THE PARTIALLY PARSED
                                              TEXT */
   DECLARE TYPE (STACKSIZE) BIT(8);  /* OPERAND TYPE FOR EXPRESSIONS */
   DECLARE REG (STACKSIZE) BIT(8);   /* ASSOCIATED GENERAL REGISTER */
   DECLARE INX (STACKSIZE) BIT(8);   /* ASSOCIATED INDEX REGISTER */
   DECLARE CNT (STACKSIZE) BIT(8);   /* ANNY COUNT, PARAMETERS, SUBSCRIPTS ...*/
   DECLARE VAR (STACKSIZE) CHARACTER;/* EBCDIC NAME OF ITEM */
   DECLARE FIXL (STACKSIZE) FIXED;   /* FIXUP LOCATION */
   DECLARE FIXV (STACKSIZE) FIXED;   /* FIXUP VALUE */
   DECLARE PPSAVE (STACKSIZE) FIXED; /* ASSOCIATED PROGRAM POINTER */

   /* SP POINTS TO THE RIGHT END OF THE REDUCIBLE STRING IN THE PARSE STACK,
      MP POINTS TO THE LEFT END, AND
      MPP1 = MP+1.
   */
   DECLARE (SP, MP, MPP1) FIXED;

   /* DECLARE STATEMENTS AND CASE STATEMENTS REQUIRE AN AUXILIARY STACK */
   DECLARE CASELIMIT LITERALLY '255', CASESTACK(CASELIMIT) FIXED;
   DECLARE CASEP FIXED;   /* POINTS TO THE CURRENT POSITION IN CASESTACK */
   DECLARE DCLRM CHARACTER INITIAL ('IDENTIFIER LIST TOO LONG');




   /*               P R O C E D U R E S                                  */



PAD:
   PROCEDURE (STRING, WIDTH) CHARACTER;
      DECLARE STRING CHARACTER, (WIDTH, L) FIXED;

      L = LENGTH(STRING);
      IF L >= WIDTH THEN RETURN STRING;
      ELSE RETURN STRING || SUBSTR(X70, 0, WIDTH-L);
   END PAD;

I_FORMAT:
   PROCEDURE (NUMBER, WIDTH) CHARACTER;
         DECLARE NUMBER FIXED, (WIDTH, L) BIT(16), STRING CHARACTER;

      STRING = NUMBER;
      L = LENGTH(STRING);
      IF L >= WIDTH THEN RETURN STRING;
      ELSE RETURN SUBSTR(X70, 0, WIDTH-L) || STRING;
   END I_FORMAT;


LISTER:
   PROCEDURE;
      S = PP;
  /*
      S = I_FORMAT(PP, 6);
   */
      OUTPUT = I_FORMAT(CARD_COUNT, 4) || X1VBAR || BUFFER || VBAR ||
                       S || REST || CURRENT_PROCEDURE || INFORMATION;
   END LISTER;

ERROR:
   PROCEDURE(MSG, SEVERITY);
      /* PRINTS AND ACCOUNTS FOR ALL ERROR MESSAGES */
      /* IF SEVERITY IS NOT SUPPLIED, 0 IS ASSUMED */
      DECLARE MSG CHARACTER, SEVERITY FIXED;
      ERROR_COUNT = ERROR_COUNT + 1;
      /* IF LISTING IS SUPPRESSED, FORCE PRINTING OF THIS LINE */
      IF ^ CONTROL(BYTE('L')) THEN
         CALL LISTER;
      OUTPUT = SUBSTR(POINTER, TEXT_LIMIT+LB-CP+MARGIN_CHOP);
      /* SEVERITY(-1) IS A PORNOGRAPHIC WAY OF OBTAINING THE RETURN ADDRESS */
      OUTPUT = '*** ERROR, ' || MSG || ' (DETECTED AT LOCATION '
             || (SEVERITY(-1)&"FFFFFF") - ADDR(COMPACTIFY) + MAINLOC
            || ' IN XCOM) ***';
      IF ERROR_COUNT>1 THEN
         OUTPUT = 'LAST PREVIOUS ERROR WAS DETECTED ON LINE ' || PREVIOUS_ERROR;
      PREVIOUS_ERROR = CARD_COUNT;
      IF SEVERITY > 0 THEN
         IF SEVERE_ERRORS > 25 THEN
            DO;
               OUTPUT = '*** TOO MANY SEVERE ERRORS, COMPILATION ABORTED ***';
               COMPILING = FALSE;
            END;
         ELSE SEVERE_ERRORS = SEVERE_ERRORS + 1;
   END ERROR;


   /*                      FILE HANDLING PROCEDURES                          */



GETDATA:
   PROCEDURE;
      /* HANDLE SCRATCH STORAGE ALLOCATION FOR THE DATA ARRAY  */
      DECLARE I FIXED;
      COUNT#GETD = COUNT#GETD + 1;
      FILE(DATAFILE,CURDBLK) = DATA;     /*  WRITE OUT CURRENT BLOCK */
      CURDBLK = DP / DISKBYTES;          /* CALCULATE NEW BLOCK NUMBER */
      DPORG = CURDBLK * DISKBYTES;
      DPLIM = DPORG + DISKBYTES;
      IF CURDBLK <= DATAMAX THEN
            DATA = FILE(DATAFILE,CURDBLK);
      ELSE
         DO;
            /*  ZERO OUT THE NEW DATA BLOCK  */
            DO I = 1 TO SHR(DISKBYTES,2);
               DATAMAX(I) = 0;
            END;
            DO DATAMAX = DATAMAX + 1 TO CURDBLK - 1;
               FILE(DATAFILE,DATAMAX)= DATA;
            END;
         END;
   END  GETDATA;

GETCODE:
   PROCEDURE;
      /*  HANDLE SCRATCH STORAGE ALLOCATION FOR THE CODE ARRAY */
      DECLARE I FIXED;
      COUNT#GETC = COUNT#GETC + 1;
      FILE(CODEFILE,CURCBLK) = CODE;
      CURCBLK = PP / DISKBYTES;       /* CALCULATE NEW BLOCK NUMBER */
      PPORG = CURCBLK * DISKBYTES;
      PPLIM = PPORG + DISKBYTES;
      IF CURCBLK <= CODEMAX THEN
               CODE = FILE(CODEFILE,CURCBLK);
      ELSE
         DO;
         /*  ZERO OUT THE NEW CODE BLOCK */
            DO I = 1 TO SHR(DISKBYTES,2);
               CODEMAX(I) = 0;
            END;
            DO CODEMAX = CODEMAX + 1 TO CURCBLK - 1;
               FILE(CODEFILE,CODEMAX) = CODE;
            END;
         END;
   END  GETCODE;

GETSTRINGS:
   PROCEDURE;
      /* HANDLE SCRATCH STORAGE ALLOCATION FOR STRING ARRAY */
      FILE(STRINGFILE, CURSBLK) = STRINGS;    /* WRITE INTO THE FILE */
      CURSBLK = CHP / DISKBYTES;              /* COMPUTE NEW BLOCK NUMBER */
      CHPORG = CURSBLK*DISKBYTES;             /* NEW BLOCK ORIGIN */
      CHPLIM = CHPORG + DISKBYTES;            /* NEW UPPER BOUND */
      IF CURSBLK <= STRINGMAX THEN
         STRINGS = FILE(STRINGFILE,CURSBLK);  /* READ BACK FROM FILE */
      ELSE
         DO STRINGMAX = STRINGMAX+1 TO CURSBLK - 1;
            FILE(STRINGFILE,STRINGMAX) = STRINGS;
            /* FILL OUT FILE SO NO GAPS EXIST */
         END;
   END GETSTRINGS;



  /*                   CARD IMAGE HANDLING PROCEDURE                      */


GET_CARD:
   PROCEDURE;
      /* DOES ALL CARD READING AND LISTING                                 */
      DECLARE I BIT(16), READING BIT(1), (TEMP, TEMP0) CHARACTER;
      IF LB > 0 THEN
         DO;
            TEXT = BALANCE;
            TEXT_LIMIT = LB - 1;
          LB,CP=0;
            RETURN;
         END;
      EXPANSION_COUNT = 0;   /* CHECKED IN SCANNER MACRO EXPANSION */
      IF READING THEN
         DO; /* 'READING' IS FALSE DURING COMPILE OF LIBRARY FROM INPUT(2) */
            BUFFER = INPUT;
            IF LENGTH(BUFFER) = 0 THEN
               DO; /* SIGNAL FOR EOF */
                  CALL ERROR ('EOF MISSING OR COMMENT STARTING IN COLUMN 1.',1);
                  BUFFER = PAD (' /*''/* */ EOF;END;EOF', 80);
               END;
            ELSE CARD_COUNT = CARD_COUNT + 1;  /* USED TO PRINT ON LISTING */
         END;
      ELSE
         DO; /* WHILE READING LIBRARY FILE ONLY */
            BUFFER = INPUT(2);
            IF LENGTH(BUFFER) = 0 THEN
               DO;  /* SIGNAL TO SWITCH TO SYSIN */
          CONTROL(BYTE('D')),   /* TURN ON THE SYMBOL DUMP */
                  CONTROL(BYTE('L')), READING = TRUE;  /* TURN ON LISTING */
                  CLOCK(1) = TIME;  /* KEEP TRACK OF TIME FOR COMPILE RATE */
                  TEXT = X1;  /* INITIALIZE TEXT FOR SCAN */
                  /* STATEMENTS ARE COUNTED FOR STATISTICS */
                  STATEMENT_COUNT = -1;
                  TEXT_LIMIT = 0;
                  PROCMARK = NDECSY + 1;
                  RETURN;
               END;
         END;
      IF MARGIN_CHOP > 0 THEN
         DO; /* THE MARGIN CONTROL FROM DOLLAR | */
            I = LENGTH(BUFFER) - MARGIN_CHOP;
            REST = SUBSTR(BUFFER, I);
            BUFFER = SUBSTR(BUFFER, 0, I);
         END;
      ELSE REST = '';
      TEXT = BUFFER;
      TEXT_LIMIT = LENGTH(TEXT) - 1;
      IF CONTROL(BYTE('M')) THEN OUTPUT = BUFFER;
      ELSE IF CONTROL(BYTE('L')) THEN
         CALL LISTER;
      INFORMATION = '';
      CP = 0;
   END GET_CARD;


   /*                THE SCANNER PROCEDURES              */


CHAR:
   PROCEDURE;
      /* USED FOR STRINGS TO AVOID CARD BOUNDARY PROBLEMS */
      CP = CP + 1;
      IF CP <= TEXT_LIMIT THEN RETURN;
      CALL GET_CARD;
   END CHAR;

DEBLANK:
   PROCEDURE;
      /* USED BY BCHAR */
      CALL CHAR;
      DO WHILE BYTE(TEXT, CP) = BYTE(' ');
         CALL CHAR;
      END;
   END DEBLANK;

BCHAR:
   PROCEDURE;
      /* USED FOR BIT STRINGS */
      DO FOREVER;
         CALL DEBLANK;
         CH = BYTE(TEXT, CP);
         IF CH ^= BYTE('(') THEN RETURN;
         /*  (BASE WIDTH)  */
         CALL DEBLANK;
         JBASE = BYTE(TEXT, CP) - "F0";  /* WIDTH */
         IF JBASE < 1 | JBASE > 4 THEN
            DO;
               CALL ERROR ('ILLEGAL BIT STRING WIDTH: ' || SUBSTR(TEXT, CP, 1));
               JBASE = 4;  /* DEFAULT WIDTH FOR ERROR */
            END;
         BASE = SHL(1, JBASE);
         CALL DEBLANK;
         IF BYTE(TEXT, CP) ^= BYTE(')') THEN
            CALL ERROR ('MISSING ) IN BIT STRING', 0 );
      END;
   END BCHAR;

BUILD_BCD:
   PROCEDURE (C);
      DECLARE C BIT(8);
      IF LENGTH(BCD) > 0 THEN
         BCD = BCD || X1;
      ELSE
         BCD = SUBSTR(X1 || X1, 1);
      /* FORCE BCD TO THE TOP OF FREE STRING AREA AND INCREASE LENGTH
          BY ONE  */
      /* THIS LINE DEPENDS UPON THE IMPLEMENTATION OF XPL STRINGS */
      COREBYTE(FREEPOINT-1) = C;
   END BUILD_BCD;

SCAN:
   PROCEDURE;
      DECLARE (S1, S2) FIXED;
      DECLARE LSTRNGM CHARACTER INITIAL('STRING TOO LONG');
      COUNT#SCAN = COUNT#SCAN + 1;
      FAILSOFT = TRUE;
      BCD = '';  NUMBER_VALUE = 0;
   SCAN1:
      DO FOREVER;
         IF CP > TEXT_LIMIT THEN CALL GET_CARD;
         ELSE
            DO; /* DISCARD LAST SCANNED VALUE */
               TEXT_LIMIT = TEXT_LIMIT - CP;
               TEXT = SUBSTR(TEXT, CP);
               CP = 0;
            END;
         /*  BRANCH ON NEXT CHARACTER IN TEXT                  */
         DO CASE CHARTYPE(BYTE(TEXT));

            /* CASE 0:  BLANK */
            DO;
               CALL INLINE ("58", 3, 0, TEXT);   /* L   3,TEXT     */
               /* LOAD DESCRIPTOR FOR TEXT & ZERO THE LENGTH FIELD */
               CALL INLINE("41", 3, 0, 3, 1);
               /* LOAD LENGTH INTO R2 */
               CALL INLINE("58",2,0,TEXT_LIMIT); /* L   2,TEXT_LIMIT*/
               /* POINT R1 JUST PAST TEXT_LIMIT IN CASE REST OF TEXT IS BLANK */
               CALL INLINE ("41",1,2,3,0);       /* LA  1,0(2,3)    */
               /* EXECUTE TRT TO SKIP OVER BLANKS */
               CALL INLINE ("44", 2, 0, TRT);     /* EX  2,TRT      */
               /* COMPUTE NEW VALE OF CP POINTING @ LAST BLANK */
               CALL INLINE("1B", 1, 3);          /* SR  1,3     */
               CALL INLINE("50", 1, 0, CP);      /* ST  1,CP    */
               /* CP IS INCREMENTED BY 1 @ END OF CASE ON CHARTYPE */
            END;

            /* CASE 1:   ILLEGAL CHARACTERS FALL HERE  */
            CALL ERROR ('ILLEGAL CHARACTER: ' || SUBSTR(TEXT, 0, 1));


            /*  CASE 2  */

            /*  STRING QUOTE ('):  CHARACTER STRING  */
            DO FOREVER;
               TOKEN = STRING;
               CALL CHAR; S1 = CP;
               DO WHILE BYTE(TEXT,CP) ^= BYTE('''');
                  CP = CP + 1;
                  IF CP > TEXT_LIMIT THEN
                     DO;
                        IF LENGTH(BCD)+CP-S1 > 256 THEN
                           DO;
                              CALL ERROR(LSTRNGM, 0);
                              RETURN;
                           END;
                        BCD = BCD || SUBSTR(TEXT,S1,CP-S1);
                        CP,S1=0;
                        CALL GET_CARD;
                     END;
               END;
               IF LENGTH(BCD)+CP-S1 > 256 THEN
                  DO;
                     CALL ERROR(LSTRNGM,0);
                     RETURN;
                  END;
               IF CP > S1 THEN
                  BCD = BCD || SUBSTR(TEXT,S1,CP-S1);
               CALL CHAR;
               IF BYTE(TEXT, CP) ^= BYTE('''') THEN
                  RETURN;
               IF LENGTH(BCD) > 255 THEN
                  DO;
                     CALL ERROR(LSTRNGM,0);
                     RETURN;
                  END;
               BCD = BCD || '''';
               TEXT_LIMIT = TEXT_LIMIT - CP;
               TEXT = SUBSTR(TEXT,CP);
               CP = 0;   /* PREPARE TO RESUME SCANNING STRING */
            END;

            /*  CASE 3  */

            DO;      /*  BIT QUOTE("):  BIT STRING  */
               JBASE = 4;  BASE = SHL(1, JBASE);  /* DEFAULT WIDTH  */
               TOKEN = NUMBER;  /* ASSUME SHORT BIT STRING */
               S1 = 0;
               CALL BCHAR;
               DO WHILE CH ^= BYTE('"');
                  S1 = S1 + JBASE;
                  IF CH >= "F0" THEN S2 = CH - "F0";  /* DIGITS */
                  ELSE S2 = CH - "B7";                /* LETTERS */
                  IF S2 >= BASE | S2 < 0 THEN
                     DO;
                     CALL ERROR ('ILLEGAL CHARACTER IN BIT STRING: '
                     || SUBSTR(TEXT, CP, 1));
                        IF CH=BYTE(';') THEN RETURN; /* GET OUT OF TROUBLE */
                     END;
                  IF S1 > 32 THEN TOKEN = STRING;     /* LONG BIT STRING */
                  IF TOKEN = STRING THEN
                     DO WHILE S1 - JBASE >= 8;
                        IF LENGTH(BCD) > "FF" THEN
                           DO;
                              CALL ERROR (LSTRNGM, 0);
                              RETURN;
                           END;
                        S1 = S1 - 8;
                        CALL BUILD_BCD (SHR(NUMBER_VALUE, S1-JBASE));
                     END;
                  NUMBER_VALUE = SHL(NUMBER_VALUE, JBASE) + S2;
                  CALL BCHAR;
               END;     /* OF DO WHILE CH...  */
               CP = CP + 1;
               IF TOKEN = STRING THEN
                  IF LENGTH(BCD) > "FF" THEN CALL ERROR (LSTRNGM, 0);
                  ELSE CALL BUILD_BCD (SHL(NUMBER_VALUE, 8 - S1));
               RETURN;
            END;

            /*  CASE 4  */

            DO FOREVER;  /* A LETTER:  IDENTIFIERS AND RESERVED WORDS */
               DO CP = CP + 1 TO TEXT_LIMIT;
                  IF NOT_LETTER_OR_DIGIT(BYTE(TEXT, CP)) THEN
                     DO;  /* END OF IDENTIFIER  */
                        IF CP > 0 THEN BCD = BCD || SUBSTR(TEXT, 0, CP);
                        S1 = LENGTH(BCD);
                        IF S1 > 1 THEN IF S1 <= RESERVED_LIMIT THEN
                           /* CHECK FOR RESERVED WORDS */
                           DO I = V_INDEX(S1-1) TO V_INDEX(S1) - 1;
                              IF BCD = V(I) THEN
                                 DO;
                                    TOKEN = I;
                                    RETURN;
                                 END;
                           END;
                        DO I = MACRO_INDEX(S1-1) TO MACRO_INDEX(S1) - 1;
                           IF BCD = MACRO_NAME(I) THEN
                              DO;
                                 BCD = MACRO_TEXT(I);
                                 IF EXPANSION_COUNT < EXPANSION_LIMIT THEN
                                    EXPANSION_COUNT = EXPANSION_COUNT + 1;
                                 ELSE
                                    CALL ERROR('TOO MANY EXPANSIONS FOR ' ||
                                    MACRO_NAME(I) || 'LITERALLY: ' || BCD, 1);
                                 TEXT = SUBSTR(TEXT, CP);
                                 TEXT_LIMIT = TEXT_LIMIT - CP;
                                 IF LENGTH(BCD) + TEXT_LIMIT > 255 THEN
                                    DO;
                                       IF LB + TEXT_LIMIT > 255 THEN
                                         CALL ERROR('MACRO EXPANSION TOO LONG');
                                       ELSE
                                          DO;
                                             BALANCE = TEXT || BALANCE;
                                             LB = LENGTH(BALANCE);
                                             TEXT = BCD;
                                          END;
                                    END;
                                 ELSE TEXT = BCD || TEXT;
                                 BCD = '';
                                 TEXT_LIMIT = LENGTH(TEXT) - 1;
                                 CP = 0;
                                 GO TO SCAN1;
                              END;
                        END;
                        /*  RESERVED WORDS EXIT HIGHER: THEREFORE <IDENTIFIER>*/
                        TOKEN = IDENT;
                        RETURN;
                     END;
               END;
               /*  END OF CARD  */
               BCD = BCD || TEXT;
               CALL GET_CARD;
               CP = -1;
            END;

            /*  CASE 5  */

            DO;      /*  DIGIT:  A NUMBER  */
               TOKEN = NUMBER;
               DO FOREVER;
                  DO CP = CP TO TEXT_LIMIT;
                     S1 = BYTE(TEXT, CP);
                     IF S1 < "F0" THEN RETURN;
                     NUMBER_VALUE = 10*NUMBER_VALUE + S1 - "F0";
                  END;
                  CALL GET_CARD;
               END;
            END;

            /*  CASE 6  */

            DO;      /*  A /:  MAY BE DIVIDE OR START OF COMMENT  */
               CALL CHAR;
               IF BYTE(TEXT, CP) ^= BYTE('*') THEN
                  DO;
                     TOKEN = DIVIDE;
                     RETURN;
                  END;
               /* WE HAVE A COMMENT  */
                 CH,CH2 = BYTE(' ');
                 DO WHILE CH ^= BYTE('*') | CH2 ^= BYTE('/');
                IF CH=BYTE('^') & CH2=BYTE('$') THEN
                     DO; /* TURN OFF THE TOGGLE */
                        CH = CH2; CALL CHAR; CH2 = BYTE(TEXT, CP);
                        CONTROL(CH2) = FALSE;
                        IF CH2=BYTE('T') THEN CALL UNTRACE; ELSE
                        IF CH2=BYTE('U') THEN CALL TRACE;
                     END;
                 ELSE
                 IF CH = BYTE('$') THEN
                     DO; /* A CONTROL CHARACTER */
                        CONTROL(CH2) = TRUE;
                        IF CH2 = BYTE('T') THEN CALL   TRACE;
                        ELSE IF CH2 = BYTE('U') THEN CALL UNTRACE;
                        ELSE IF CH2 = BYTE('|') THEN
                           IF CONTROL(CH2) THEN
                              MARGIN_CHOP = 1 + TEXT_LIMIT - CP;
                           ELSE
                              MARGIN_CHOP = 0;
                     END;
                  CH = CH2;
                  CALL CHAR;
                  CH2 = BYTE(TEXT, CP);
               END;
            END;

            /*  CASE 7  */
            DO;      /*  SPECIAL CHARACTERS  */
               TOKEN = TX(BYTE(TEXT));
               CP = 1;
               RETURN;
            END;

            /*  CASE 8  */
            DO;  /* A |:  MAY BE "OR" OR "CAT"  */
               CALL CHAR;
               IF BYTE(TEXT, CP) = BYTE('|') THEN
                  DO;
                     CALL CHAR;
                     TOKEN = CONCATENATE;
                  END;
               ELSE TOKEN = ORSYMBOL;
               RETURN;
            END;

         END;     /* OF CASE ON CHARTYPE  */
         CP = CP + 1;  /* ADVANCE SCANNER AND RESUME SEARCH FOR TOKEN  */
      END;
   END SCAN;


  /*             ADDRESS AND REGISTER COMPUTATIONS                       */


CHECKBASES:
   PROCEDURE;
      IF ^ COMPILING THEN RETURN;
      IF DP >= BASES(LASTBASE) + 4096 THEN
         DO;
            LASTBASE = LASTBASE - 1;  /* USE REG 11 DOWN TO REG 4 */
            BASES(LASTBASE) = DP & "FFFFFC";
            INFORMATION = INFORMATION || ' R' || LASTBASE || EQUALS ||
               BASES(LASTBASE) || PERIOD;
            IF LASTBASE = 3 THEN CALL ERROR('EXCEEDED DATA AREA',1);
         END;
   END  CHECKBASES;

CLEARREGS:
   PROCEDURE;
      /* FREE ALL THE ARITHMETIC REGISTERS  */
      TARGET_REGISTER=3; CLEARIT: BASES(TARGET_REGISTER)= AVAIL;
      TARGET_REGISTER = TARGET_REGISTER - 1;
      IF TARGET_REGISTER>=0 THEN GOTO CLEARIT; /* LEAVES -1 IN TARGET_REGISTER*/
   END  CLEARREGS;

FINDAC:
   PROCEDURE FIXED;
      /*  FIND AN ACCUMULATOR FOR 32 BIT QUANTITY  */
      DECLARE I FIXED;
      IF TARGET_REGISTER>=0 THEN IF BASES(TARGET_REGISTER) = AVAIL THEN
         DO;
            BASES(TARGET_REGISTER) = ACCUMULATOR;
            RETURN TARGET_REGISTER;
         END;
      DO I = 1 TO 3;
         IF BASES(I) = AVAIL THEN
            DO;
               BASES(I) = ACCUMULATOR;
               RETURN I;
            END;
      END;
      CALL ERROR('USED ALL ACCUMULATORS',0);
      RETURN 0;
   END  FINDAC;


FINDADDRESS:
   PROCEDURE (ADR);
      /* FIND THE APPROPRIATE BASE AND DISPLACEMENT FOR THE ADDRESS  */
      DECLARE (ADR, I) FIXED;
      COUNT#FIND = COUNT#FIND + 1;
      IF ADR < 0 THEN
         DO;
            ADRDISP = - ADR;
            ADREG = SBR;
            RETURN;
         END;
      IF ADR = 0 THEN
         DO;
            ADREG,ADRDISP = 0;
            RETURN;
         END;
      DO I = LASTBASE TO DBR;
         IF BASES(I) <= ADR & BASES(I)+4096 > ADR THEN
            DO;
               ADRDISP = ADR - BASES(I);
               ADREG = I;
               RETURN;
            END;
      END;
      CALL ERROR('FIND ADDRESS FAILED',1);
      ADREG,ADRDISP = 0;
   END  FINDADDRESS;




  /*                    CODE EMISSION PROCEDURES                       */


EMITCHAR:
   PROCEDURE (C);
      DECLARE C BIT (8);
      /*  SEND ONE 8-BIT CHARACTER TO THE STRING AREA  */
      IF CONTROL(BYTE('E')) THEN
         OUTPUT = X70 || CHP || ': CHARACTER = ' ||
            SUBSTR(HEXCODES, SHR(C,4), 1) || SUBSTR(HEXCODES, C & "F", 1);
      IF CHP < CHPORG | CHP >= CHPLIM THEN CALL GETSTRINGS;
      STRINGS(CHP-CHPORG) = C;
      CHP = CHP + 1;
   END  EMITCHAR;

EMITBYTE:
   PROCEDURE (B);
      DECLARE B BIT(8);
      /*  EMIT ONE BYTE OF DATA  */
      IF DP < DPORG | DP >= DPLIM THEN CALL GETDATA;
      DATA(DP-DPORG) = B;
      IF CONTROL(BYTE('E')) THEN
         OUTPUT = DP ||  DATAQ ||
            SUBSTR(HEXCODES, SHR(B,4), 1) || SUBSTR(HEXCODES, B & "F", 1);
      DP = DP + 1;
      CALL CHECKBASES;
   END EMITBYTE;

EMITCODEBYTES:
   PROCEDURE (B1,B2);
      DECLARE (B1, B2) BIT(8), I FIXED;
      /*  EMIT TWO BYTES OF CODE  */
      SAVEADR ,
      STILLCOND = 0;
      IF PP < PPORG | PP >= PPLIM THEN CALL GETCODE;
      I = PP - PPORG;
      CODE(I) = B1;             /*  FIRST  BYTE  */
      CODE(I+1) = B2;           /*  SECOND  BYTE  */
      IF CONTROL(BYTE('B')) THEN
         OUTPUT = PP || CODEQ ||
            SUBSTR(HEXCODES, SHR(B1,4), 1) || SUBSTR(HEXCODES, B1 & "F", 1)
            || SUBSTR(HEXCODES, SHR(B2,4), 1) || SUBSTR(HEXCODES, B2 & "F",1);
      PP =  PP + 2;
   END  EMITCODEBYTES ;

EMITDATAWORD:
   PROCEDURE(W);
      DECLARE (W, I) FIXED;
      /*  SEND A 32-BIT WORD TO THE DATA ARRAY  */
      DP = (DP + 3) & "FFFFFC";
      IF DP < DPORG | DP >= DPLIM THEN CALL GETDATA;
      CALL CHECKBASES;
      IF CONTROL(BYTE('E')) THEN
         OUTPUT = DP || DATAQ || W;
      I = SHR(DP-DPORG, 2) +1; /* CONVERT TO WORD ADDRESSING */
      DATAMAX(I)=W;
      DP = DP + 4;
      CALL CHECKBASES;
   END EMITDATAWORD;

EMITDESC:
   PROCEDURE (D);
      DECLARE D FIXED;
      /*  SEND 32-BIT DESCRIPTOR TO STRING DESCRIPTOR AREA  */
      IF DSP >= 4096 THEN
         DO;
            CALL ERROR ('TOO MANY STRINGS', 1);
            RETURN;
         END;
      IF CONTROL(BYTE('E')) THEN
         OUTPUT = X70 || DSP || ': DESC = ' || SHR(D,24) || ', ' ||
            (D & "FFFFFF");
      DESC(SHR(DSP,2)) = D;
      DSP = DSP + 4;
   END EMITDESC;

EMITCONSTANT:
   PROCEDURE(C);
      /* SEE IF C HAS ALREADY BEEN EMITED, AND IF NOT EMIT.  SET UP ADDRESS */
      DECLARE CTAB(59) FIXED, CADD(59) BIT(16), C FIXED, I BIT(16),
         NC BIT(16) INITIAL("FFFF");
     DO I = 0 TO NC;
         IF CTAB(I) = C THEN
            DO;
               ADREG = SHR(CADD(I), 12) & "F"; /* & TO REMOVE SIGN BIT */
               ADRDISP = CADD(I) & "FFF";
               RETURN;
            END;
      END;
      CALL EMITDATAWORD (C);
      CTAB(I) = C;
      CALL FINDADDRESS(DP-4);
      CADD(I) = SHL(ADREG,12) + ADRDISP;
      IF I<59 THEN NC=I;
      INFORMATION = INFORMATION || ' C' || I || EQUALS || C || PERIOD;
   END EMITCONSTANT;

EMITRR:
   PROCEDURE (OP, R1, R2);
      DECLARE (OP, R1, R2) BIT(8);
      /* EMIT A 16-BIT RR FORMAT INSTRUCTION  */
      COUNT#RR = COUNT#RR + 1;
      IF CONTROL(BYTE('E')) THEN
         DO;
            OP_CODE = SUBSTR(OPNAMES, SHL(OPER(OP), 2), 4);
            OUTPUT = PP || CODEQ || OP_CODE || X1 || R1 || COMMA || R2;
         END;
      CALL EMITCODEBYTES(OP, SHL(R1,4)+R2);
      INSTRUCT(OP) = INSTRUCT(OP) + 1;
   END EMITRR;

EMITRX:
   PROCEDURE (OP, R1, R2, R3, DISP);
      DECLARE (OP, R1, R2, R3) BIT(8), DISP FIXED;
      /*  EMIT A 32-BIT RX FORMAT INSTRUCTION */
      COUNT#RX = COUNT#RX + 1;
      IF CONTROL(BYTE('E')) THEN
         DO;
            OP_CODE = SUBSTR(OPNAMES, SHL(OPER(OP), 2), 4);
            OUTPUT = PP || CODEQ || OP_CODE || X1 || R1 || COMMA || DISP ||
               LPAR || R2 || COMMA|| R3 || RPAR;
         END;
      CALL EMITCODEBYTES(OP, SHL(R1,4)+R2);
      CALL EMITCODEBYTES(SHL(R3,4)+SHR(DISP,8), DISP & "FF");
      INSTRUCT(OP) = INSTRUCT(OP) + 1;
   END EMITRX;


EMITSS:
   PROCEDURE(OP, LENGTH, AD1, AD2);
      /* EMIT A 48-BIT SS INSTRUCTION */
      DECLARE (OP, LENGTH) BIT(8), (AD1, AD2) BIT(16);
      IF CONTROL(BYTE('E')) THEN
         DO;
            OP_CODE = SUBSTR(OPNAMES,SHL(OPER(OP),2),4);
            OUTPUT = PP || CODEQ   || OP_CODE || X1 ||(AD1 & "FFF")|| LPAR
                     || LENGTH+1 || COMMA ||(SHR(AD1, 12) & "F")|| '),' ||
                     (AD2 & "FFF") || LPAR ||(SHR(AD2, 12) & "F")|| RPAR;
         END;
      CALL EMITCODEBYTES(OP, LENGTH);
      CALL EMITCODEBYTES(SHR(AD1,8), AD1);
      CALL EMITCODEBYTES(SHR(AD2,8), AD2);
      INSTRUCT(OP) = INSTRUCT(OP)+1;
   END  EMITSS;


LOAD_CONSTANT:
   PROCEDURE(OP, REG, CONST);
      DECLARE REG BIT(8), OP BIT(8),
         CONST FIXED;
HALF_CONST:
   PROCEDURE;
      /* EMITS HALFWORD CONSTANTS. SEE IF CONST HAS ALREADT BEEN EMITTED.
         IF NOT, SET UP, ADDRESS */
      DECLARE CTAB(49) BIT(16), CADD(49) BIT(16), C FIXED, I BIT(16),
         NC BIT(16) INITIAL ("FFFF");
      DO I = 0 TO NC;
         IF CTAB(I) = CONST THEN
            DO;
                ADREG = SHR(CADD(I),12) & "F";
                ADRDISP = CADD(I) & "FFF";
                RETURN;
            END;
      END;
      DP=(DP&1)+DP; /* ALIGN HALFWORD BOUNDARY */
      CTAB(I) = CONST;
      CALL FINDADDRESS(DP);
      CALL EMITBYTE(SHR(CONST, 8)); CALL EMITBYTE(CONST);
      CADD(I)= SHL(ADREG,12) | ADRDISP;
      IF I<49 THEN NC=I;
      INFORMATION = INFORMATION || ' CH'|| I || EQUALS || CONST || PERIOD;
   END HALF_CONST;
      IF (((OP>=LOAD) & (OP<="5C")) | (OP="50")) &
         (CONST>="FFFF8000") & (CONST<="FFFF") THEN
         DO;
            IF OP="5C" THEN REG=REG+1;
            CALL HALF_CONST;
            OP = OP - 16; /* HALFWORD OPERATION CODE */
         END;
      ELSE CALL EMITCONSTANT (CONST);
      CALL EMITRX(OP, REG, 0, ADREG, ADRDISP);
   END LOAD_CONSTANT;


  /*                       FIXUP PROCEDURES                                  */



INSERT_CODE_FIXUPS:
   PROCEDURE;
      /* EMPTY THE FIXUP TABLE, EITHER FOR LOADING OR BECAUSE OF
         TABLE OVERFLOW */
      DECLARE (I, J, L, FXLIM, T1, K) FIXED;
      DECLARE T2 BIT(8), EXCHANGES BIT(1);

      /* THE FIRST STEP IS TO SORT THE CODE FIXUP TABLE */
      K,FXLIM = FCP - 1;     EXCHANGES = TRUE;
      DO WHILE EXCHANGES;  /* QUIT BUBBLE SORT AFTER TABLE QUIETS DOWN */
         EXCHANGES = FALSE;  /* RESET ON EACH EXCHANGE BELOW */
         DO J = 0 TO K-1;
            I = FXLIM-J;
            L = I-1;
            IF FIXCADR(L) > FIXCADR(I) THEN
               DO;  /* SWAP */
                  T1 = FIXCADR(L);  FIXCADR(L) = FIXCADR(I);  FIXCADR(I) = T1;
                  T2 = FIXCB1(L);  FIXCB1(L) = FIXCB1(I);  FIXCB1(I) = T2;
                  T2 = FIXCB2(L);  FIXCB2(L) = FIXCB2(I);  FIXCB2(I) = T2;
                  EXCHANGES = TRUE;  K = J;
               END;
         END;
      END;

      /* NOW WRITE OUT THE CURRENT BLOCK */
      FILE(CODEFILE,CURCBLK) = CODE;

      /* WRITE BINARY PROGRAM PATCHES INTO PROGRAM FILE */

      K,PPORG=0;  PPLIM = DISKBYTES;
      DO J = 0 TO CODEMAX;

         I = K;  /* KEEP TRACK OF K SO THAT WE WILL KNOW WHEN TO READ IN */

         DO WHILE (K <= FXLIM)  &  (FIXCADR(K) < PPLIM);
            /* IF THE FILE HAS NOT YET BEEN READ IN, DO SO */
            IF K = I THEN CODE = FILE(CODEFILE,J); /* ONLY IF A FIX IS NEEDED */
            L = FIXCADR(K) - PPORG;  /* RELATIVE ADDRESS WITHIN THIS BLOCK */
            CODE(L) = FIXCB1(K);  CODE(L+1) = FIXCB2(K);
            K = K + 1;
         END;

         IF K > I THEN    /* A FIXUP WAS DONE */
            FILE(CODEFILE,J) = CODE;  /* SO WRITE OUT THE CONTENTS */

         PPORG = PPORG + DISKBYTES;
         PPLIM = PPLIM + DISKBYTES;
      END;

      FCP = 0;  /* RESET TABLE TO EMPTY */
      CODE = FILE(CODEFILE,CURCBLK);  /* RESTORE FILE TO PREVIOUS STATE */
      PPORG = CURCBLK*DISKBYTES;  PPLIM = PPORG + DISKBYTES;
   END INSERT_CODE_FIXUPS;

FIXCHW:
   PROCEDURE (ADR, B1, B2);
      DECLARE ADR FIXED, (B1, B2) BIT(8);
      /*  FIX UP ONE HALF WORD OF CODE  */
      COUNT#FIXCHW = COUNT#FIXCHW + 1;
      IF FCP >= FCLIM THEN
         CALL INSERT_CODE_FIXUPS;
      IF PPORG <= ADR & ADR < PPLIM THEN
         DO;
            SHORTCFIX = SHORTCFIX + 1;
            ADR = ADR - PPORG;
            CODE(ADR) = B1;
            CODE(ADR+1) = B2;
         END;
      ELSE
         DO;
            LONGCFIX = LONGCFIX + 1;
            FIXCADR(FCP) = ADR;
            FIXCB1(FCP) = B1;
            FIXCB2(FCP) = B2;
            FCP = FCP + 1;
         END;
   END  FIXCHW;


FIXBFW:
   PROCEDURE (WHERE, VAL);
      DECLARE (WHERE, VAL, I, J, P) FIXED;
      IF WHERE = 0 THEN RETURN;
      /* FIX UP A BRANCH WHOSE ADDRESS WE NOW KNOW */
      COUNT#FIXBFW = COUNT#FIXBFW + 1;
      IF CONTROL(BYTE('E')) THEN
         OUTPUT = X4 || WHERE || FIXUPM || VAL;
      P = WHERE + 2;       /* THE ACTUAL ADDRESS FIELD  */
      I = VAL & "FFF";  J = SHL(SHR(VAL,12), 2);
      IF WHERE > "FFF" THEN
         DO;
            CALL FIXCHW(P, SHL(DBR,4), J);
            VAL = I;
            P = P + 4;
         END;
      ELSE IF VAL >= "1000" THEN
         DO;
            INSTRUCT(LOAD) = INSTRUCT(LOAD) + 1;
            INSTRUCT(BC) = INSTRUCT(BC) + 1;
            CALL EMITDATAWORD(SHL(BRCHREG+"580", 20)+SHL(DBR, 12) + J);
            CALL EMITDATAWORD(SHL("47F0"+BRCHREG, 16) + SHL(PBR, 12) + I);
            CALL FINDADDRESS (DP-8);
            CALL FIXCHW(P, SHL(ADREG,4)+SHR(ADRDISP,8), ADRDISP & "FF");
            RETURN;
         END;
      CALL FIXCHW(P, SHL(PBR,4)+SHR(VAL,8), VAL & "FF");
   END FIXBFW;


FIXWHOLEDATAWORD:
   PROCEDURE (ADR, WORD);
      DECLARE (ADR, WORD) FIXED;
      DECLARE (BLK, TEMP) FIXED;
      IF CONTROL(BYTE('E')) THEN
         OUTPUT = ADR || FIXUPM || WORD;
      COUNT#FIXD = COUNT#FIXD + 1;
      BLK = ADR/DISKBYTES;
      IF CURDBLK^=BLK THEN
         DO;  /* MUST GET THE RIGHT BLOCK  */
            LONGDFIX = LONGDFIX + 1;
            TEMP = DP;
            DP = ADR;
            CALL GETDATA;
            DP = TEMP;
         END;
      ELSE SHORTDFIX = SHORTDFIX + 1;
      ADR = ADR MOD DISKBYTES;
         /* SHIFT TO WORD INDEXING */
         DATAMAX(SHR(ADR,2)+1) = WORD;
   END  FIXWHOLEDATAWORD;


HASHER:
   PROCEDURE(ID);
      DECLARE ID CHARACTER, L BIT(16);
      CALL INLINE("1B", 0, 0);
      L = INLINE("43",0, 0,ID) + 1; /* LENGTHS ARE ALWAYS >=1 */
      RETURN (BYTE(ID)+BYTE(ID,L-1)+SHL(L,4)) & "FF" ;
   END HASHER;

ENTER:
   PROCEDURE (N, T, L, LINE);
      /*  ENTER A SYMBOL IN THE SYMBOL TABLE  */
      DECLARE (I, J, K, L, T, LINE) FIXED, N CHARACTER;

      IDX = HASHER(N);
      I = HASH(IDX);
      DO WHILE I>= PROCMARK;
         /* NOW TEST FOR NAMES USING INDIRECT INDICES */
         IDCOMPARES = IDCOMPARES + 1;
         IF N = SYT(I) THEN
            DO;
               K = SYTYPE(I);
               IF T = LABELTYPE & (K = FORWARDTYPE | K = FORWARDCALL) THEN
                  DO;
                     IF CONTROL(BYTE('E')) THEN
                        OUTPUT = X70 || 'FIX REFERENCES TO: ' || N;
                     J = BASES(SYBASE(I))+ SYDISP(I);
                     IF K = FORWARDCALL THEN
                    L = L + 4 + SHL(L>"FFF", 2);
                     SYBASE(I) = SHR(L, 12);
                     SYDISP(I) = L & "FFF";
                     CALL FIXWHOLEDATAWORD(J,L);
                     SYTYPE(I) = T;
                  END;
               ELSE IF PROCMARK + PARCT < I THEN
                  CALL ERROR('DUPLICATE DECLARATION FOR:  ' || N, 0);
               DECLARED_ON_LINE(I) = LINE;
               RETURN I;
            END;
         I = PTR(I);  /* CHECK NEXT LINK */
      END;
      NDECSY = NDECSY + 1;
      IF NDECSY > MAXNDECSY THEN
         IF NDECSY > SYTSIZE THEN
            DO;
               CALL ERROR ('SYMBOL TABLE OVERFLOW', 1);
               NDECSY = NDECSY - 1;
            END;
         ELSE MAXNDECSY = NDECSY;
      SYT(NDECSY) = N;
      /* LINK IN HASH ID AS LEGAL */
      PTR(NDECSY) = HASH(IDX);
      HASH(IDX) = NDECSY;
      SYTYPE(NDECSY) = T;
      DECLARED_ON_LINE(NDECSY) = LINE;
      SYTCO(NDECSY) = 0;
      IF T = LABELTYPE THEN
         DO;
            SYBASE(NDECSY) = SHR(L, 12);  /* PAGE  */
            SYDISP(NDECSY) = L & "FFF";
         END;
      ELSE
         DO;
            CALL FINDADDRESS(L);
            SYBASE(NDECSY) = ADREG;
            SYDISP(NDECSY) = ADRDISP;
         END;
      IDCOMPARES = IDCOMPARES + NDECSY - PROCMARK;
      RETURN NDECSY;
   END  ENTER;

ID_LOOKUP:
   PROCEDURE (P);
       /* LOOKS UP THE IDENTIFIER AT P IN THE ANALYSIS STACK IN THE
          SYMBOL TABLE AND INITIALIZES FIXL,CNT,TYPE,REG,INX
          APPROPRIATELY.  IF THE IDENTIFIER IS NOT FOUND, FIXL IS
          SET TO -1
       */
       DECLARE P FIXED, I FIXED;
       CHAR_TEMP = VAR(P);
      I = HASH(HASHER(CHAR_TEMP));
      DO WHILE I ^= -1;
         IDCOMPARES = IDCOMPARES+1;
         IF SYT(I) = CHAR_TEMP THEN
            DO;
               FIXL(P) = I;
               CNT(P)=0;  /* INITIALIZE SUBSCRIPT COUNT */
               TYPE(P) = VARIABLE;
               IF SYTYPE(I) = SPECIAL THEN FIXV(P) = SYDISP(I); /* BUILTIN FN */
               ELSE FIXV(P) = 0;
               REG(P),INX(P)=0; /* INITIALIZE REGISTER POINTERS */
               SYTCO(I) = SYTCO(I) + 1; /* COUNT REFERENCES */
               RETURN;
            END;
         I = PTR(I);
      END;
      FIXL(P) = -1;      /*  IDENTIFIER NOT  FOUND */
   END   ID_LOOKUP;


UNDECLARED_ID:
   PROCEDURE (P);
      /* ISSUES AN ERROR MESSAGE FOR UNDECLARED IDENTIFIERS AND
         ENTERS THEM WITH DEFAULT TYPE IN THE SYMBOL TABLE
      */
      DECLARE P FIXED;
      CALL ERROR('UNDECLARED IDENTIFIER:  ' || VAR(P) ,0);
      CALL EMITDATAWORD(0);
      CALL ENTER (VAR(P), FIXEDTYPE, DP-4, CARD_COUNT);
      CNT(P) = 0;
      FIXV(P) = 0;
      REG(P) = 0;
      INX(P) = 0;
      FIXL(P) = NDECSY;
      SYTCO(NDECSY) = 1;                /* COUNT FIRST REFERENCE */
      TYPE(P) = VARIABLE;
   END  UNDECLARED_ID;

SETINIT:
   PROCEDURE;
      /*  PLACES INITIAL VALUES INTO DATA AREA */

      DECLARE (I, J) FIXED;
      IF ITYPE = CHRTYPE THEN
         DO;
            IF TYPE(MPP1) ^= CHRTYPE THEN VAR(MPP1) = FIXV(MPP1);
            S = VAR(MPP1);    /* THE STRING */
            I = LENGTH(S) - 1;

            IF I < 0 THEN
               CALL EMITDESC(0);
            ELSE
               CALL EMITDESC(SHL(I,24) + CHP);

            DO J = 0 TO I;
               CALL EMITCHAR(BYTE(S,J));
            END;
         END;
      ELSE IF TYPE(MPP1) ^= CONSTANT THEN
         CALL ERROR ('ILLEGAL CONSTANT IN INITIAL LIST');
      ELSE IF ITYPE = FIXEDTYPE THEN
         CALL EMITDATAWORD(FIXV(MPP1));
      ELSE IF ITYPE = HALFWORD THEN
         DO;
            /*  FIRST FORCE ALIGNMENT  */
            DP = (DP & 1) + DP;
            CALL EMITBYTE (SHR(FIXV(MPP1), 8));
            CALL EMITBYTE(FIXV(MPP1));
         END;
      ELSE IF ITYPE = BYTETYPE THEN
         CALL EMITBYTE(FIXV(MPP1));
   END  SETINIT;

ALLOCATE :
   PROCEDURE(P,DIM);
      /* ALLOCATES STORAGE FOR THE IDENTIFIER AT P IN THE ANALYSIS
         STACK WITH DIMENSION DIM
      */

      DECLARE (P, DIM, J) FIXED;


   CHECK_NEWDP:
      PROCEDURE;
         DECLARE T FIXED;
         T = DP;
         DP = NEWDP;
         CALL CHECKBASES;
         DP = T;
      END  CHECK_NEWDP;



      DIM = DIM + 1;         /* ACTUAL NUMBER OF ITEMS  */
      DO CASE TYPE(P);

         ;     /*  CASE  0    DUMMY        */

         DO;      /*   CASE 1    HALFWORD  */
            NEWDP = (NEWDP & 1) + NEWDP;  /* ALIGN HALFWORD */
            CALL CHECK_NEWDP;
            J = NEWDP;
            NEWDP = NEWDP + SHL(DIM, 1);
         END;


         ;     /*  CASE  2    LABEL TYPE         */


          ;    /*  CASE  3    ACCUMULATOR        */

          ;    /*  CASE  4    VARIABLE           */

          ;    /*  CASE  5    CONSTANT           */

          ;    /*  CASE  6    CONDITION          */

          DO;  /*  CASE  7    CHARACTER TYPE     */
            IF NEWDSP>4095 THEN
               DO;
                  CALL ERROR('TOO MANY STRINGS', 1); NEWDSP=NEWDSP & "FFF";
               END;
            J = -NEWDSP;
            NEWDSP = NEWDSP + SHL(DIM,2);
          END;

          DO;  /*  CASE  8    FIXED TYPE         */
            NEWDP = (NEWDP + 3) & "FFFFFC";    /* ALIGN TO WORD */
            CALL CHECK_NEWDP;
            J = NEWDP;
            NEWDP = NEWDP + SHL(DIM,2);
          END;

          DO;  /*  CASE  9    BYTE TYPE          */
            CALL CHECK_NEWDP;
            J = NEWDP;
            NEWDP = NEWDP + DIM;
          END;

         DO;  /*  CASE 10    FORWARD TYPE  (LABEL)  */
            NEWDP = (NEWDP+3) & "FFFFFC";  /* WORD ALIGN */
            CALL CHECK_NEWDP;
            J = NEWDP;
            NEWDP = NEWDP + SHL(DIM,2);        /* SPACE FOR FIXUPS  */
         END;

          ;    /*  CASE 11    DESCRIPT           */

          ;    /*  CASE 12    SPECIAL            */

          ;    /*  CASE 13    FORWARD CALL       */

          ;    /*  CASE 14    CHAR_PROC_TYPE             */

          ;    /*  CASE 15    UNUSED             */

      END; /*  OF DO CASE TYPE(P)  */

      SYTYPE(FIXL(P)) = TYPE(P);
      CALL FINDADDRESS(J);
      SYBASE(FIXL(P)) = ADREG;
      SYDISP(FIXL(P)) = ADRDISP;

   END  ALLOCATE;


TDECLARE:
   PROCEDURE (DIM);
      /*  ALLOCATES STORAGE FOR IDENTIFIERS IN DECLARATIONS  */
      DECLARE DIM FIXED;
      NEWDP = DP;
      NEWDSP = DSP;
      TYPE(MP) = TYPE(SP);
      CASEP = FIXL(MP);
      DO I = 1 TO INX(MP);
         FIXL(MP) = CASESTACK(CASEP+I);      /* SYMBOL TABLE POINTER */
         CALL ALLOCATE(MP, DIM);
      END;
   END  TDECLARE;




MOVESTACKS:
   PROCEDURE (F,T);
      DECLARE F FIXED, T FIXED;
      /*  MOVE ALL THE COMPILER STACKS DOWN FROM F TO T  */
      TYPE(T) = TYPE(F);  VAR(T) = VAR(F);
      FIXL(T) = FIXL(F);  FIXV(T) = FIXV(F);
      INX(T) = INX(F);    REG(T) = REG(F);
      PPSAVE(T) = PPSAVE(F);  CNT(T) = CNT(F);
   END  MOVESTACKS;




  /*                        BRANCH PROCEDURES                                */



BRANCH_BD:
   PROCEDURE(COND, B, D);
      DECLARE COND BIT(8), (B, D) FIXED;
      /*  BRANCHES ARE A SPECIAL CASE.  IF THEY ARE INTO THE 1ST  4096
         BYTES OF PROGRAM A SINGLE BRANCH WILL SUFFICE.  OTHERWISE WE
         MUST INDEX WITH A CONSTANT IN BRCHREG TO GET ANYWHERE.
      */
      IF B = 0 THEN
         CALL EMITRX(BC, COND, 0, PBR, D);
      ELSE
         DO;
            CALL EMITRX(LOAD,BRCHREG,0,DBR,SHL(B,2));
            CALL EMITRX(BC, COND, BRCHREG, PBR, D);
         END;
   END  BRANCH_BD;


BRANCH:
   PROCEDURE (COND, LOCATION);
      DECLARE COND BIT(8), LOCATION FIXED;
      IF LOCATION = 0 THEN LOCATION = PP;
      /* ASSUME FIXUP WILL BE NEAR  */
      CALL BRANCH_BD(COND, SHR(LOCATION,12), LOCATION & "FFF");
   END BRANCH;




  /*                     EXPRESSIONS                                         */


CONDTOREG:
   PROCEDURE (MP, CC);
      DECLARE MP FIXED, (CC, J) BIT(8);
      J = FINDAC;
      FIXL(MP)  = CC + SHL(PP,4);  /* SAVE TILL THE END OF THIS PROCEDURE */
       /* SPECIAL CASES ARE SHORTER--NO BRANCH NEEDED */
      /* > AND < */
      IF (CC=12) | (CC=10) THEN
          DO;
            CALL EMITRR (BALR, J, 0); /* GET THE CONDITION CODE */
            CALL EMITRX("89", J, 0, 0, 2+(CC=10));
            CALL EMITRX("88", J, 0, 0, 31);
         END;
      ELSE
      DO;
      CALL EMITRX (LA, J, 0, 0, 1);
      IF PP<4088 THEN
         CALL BRANCH(14-CC, PP+6);
      ELSE
         DO;
            CALL EMITRR ("05", BRCHREG, 0);
            CALL EMITRX (BC, 14-CC, 0, BRCHREG, 6);
         END;
      CALL EMITRR("06", J, 0);
      END;
      STILLCOND = FIXL(MP);
      TYPE(MP) = ACCUMULATOR;
      REG(MP) = J;
   END CONDTOREG;

BRLINK_BD:
   PROCEDURE (BASE,DISP);
      DECLARE (BASE, DISP) FIXED;
      IF BASE = 0 THEN
         CALL EMITRX(BAL, BRCHREG, 0, PBR, DISP);
      ELSE
         DO;
            CALL EMITRX(LOAD, BRCHREG, 0, DBR, SHL(BASE,2));
            CALL EMITRX(BAL, BRCHREG, BRCHREG, PBR, DISP);
         END;
   END  BRLINK_BD;


   /*                  CODE FOR PROCEDURES                                   */


SAVE_REGISTERS:
   PROCEDURE;
      /* GENERATES CODE TO SAVE REGISTERS BEFORE A PROCEDURE OR
         FUNCTION CALL
      */
      DECLARE I FIXED;
      DO I = 1 TO 3;
         IF BASES(I) ^= AVAIL THEN
            DO;
               CALL EMITDATAWORD(0);
               CALL FINDADDRESS(DP-4);
               TEMP(I) = SHL(ADREG,12)+ ADRDISP;
               CALL EMITRX(STORE,I,0,ADREG,ADRDISP);
            END;
         ELSE
            TEMP(I) = 0;
      END;
   END  SAVE_REGISTERS;


UNSAVE_REGISTERS:
   PROCEDURE (R,P);
      /*  GENERATES CODE TO RESTORE REGISTERS AFTER A FUNCTION
          OR PROCEDURE CALL AND ALSO DOES SOME HOUSEKEEPING
      */
      DECLARE (R, P, I, J) FIXED;
      IF BASES(R) ^= AVAIL THEN
         DO;
            J = FINDAC;
            CALL EMITRR("18", J, R);
         END;
      ELSE
         J = R;
      DO I = 1 TO 3;
         IF TEMP(I) ^= 0 THEN
            CALL EMITRX(LOAD,I,0,SHR(TEMP(I),12), TEMP(I)&"FFF");
      END;
      TYPE(P) = ACCUMULATOR;
      REG(P) = J;
      BASES(J) = ACCUMULATOR;
   END  UNSAVE_REGISTERS;




CALLSUB:
   PROCEDURE (SB,SD, R, P);
      DECLARE (SB, SD, R, P) FIXED;
      CALL SAVE_REGISTERS;
      CALL BRLINK_BD(SB,SD);
      CALL UNSAVE_REGISTERS(R, P);
   END  CALLSUB;


CALLSUB_FORWARD:
   PROCEDURE (SB,SD,R,P);
      DECLARE (SB, SD, R, P) FIXED;
      CALL SAVE_REGISTERS;
      CALL EMITRX(LOAD, BRCHREG, 0, SB,SD);
      CALL EMITRX(BAL, BRCHREG, BRCHREG, PBR, 0);
      CALL UNSAVE_REGISTERS(R, P);
   END  CALLSUB_FORWARD;



FORCE_ADDRESS:
   PROCEDURE (SP,R);
      /* GENERATES THE ADDRESS OF THE <VARIABLE> IN THE ANALYSIS
         STACK AT SP IN REGISTER R.
      */
      DECLARE (SP, K)FIXED, (R,    INXSP) BIT(8);
      IF SYTYPE(FIXL(SP)) = LABELTYPE THEN
         DO;
            K = FIXL(SP);
            IF SYBASE(K) = 0 THEN
               CALL EMITRX(LA,R,0,PBR,SYDISP(K));
            ELSE
               DO;
                  CALL EMITRX(LOAD,R,0,DBR,SHL(SYBASE(K),2));
                  CALL EMITRX(LA,R,R,PBR,SYDISP(K));
               END;
         END;
      ELSE
         DO;
            K = SYTYPE(FIXL(SP));
            INXSP = INX(SP);
            IF INXSP ^= 0 THEN
               DO;
                  IF K ^= BYTETYPE THEN
                     IF K = HALFWORD THEN
                        CALL EMITRR ("1A", INXSP, INXSP);
                     ELSE
                        CALL EMITRX("89",INXSP,0,0,2);
                  BASES(INXSP) = AVAIL;
               END;
            IF K = FORWARDTYPE | K = FORWARDCALL THEN
               DO;
                  K = FIXL(SP);
                  CALL EMITRX(LOAD,R,0,SYBASE(K),SYDISP(K));
                  CALL EMITRR("1A",R,PBR);
               END;
            ELSE
               CALL EMITRX(LA,R,INXSP,SYBASE(FIXL(SP)),SYDISP(FIXL(SP)));
         END;
   END  FORCE_ADDRESS;


FILE_PSEUDO_ARRAY:
   PROCEDURE (VARP,FILEP, DIRECTION);
      /* PROCEDURE TO GENERATE CODE FOR THE FILE PSEUDO ARRAY.
         TWO FORMS ARE HANDLED:

               <VARIABLE>  =  FILE(I,J);

               FILE(I,J)  =  <VARIABLE>;

         VARP IS A POINTER TO THE <VARIABLE> IN THE ANALYSIS STACKS.
         FILEP IS A POINTER TO THE ANALYSIS STACK WHERE FILE(I,J)
         HAS BEEN ASSIMILATED UNDER THE GUISE OF A SUBSCRIPTED
         VARIABLE.  DIRECTION = 0 FOR THE FIRST CASE (READ) AND
         DIRECTION = 4 FOR THE SECOND CASE (WRITE).  I IS THE FILE
         INDEX (I = 1,2,3) AND J IS THE RELATIVE RECORD WITHIN THE
         FILE.  THE GENERATED CODE SHOULD HAVE THE SAME EFFECT AS;

               LA   0,<VARIABLE>
               L    1,I
               SLL  1,3                 I*8
               LA   1,DIRECTION+44(,1)
               L    2,J
               BALR BRCHREG,IOREG

         REGISTERS 0-3 ARE NOT PRESERVED ACROSS THE MONITOR CALL,
         HENCE ALL REGISTERS ARE FREED,

      */
      DECLARE (VARP, DIRECTION, FILEP, R) FIXED;
      IF TYPE(VARP) = VARIABLE THEN
         DO;
            CALL FORCE_ADDRESS(VARP,0);
            CALL EMITRX("89",REG(FILEP),0,0,3);   /*  I*8  */
            R = FINDAC;
            IF INX(FILEP) = 1 THEN
               DO;                      /*  JUGGLE REGISTERS  */
                  CALL EMITRR("18",R,1);
                  INX(FILEP) = R;
               END;
            CALL EMITRX(LA,1,0,REG(FILEP),44+DIRECTION);
            IF INX(FILEP) ^= 2 THEN
               CALL EMITRR("18",2,INX(FILEP));    /*  J    */
            CALL EMITRR(BALR,BRCHREG,IOREG);
            TYPE(FILEP) = SPECIAL;      /*  NO MORE ASSIGNMENTS  */
            CALL CLEARREGS;            /*  FREE ALL REGISTERS  */
         END;
      ELSE
         CALL ERROR('ILLEGAL USE OF FILE PSEUDO ARRAY',1);
   END  FILE_PSEUDO_ARRAY;


EMIT_INLINE:
   PROCEDURE;

      /* GENERATES CODE FOR THE PSEUDO FUNCTION INLINE                */

      DECLARE BINLM CHARACTER INITIAL ('BAD ARGUMENT TO INLINE');
      DECLARE (FV, FL) FIXED;

      FV = FIXV(MPP1);
      FL = FIXL(MPP1);
      IF CNT(MP) < 4 THEN
         DO;
            IF TYPE(MPP1) = CONSTANT THEN
               DO CASE CNT(MP);

                  ;                              /* NO CASE 0 */

                  DO;
                     FIXL(MP) = FV;
                     INSTRUCT(FV) = INSTRUCT(FV) + 1; /* STATISTICS */
                  END;

                  DO;                            /* SAVE R1  */
                     TYPE(MP) = ACCUMULATOR;
                     REG(MP) = FIXV(MPP1);
                  END;

                  CALL EMITCODEBYTES(FIXL(MP), SHL(REG(MP), 4) +
                     FIXV(MPP1));
                                                 /* EMIT  OP R1 X  */
               END;
            ELSE
               CALL ERROR(BINLM,1);
         END;
      ELSE IF TYPE(MPP1) = CONSTANT THEN
         DO;
            IF CNT(MP) & 1 THEN
               CALL EMITCODEBYTES(INX(MP)+SHR(FIXV(MPP1), 8),
                  FIXV(MPP1));
                                       /* EMIT  B DDD  */
            ELSE
               INX(MP) = SHL(FIXV(MPP1), 4);      /* SAVE BASE REG  */
         END;
      ELSE IF TYPE(MPP1) = VARIABLE THEN
         DO;
            CNT(MP) = CNT(MP) + 1;
            IF CNT(MP) & 1 THEN
               DO;
                     IF SYTYPE(FL) = LABELTYPE THEN
                     DO;
                        IF SYBASE(FL)=0 THEN /* FIRST PAGE */
                           CALL EMITCODEBYTES(SHL(PBR,4) | SHR(SYDISP(FL),8),
                              SYDISP(FL));
                           ELSE CALL ERROR(
                    'CANNOT USE INLINE WITH LABEL OUTSIDE PAGE 0', 1);
                        END;
                     ELSE
                        CALL EMITCODEBYTES(SHL(SYBASE(FL),4) | SHR(SYDISP(FL),8)
                           , SYDISP(FL));
               END;
            ELSE
               CALL ERROR(BINLM, 1);
         END;
      ELSE
         CALL ERROR(BINLM, 1);

   END  EMIT_INLINE;




PROC_START:
   PROCEDURE;
      /*  GENERATES CODE FOR THE HEAD OF A PROCEDURE */

      DECLARE I FIXED;
      I = FIXL(MP);
      FIXL(MP) = PP;
      CALL BRANCH("F",0);    /*  BRANCH AROUND  */
      CALL EMITDATAWORD(0);  /*  PLACE TO STORE RETURN ADDRESS */
      PPSAVE(MP) = RTNADR;
      RTNADR = DP - 4;
      CALL FINDADDRESS(RTNADR);
      SYBASE(I) = SHR(PP,12);          /* ADDRESS OF THE PROCEDURE  */
      SYDISP(I) = PP & "FFF";
      CALL EMITRX(STORE, BRCHREG,0,ADREG,ADRDISP);
   END  PROC_START;



CHECK_STRING_OVERFLOW:
   PROCEDURE;
      DECLARE (I, BR_SAVE) FIXED;
      CALL EMITSS("D5", 3, SHL(DBR,12) | TSA, SHL(DBR,12) | LIMITWORD); /* CLC*/
      I = PP;
      CALL BRANCH (4, 0);
      CALL EMITDATAWORD(0);  BR_SAVE = DP - 4;
      CALL FINDADDRESS(BR_SAVE);
      CALL EMITRX(STORE, BRCHREG, 0, ADREG, ADRDISP);
      IF SYTYPE (STRING_RECOVER) = LABELTYPE THEN
         CALL CALLSUB(SYBASE(STRING_RECOVER),SYDISP(STRING_RECOVER), 0,
            STACKSIZE);
      ELSE
         CALL CALLSUB_FORWARD(SYBASE(STRING_RECOVER),
            SYDISP(STRING_RECOVER), 0, STACKSIZE);
      BASES(REG(STACKSIZE)) = AVAIL;
      CALL FINDADDRESS (BR_SAVE);
      CALL EMITRX(LOAD,BRCHREG,0,ADREG,ADRDISP);
      SYTCO(STRING_RECOVER) = SYTCO(STRING_RECOVER) + 1;
      CALL EMITRR ("1B", 0, 0);
      CALL FINDADDRESS (STRL);
      CALL EMITRX (STORE, 0, 0, ADREG, ADRDISP);
      CALL FIXBFW (I, PP);
   END CHECK_STRING_OVERFLOW;


FORCEACCUMULATOR:
   PROCEDURE (P);
      DECLARE P FIXED;
      /* FORCE THE OPERAND AT P INTO AN ACCUMULATOR */
      DECLARE SD FIXED, (R, SB, TP, SFP) BIT(8), T1 CHARACTER;
         DECLARE I BIT(16);
      COUNT#FORCE = COUNT#FORCE + 1;
      TP = TYPE(P);
      IF TP = CONDITION THEN CALL CONDTOREG (P, REG(P));
      ELSE IF TP = VARIABLE THEN
         DO;
            SB = SYBASE(FIXL(P));
            SD = SYDISP(FIXL(P));
                IF INX(P)=16 THEN
                   DO; INX(P)=0; SD=SD+PPSAVE(P); END;
                 /* PPSAVE HAS SOME GOODIES TO INCREMENT THE DISPLACEMENT
                    WHEN THE SUBSCRIPT IS A CONSTANT */
            SFP = SYTYPE(FIXL(P));
            IF SFP = LABELTYPE | SFP = CHAR_PROC_TYPE THEN
               DO;
                  CALL CALLSUB(SB,SD,3,P);
                  IF LENGTH(SYT(FIXL(P)+CNT(P)+1)) = 0 THEN
                     IF CONTROL(BYTE('N')) THEN
                        OUTPUT = '** WARNING--NOT ALL PARAMETERS SUPPLIED';
                  IF SFP = CHAR_PROC_TYPE THEN
                     TYPE(P) = DESCRIPT;
               END;
            ELSE IF SFP = FORWARDTYPE | SFP = FORWARDCALL THEN
               DO;
                  CALL CALLSUB_FORWARD(SB,SD,3,P);
                  SYTYPE(FIXL(P)) = FORWARDCALL;
               END;
            ELSE  IF SFP = SPECIAL THEN
               DO;
                  CALL EMITRX("90", 1, 3, DBR, IO_SAVE);
                  IF SD = 6 THEN
                     DO;  /*  INPUT */
                        CALL CHECK_STRING_OVERFLOW;
                        IF REG(P) = 0 THEN CALL EMITRR ("1B", 2, 2);
                        ELSE IF REG(P)^=2 THEN CALL EMITRR("18", 2, REG(P));
                        BASES(REG(P)) = AVAIL;
                        CALL FINDADDRESS (TSA);
                        CALL EMITRX("98", 0, 1, ADREG, ADRDISP);
                        /* THIS IS A POINTER TO THE FIRST FREE STRING AREA*/
           /* SECOND WORD IS THE CONST. 4 FOR READ CARD. (SEE INITIALIZE)*/
                        CALL EMITRR (BALR, BRCHREG, IOREG); /* MONITOR CALL*/
                        /* MOVE FREE STRING AREA POINTER */
                        CALL EMITRX (STORE, 1, 0, ADREG, ADRDISP);
                        CALL FINDADDRESS (STRL);/* LAST COMPUTED STRING */
                        CALL EMITRX (STORE, 0, 0, ADREG, ADRDISP);
                        REG(P) = 0;
                        TYPE(P) = DESCRIPT;
                     END;
                  ELSE IF SD = 8 THEN
                     CALL FILE_PSEUDO_ARRAY(P-2,P,0);
                  ELSE IF SD >= 11 & SD <= 18 THEN
                     DO;
                        /* TRACE, UNTRACE, EXIT, TIME, DATE, ETC.         */
                        R = SD=15;
                        IF SD > 15 THEN
                           DO;
                              IF REG(P) ^= 0 THEN
                                 CALL EMITRR ("18", 0, REG(P));
                              BASES(REG(P)) = AVAIL;
                              IF INX(P) ^= 2 THEN
                                 CALL EMITRR ("18", 2, INX(P));
                              BASES(INX(P)) = AVAIL;
                           END;
                        /* SET UP MONITOR REQUEST CODE */
                        CALL EMITRX(LA,1,0,0,SHL(SD-R,2)-32);
                        /* MONITOR CALL */
                        CALL EMITRR (BALR, BRCHREG, IOREG);
                        TYPE(P) = ACCUMULATOR;
                        IF R ^= 0 THEN
                           CALL EMITRR ("18", 0, R);
                        REG(P) = 0;
                     END;
                  ELSE CALL ERROR (' ILLEGAL USE OF ' || SYT(FIXL(P)));
                  CALL EMITRX ("98", 1, 3, DBR, IO_SAVE);
               END;
            ELSE
               DO;  /* FETCH THE VARIABLE (ALL ELSE HAS FAILED) */
                  I = SYBASE(FIXL(P));
                  IF SFP ^= BYTETYPE THEN
                     DO;
                        IF SFP = HALFWORD THEN TP="48";
                        ELSE TP=LOAD;
                        R = INX(P);
                        IF R^=0 THEN
                          DO;
                           IF I=0 THEN /* FOR COREWORD, WE SPLIT THE SUBSCRIPT
                                          BETWEEN BASE & INDEX REGISTER */
                              DO;
                                 I = R;
                                 IF SFP=FIXEDTYPE THEN
                                 SFP = HALFWORD; /* A TRICK TO GET
                                                    AR  INX(P),INX(P) */
                                 ELSE IF SFP=HALFWORD THEN SFP=BYTETYPE;
                              END;
                           IF SFP = HALFWORD THEN
                           CALL EMITRR("1E", R, R); /* ADD LOGICAL  AL R,R */
                           ELSE IF SFP^=BYTETYPE THEN
                           CALL EMITRX("89", R, 0, 0, 2);
                           /* SHIFT INDEX FOR WORD-TYPE ARRAY */
                          END;
                        ELSE R = FINDAC;
                     END;
                  ELSE
                     DO;
                        IF (BASES(1) & BASES(2) & BASES(3)) = ACCUMULATOR THEN
                           R=0; ELSE
                           DO;
                              R = FINDAC;
                              BASES(INX(P)) = AVAIL;
                           END;
                        CALL EMITRR("1F", R, R); /* CLEAR R */
                        TP = "43";
                        /* INSERT CHARACTER */
                     END;
                  CALL EMITRX(TP, R, INX(P), I, SD);
                        IF R=0 THEN /* TOO MANY ACCUMULATORS  BUT MAKE GOOD
                                       OBJECT CODE ANYHOW */
                     IF SFP=BYTETYPE THEN IF TARGET_REGISTER^=0 THEN
                           CALL EMITRR("18", INX(P), 0);
                  IF SFP = CHRTYPE THEN TYPE(P) = DESCRIPT;
                     ELSE TYPE(P) = ACCUMULATOR;
                  REG(P) = R;
               END;
         END;
            ELSE IF TP = CONSTANT THEN
               DO;
                  R = FINDAC;
                  /* FETCH A CONSTANT INTO AN ACCUMULATOR */
                  IF FIXV(P) = 0 THEN CALL EMITRR("1B", R, R);
                  ELSE IF FIXV(P) < "1000" & FIXV(P) >= 1 THEN
                     CALL EMITRX(LA, R, 0, 0, FIXV(P));
                     ELSE
                        CALL LOAD_CONSTANT(LOAD, R, FIXV(P));
                  TYPE(P) = ACCUMULATOR;
                  REG(P) = R;
               END;
            ELSE IF TP = CHRTYPE THEN
               DO;
                  R = FINDAC;
                  TYPE(P) = DESCRIPT;
                  REG(P) = R;
                  T1 = VAR(P);
                  SD = LENGTH(T1) - 1;
                  IF SD < 0 THEN
                     CALL EMITRR("1B",R,R); /* CLEAR  REG R, NULL STRING */
                  ELSE
                     IF SD = 0 THEN /* LENGTH=1 */
                         DO;
                            /* PLACE 1-BYTE CONSTANT STRINGS IN THE DATA AREA
                            & COMPUTE THE DESCRIPTOR, WHICH IS JUST THE ADDRESS,
                            AT EXECUTION TIME */
                            CALL FINDADDRESS(DP);
                            CALL EMITBYTE(BYTE(T1));
                            CALL EMITRX(LA, R, 0, ADREG, ADRDISP);
                         END;
                  ELSE
                     DO;
                        IF DSP> 3800 THEN /* WE ARE GETTING SHORT OF DESCRIPTR*/
                           DO; /* PLACE DESCRIPTOR IN DATA AREA */
                              CALL FINDADDRESS(DP);
                              CALL EMITRX(LA, R, 0, ADREG, ADRDISP);
                              DO I = 0 TO SD;
                                 CALL EMITBYTE(BYTE(T1, I));
                              END;
                              CALL EMITDATAWORD(SHL(SD,24));
                              CALL FINDADDRESS(DP-4);
                              /* LOGICAL OR IN THE LENGTH */
                              TP = "56";
                           END;
                        ELSE
                           DO;
                        CALL FINDADDRESS (-DSP);
                        /* MAKE UP A DESCRIPTOR */
                        CALL EMITDESC(SHL(SD,24)+CHP);
                        DO I = 0 TO SD;
                           CALL EMITCHAR(BYTE(T1, I));
                        END;
                              TP = LOAD;
                           END;
                           CALL EMITRX(TP, R, 0, ADREG, ADRDISP);
                     END;
               END;
            ELSE IF TP ^= ACCUMULATOR THEN IF TP ^= DESCRIPT THEN
               CALL ERROR ('FORCEACCUMULATOR FAILED ***', 1);
   END FORCEACCUMULATOR;

STUFF_PARAMETER:
   PROCEDURE;
      /* GENERATES CODE TO SEND AN ACTUAL PARAMETER TO A PROCEDURE */
                  /* NO SPECIAL PROVISION FOR INX(MP)=16   REQUIRED */
         DECLARE I BIT(16), J BIT(8);
      I = FIXL(MP) + CNT(MP);
      J = 0;
      IF TYPE(MPP1)=VARIABLE THEN
         IF INX(MPP1)=0 THEN
            IF SYTYPE(FIXL(MPP1))=SYTYPE(I) THEN J=1;
      IF LENGTH(SYT(I)) = 0 THEN
         DO;
          IF TYPE(MPP1)=CONSTANT & SYTYPE(I)=BYTETYPE THEN
            CALL EMITRX("92", 0, FIXV(MPP1), SYBASE(I), SYDISP(I)); /* MVI */
            ELSE IF J THEN
               DO; /* BOTH ARGUMENT & PARAMETER ARE SAME TYPE, SO EMIT MVC */
                  IF SYTYPE(I)=BYTETYPE THEN J=0; ELSE
                  IF SYTYPE(I)=HALFWORD THEN J=1; ELSE J = 3;
                  CALL EMITSS("D2", J, SHL(SYBASE(I), 12) | SYDISP(I),
                     SHL(SYBASE(FIXL(MPP1)), 12) | SYDISP(FIXL(MPP1)));
               END;
            ELSE
               DO;
                  CALL FORCEACCUMULATOR(MPP1);
                  IF SYTYPE(I)=BYTETYPE THEN
                    J="42"; /* STC */
                  ELSE IF SYTYPE(I)=HALFWORD THEN
                    J="40"; /* STH */
                  ELSE
                    J=STORE;/* ST  */
                  CALL EMITRX(J, REG(MPP1), 0, SYBASE(I), SYDISP(I));
                  BASES(REG(MPP1))=AVAIL;
               END;
         END;
      ELSE
         CALL ERROR('TOO MANY PARAMETERS', 1);
END STUFF_PARAMETER;

FORCEDESCRIPT:
   PROCEDURE (P);
      /* GET A DESCRIPTOR FOR THE OPERAND P */
      DECLARE P FIXED;
      CALL FORCEACCUMULATOR (P);
      IF TYPE(P) ^= DESCRIPT THEN
         DO;
            CALL EMITRX (STORE, REG(P), 0, DBR, STRN);
            /* STORE IN PARAMETER LOCATION FOR NUMBER-TO -DECIMAL-STRING */
            BASES(REG(P)) = AVAIL;
            CALL CALLSUB(0,NMBRNTRY,3,P);
            /* ASSUMES NUMBER-TO-STRING IS IN THE 1ST PAGE */
            TYPE(P) = DESCRIPT;
         END;
   END FORCEDESCRIPT;

GENSTORE:
   PROCEDURE (MP, SP);
      DECLARE (MP, SP, SD, FLSP) BIT(16), (SFP, SB) BIT(8);
       DECLARE TP BIT(8);
      FLSP = FIXL(SP);
      COUNT#STORE = COUNT#STORE + 1;
      IF TYPE(SP) = SPECIAL THEN RETURN;
      /* GENERATE TYPE CONVERSION (IF NECESSARY) & STORAGE CODE --
            ALSO HANDLES OUTPUT AND FILE ON LEFT OF REPLACE OPERATOR */
      SB = SYBASE(FIXL(MP));
      SD = SYDISP(FIXL(MP));
      SFP = SYTYPE(FIXL(MP));
      IF SFP = SPECIAL THEN
         DO;
            IF SD = 3 THEN      /*  FUNCTION BYTE ON THE LEFT */
               DO;
                  CALL FORCEACCUMULATOR(SP);
                  CALL EMITRX("42",REG(SP),INX(MP),REG(MP),0);
               END;
            ELSE IF SD = 7 THEN
               DO;      /* OUTPUT   */
                  IF PARSE_STACK(MP-1)=58 THEN
                     /* MULTIPLE ASSIGNMENT, SO SAVE REGISTERS */
                  CALL EMITRX("90",1,3,DBR,IO_SAVE);
                  TARGET_REGISTER = 0;
                  CALL FORCEDESCRIPT (SP);
                  TARGET_REGISTER = -1;
                  IF REG(SP) ^= 0 THEN CALL EMITRR ("18", 0, REG(SP));
                  IF REG(MP) = 0 THEN CALL EMITRR ("1B", 2, 2);
                  ELSE IF REG(MP) ^= 2 THEN CALL EMITRR ("18", 2, REG(MP));
                  BASES(REG(MP)) = AVAIL;
                  CALL EMITRX (LA, 1, 0, 0, 8);  /* 8 = PRINT CODE */
                  CALL EMITRR (BALR, BRCHREG, IOREG); /* MONITOR CALL */
                  IF PARSE_STACK(MP-1)=58 THEN
                  CALL EMITRX("98",1,3,DBR,IO_SAVE);
               END;
            ELSE IF SD = 8 THEN
               CALL FILE_PSEUDO_ARRAY(SP,MP,4);
            ELSE CALL ERROR ('ILLEGAL USE OF ' || SYT(FIXL(MP)));
         END;
      ELSE
         DO;
            /* CODE ECONOMISER FOR SIMPLE ASSIGNMENTS;
               IDENTIFIER=IDENTIFIER, AND IDENTIFIER(SUBSCRIPT)=IDENTIFIER.
               THE FORMER FOR ALL TYPES, THE LATTER FOR BYTE TYPE ONLY */
            I = INX(MP);
            IF I=16 THEN I,INX(MP)=0; ELSE PPSAVE(MP)=0;
            IF INX(SP)=16 THEN INX(SP)=0; ELSE PPSAVE(SP)=0;
            SD = SD + PPSAVE(MP); /* A CORRECTION DUE TO CONSTANT SUBSCRIPT */
            J = 0;
            IF TYPE(SP)=VARIABLE THEN IF INX(SP) =0 THEN
               IF SYTYPE(FLSP    )=SFP THEN
                 IF (SFP=BYTETYPE) | (SFP=HALFWORD & I=0) |
                    (SFP=FIXEDTYPE& I      =0) | (SFP=CHRTYPE & I=0) THEN
                       J = 1; /* SET ECONOMISER BIT */
            IF PARSE_STACK(MP-1)=58 /* LEFT PART -> WE HAVE MULTIPLE ASSIGNMENT
                                    */ THEN J=0; /* SO NO ECONOMISING */
               ELSE
                  IF TYPE(SP)=VARIABLE THEN IF SFP=BYTETYPE THEN
                     IF SYTYPE(FLSP)=SFP THEN IF INX(SP)^=0 THEN
                        DO;
                           /* NO NEED TO CLEAR REG(SP) FOR THE IC */
                           REG(SP)=INX(SP);
                           CALL EMITRX("43", REG(SP), REG(SP), SYBASE(FLSP),
                                 SYDISP(FLSP) + PPSAVE(SP));
                           TYPE(SP) = ACCUMULATOR;
                           J=0;
                        END;
            IF J THEN
               DO;
                  J = INX(MP);
                  IF SB>0 THEN /* EXCEPT FOR COREBYTE */
                  IF J^=0 THEN
                        /* ONLY FOR BYTE TYPE */
                       CALL EMITRR("1E", J, SB); /* CODE FOR SUBSCRIPT */
                    ELSE J=SB;
                  I = 3;
                  IF SFP=BYTETYPE THEN I=0; ELSE IF SFP=HALFWORD THEN I=1;
               CALL EMITSS("D2", I, SHL(J,12) | SD,
                    SHL(SYBASE(FLSP), 12) | SYDISP(FLSP));
                  REG(SP) = 0;
               END;
            ELSE
            IF SFP=BYTETYPE & TYPE(SP)=CONSTANT THEN
               DO;
            /* SUBSCRIPTED & SCALAR BYTETYPE VARIABLES ASSIGNED TO A CONSTANT */
                  IF INX(MP)^=0 THEN
                    DO;
                       IF SB>0 THEN /* EXCEPT FOR COREBYTE, COREWORD */
                       CALL EMITRR("1E", INX(MP), SB);
                       SB = INX(MP);
                    END;
                  CALL EMITRX("92", 0, FIXV(SP), SB, SD); /* MVI */
                  REG(SP) = 0; /* INITIALIZE FOR BASES(REG(SP))=AVAIL LATER */
               END;
            ELSE
             DO;
            CALL FORCEACCUMULATOR (SP);
            IF TYPE(SP) ^= SPECIAL THEN
               DO;
                  IF SFP=FIXEDTYPE & TYPE(SP)=ACCUMULATOR | SFP=CHRTYPE THEN
                     DO;
                        IF SFP = CHRTYPE THEN CALL FORCEDESCRIPT (SP);
                        /* SHIFT INDEX FOR WORD ARRAY */
                        IF INX(MP) ^=0 THEN
                        /* FOR COREWORD, SPLIT INDEX OVER BASE & INDEX FIELDS */
                        IF SB = 0 THEN
                           DO; SB = INX(MP); CALL EMITRR("1E", SB, SB); END ;
                        ELSE CALL EMITRX("89", INX(MP), 0, 0, 2);
                        TP = STORE;
                     END;
                  ELSE IF SFP = HALFWORD & TYPE(SP) = ACCUMULATOR THEN
                     DO;
                        IF SB = 0 THEN SB = INX(MP); ELSE
                        /* FOR COREHALFWORD, SPLIT INDEX OVER BASE & INDEX FIELD
                           */
                        IF INX(MP) ^= 0 THEN CALL EMITRR("1E", INX(MP),INX(MP));
                        TP = "40"; /* STH */
                     END;
                  ELSE IF SFP = BYTETYPE & TYPE(SP) = ACCUMULATOR THEN
                        TP = "42"; /* STC */
                  ELSE CALL ERROR('ASSIGNMENT NEEDS ILLEGAL TYPE CONVERSION');
                  CALL EMITRX(TP, REG(SP), INX(MP), SB, SD);
               END;
            END;
         END;
      BASES(INX(MP)) = AVAIL;
      BASES(REG(SP)) = AVAIL;
      CALL MOVESTACKS (SP, MP);
   END GENSTORE;

STRINGCOMPARE:
   PROCEDURE;
      /* GENERATES THE CODE TO COMPARE THE STRINGS AT SP & MP */
      DECLARE (I, J, K) FIXED;
      DECLARE TYPESAVE BIT(8), LENGTHCON BIT(16);
      TYPESAVE =  TYPE(SP);
      IF TYPESAVE=CHRTYPE THEN
         DO;
                LENGTHCON = LENGTH(VAR(SP)) - 1;
            IF LENGTHCON<0 THEN /* WE ARE LOOKING FOR A NULL STRING */
               DO;
                  CALL EMITRR("12", REG(MP), REG(MP)); /* LTR */
                  RETURN; /* NO NEED TO MAKE BASES(REG(SP)) AVAILABLE SINCE
                               NOT USED */
               END;
         END;
      CALL FORCEDESCRIPT (SP);  /* GET THE DESCRIPTOR FOR THE SECOND OPERAND */
      CALL EMITRR ("18", 0, REG(MP));  /* WE CAN USE 0 FOR SCRATCH */
      CALL EMITRR ("17", 0, REG(SP));     /* EXCL. | TO COMPARE  */
      CALL EMITRX ("8A", 0, 0, 0, 24);  /* CHECK HIGH ORDER 8 BITS FOR ZERO */
      IF REG(MPP1) = 6 | REG(MPP1) = 8 THEN
         DO;          /* IF WE ONLY NEED TO TEST EQUALITY, CODE IS SIMPLER  */
            K = PP;
            CALL BRANCH (6, 0);
         END;
      ELSE
         DO;
            J = PP;
            CALL BRANCH (8, 0);     /*  SKIP IF EQUAL LENGTH */
            CALL EMITRR ("15", REG(MP), REG(SP));     /* SET CONDITION CODE  */
            K = PP;  /* SAVE FOR FIXUP */
            CALL BRANCH ("F", 0);  /* BRANCH AROUND STRING COMPARE CODE  */
            CALL FIXBFW (J, PP);
         END;
      /* TEST FOR NULL STRINGS. IF ONE OPERAND IS NULL, CAN'T DO CLC */
      CALL EMITRR ("12", 0, REG(MP));       /* LTR  0,REG(MP) */
      J = PP; CALL BRANCH ("6", 0); /* BNE BRANCH AROUND NULL STRING CODE */
      M = PP; /* FOR A BRANCH IN CASE OF NULL STRINGS */
      CALL EMITRR ("15", REG(MP), REG(SP)); /* CLR SET CONDITION CODE */
      L = PP; CALL BRANCH("F", 0);          /* EXIT BRANCH */
      CALL FIXBFW (J, PP);
      IF TYPESAVE^=CHRTYPE THEN /* MORE CODE WHEN BOTH OPERANDS ARE VARIABLES */
         DO;
            CALL EMITRR ("12", 0, REG(SP));
            CALL BRANCH ("8", M); /* BZ: BRANCH TO THE NULL STRING CODE */
         END;
      /* NOW COMPARE THE STRINGS */
      IF TYPESAVE=CHRTYPE THEN
         CALL EMITSS("D5", LENGTHCON, SHL(REG(MP), 12), SHL(REG(SP), 12));
      ELSE
         DO; /* USE REG 12, THE BRANCH REGISTER, AS A TEMPORARY */
            CALL EMITRR("18", BRCHREG, REG(MP));
            CALL EMITRX("88", BRCHREG, 0, 0, 24);
      DP = (DP&1) + DP;       /* ALIGN ON A HALFWORD BOUNDARY */
         CALL FINDADDRESS(DP);
      INSTRUCT("D5") = INSTRUCT("D5") + 1;
      CALL EMITBYTE("D5");
      CALL EMITBYTE(0);
      CALL EMITBYTE(SHL(REG(MP), 4));
      CALL EMITBYTE(0);
      CALL EMITBYTE (SHL(REG(SP), 4));
      CALL EMITBYTE (0);
            CALL EMITRX("44", BRCHREG, 0, ADREG,ADRDISP);
         END;
      BASES(REG(SP)) = AVAIL;
      CALL FIXBFW(L , PP); /* NULL STRINGS RESUME HERE */
      CALL FIXBFW (K, PP);  /* BRING OTHER BRANCH IN HERE */
   END STRINGCOMPARE;

SHOULDCOMMUTE:
   PROCEDURE BIT(1);
      IF TYPE(MP)=ACCUMULATOR THEN RETURN FALSE;
      IF TYPE(MP)=VARIABLE THEN IF SYTYPE(FIXL(MP))=BYTETYPE THEN RETURN FALSE;
      IF TYPE(SP)=ACCUMULATOR THEN RETURN TRUE;
      IF TYPE(SP)=CONSTANT THEN RETURN TRUE;
      IF TYPE(SP)=VARIABLE THEN IF SYTYPE(FIXL(SP))=BYTETYPE THEN RETURN TRUE;
      RETURN FALSE;
   END;

ARITHEMIT:
   PROCEDURE (OP);
      /* EMIT AN INSTRUCTION FOR AN INFIX OPERATOR -- CONNECTS MP & SP */
      DECLARE (OP, T1, T2) BIT(8), TP FIXED, EXCHANGECC(15) BIT(8) INITIAL
      (0, 1, 4, 5, 2, 3, 6, 7, 8, 9, 12, 13, 10, 11, 14, 15);
      COUNT#ARITH = COUNT#ARITH + 1;
      TP = 0;  /* REMEMBER IF COMMUTED */
      IF COMMUTATIVE(OP) THEN
            IF SHOULDCOMMUTE THEN
               DO;
                  IF OP=CMPRR THEN
                    DO;
                       /* COMPARISON OPERATIONS ARE COMMUTATIVE.  HOWEVER
                          THE OPERATOR MAY HAVE TO BE CHANGED.
                          = AND ^= CODES REMAIN UNCHANGED.
                          WE CHANGE THE FOLLOWING RELATION OPERATORS:
                          > BECOMES <
                          < BECOMES >
                          >=BECOMES <=
                          <=BECOMES >=
                          ^>BECOMES >=
                          ^<BECOMES <=
                                                        */
                       /* REPLACE CONDITION MASK */
                       REG(MPP1) = EXCHANGECC(REG(MPP1));
                    END;
                  TP = MP; MP = SP; SP = TP;
               END;
      CALL FORCEACCUMULATOR (MP);  /* GET THE LEFT ONE INTO AN ACCUMULATOR */
      /* FIXL(SP) IS GARBAGE IF TYPE ^= VARIABLE, WE GET 0C5 IF WE TEST IT */
      T1 = "0";
      IF TYPE(SP) = VARIABLE THEN IF SYTYPE(FIXL(SP)) = FIXEDTYPE THEN T1 = "1";
                                  ELSE IF SYTYPE(FIXL(SP))=HALFWORD THEN
                                  IF OP>=CMPRR & OP<="1C" THEN T1=2;
      IF TYPE(MP) = DESCRIPT THEN
         DO;
            IF OP = CMPRR THEN CALL STRINGCOMPARE;
            ELSE CALL ERROR ('ARITHMETIC WITH A STRING DESCRIPTOR');
         END;
      ELSE IF T1>0 THEN
            DO; /* OPERATE DIRECTLY FROM STORAGE:    CH,AH,SH AND MH
                                         OPCODES   "49","4A","4B","4C"
                                         & ALL FULLWORD OPCODES               */
               T2=INX(SP);
               IF T2=16 THEN T2,INX(MP)=0; ELSE PPSAVE(SP)=0;
               IF T2^=0 THEN IF T1 THEN CALL EMITRX("89",T2,0,0,2); /*FULLWORD*/
                                   ELSE    CALL EMITRR("1A",T2,T2); /*HALFWORD*/
               /* OP + 64 GIVES THE FULLWORD OPERATION CODE */
               /* OP + 48 GIVES THE HALFWORD OPERATION CODE */
               IF T1=2 THEN
                  DO;
                     IF OP="1C" THEN REG(MP)=REG(MP)+1; /* FOR MH */
                     OP = OP - 16;  /* CH,AH,SH,MH */
                  END;
               CALL EMITRX(OP+64, REG(MP), T2, SYBASE(FIXL(SP)),
                  SYDISP(FIXL(SP))+PPSAVE(SP));
               BASES(T2) = AVAIL;
            END;
      ELSE IF TYPE(SP) = CONSTANT THEN
            DO;
               IF OP = CMPRR & SAVEADR ^= 0 THEN
                  DO; /* ERASE GENERATED CODE FOR LENGTH */
                     IF CONTROL(BYTE('E')) THEN
                        OUTPUT = 'WHOA: BACK UP';
                     IF FIXV(SP)=0 THEN
                        DO ; /* RESET PP */
                           PP = LENGTHPP2;
                           CALL EMITRR("12" , 0, REG(MP)); /* LTR */
                        END;
                     ELSE
                        DO;
                           PP = LENGTHPP; /* RESET PROGRAM POINTER */
                           T2 = SHR(SAVEADR, 16) & "F"; /* UNPACK INDEX */
                           IF T2 ^= 0 THEN
                              DO; /* SHIFT TO WORD INDEXING */
                                 CALL EMITRX("89", T2, 0, 0, 2);
                                 CALL EMITRR("1E", T2, SBR);
                                 SAVEADR = SAVEADR & "FFF";
                              END;
                           CALL EMITRX ("95", 0, FIXV(SP)-1, T2, SAVEADR);
                           BASES(REG(MP)) = AVAIL;
                           REG(MP) = EXCHANGECC(REG(MP));
                        END;
                  END;
               ELSE
                  DO;
             IF OP="1B" & FIXV(SP)=1 THEN
               CALL EMITRR ("06", REG(MP), 0);
            ELSE
                           CALL LOAD_CONSTANT(OP+64, REG(MP), FIXV(SP));
                        END;
             END;
      ELSE
            DO;
               CALL FORCEACCUMULATOR (SP);
               IF TYPE(SP) ^= ACCUMULATOR THEN
                  CALL ERROR ('ARITHMETIC BETWEEN STRING DESCRIPTORS', 1);
               CALL EMITRR (OP, REG(MP), REG(SP));
               BASES(REG(SP)) = AVAIL;
            END;
      IF TP ^= 0 THEN
         DO;  /* COMMUTED */
            SP = MP;  MP = TP;
            CALL MOVESTACKS (SP, MP);
         END;
         /* BY THE ALGORITHM, TYPE(MP) IS ALREADY ACCUMULATOR */
   END ARITHEMIT;

BOOLBRANCH:
   PROCEDURE (SP, MP);
      DECLARE (SP,MP) FIXED, T1 BIT(1);
      T1 = "0";
      IF TYPE(SP) = VARIABLE THEN IF SYTYPE(FIXL(SP)) = BYTETYPE THEN T1 = "1";
      /* GENERATE A CONDITIONAL BRANCH FOR A DO WHILE OR AN IF STATEMENT */
      IF STILLCOND ^= 0 THEN
         DO;
            BASES(REG(SP)) = AVAIL;
            PP = SHR(STILLCOND, 4);     /* RESET THE PROGRAM POINTER */
            IF CONTROL(BYTE('E')) THEN
                  OUTPUT = X70 || '               BACK UP CODE EMITTER';
            INSTRUCT(BC) = INSTRUCT(BC) - 1;  /* KEEP STATISTICS ACCURATE */
            INSTRUCT(LA) = INSTRUCT(LA) - 1;
            INSTRUCT(6) = INSTRUCT(6) - 1; /* BCTR */
            REG(SP) = STILLCOND & "F";
         END;
      ELSE IF T1 THEN
         DO;
            I = SYBASE(FIXL(SP)); J = SYDISP(FIXL(SP));
            IF INX(SP)=16 THEN /* THE SUBSCRIPT WAS A CONSTANT */
               DO; J = J + PPSAVE(SP); INX(SP)=0; END;
            IF INX(SP) ^= 0 THEN
               DO;
                  IF I>0 THEN /* EXCEPT FOR COREBYTE */
                     CALL EMITRR ("1E", INX(SP), I);
                  I = INX(SP);
                  BASES(INX(SP)) = AVAIL;
               END;
            CALL EMITRX ("91", 0, 1, I, J);
                  /*  TEST UNDER MASK  */
            REG(SP) = 8;
         END;
      ELSE IF TYPE(SP) = CONSTANT THEN
         DO;
            IF FIXV(SP) THEN
               DO;  FIXL(MP) = 0;  RETURN; END;
            ELSE REG(SP) = 15;
         END;
      ELSE IF TYPE(SP) ^= CONDITION THEN
         DO;
            CALL FORCEACCUMULATOR (SP);
            CALL EMITRX ("54", REG(SP), 0, DBR, TRUELOC);/* TEST LS BIT */
            BASES(REG(SP)) = AVAIL;
            REG(SP) = 8;
         END;
      FIXL(MP) = PP;  /* SAVE ADDRESS FOR FUTURE FIXUP */
      CALL BRANCH (REG(SP), 0);  /* REG(SP) HAS THE CC TO BE TESTED FOR */
   END BOOLBRANCH;


SET_LIMIT:
   PROCEDURE(MPP1);
      /*  SETS DO LOOP LIMIT FOR <ITERATION CONTROL>   */
      DECLARE MPP1 FIXED;
      IF TYPE(MPP1) = CONSTANT THEN
         CALL EMITCONSTANT(FIXV(MPP1));
      ELSE
         DO;
            CALL FORCEACCUMULATOR(MPP1);
            CALL EMITDATAWORD(0);
            CALL FINDADDRESS(DP-4);
            CALL EMITRX(STORE,REG(MPP1),0,ADREG,ADRDISP);
            BASES(REG(MPP1)) = AVAIL;
         END;
   END  SET_LIMIT;


DIVIDE_CODE:
   PROCEDURE(DIV); /* GENERATES CODE FOR DIVISION AND MOD */
      DECLARE DIV BIT(8);
      DECLARE (I,J,K) BIT(8);
      TARGET_REGISTER=0;
      IF(BASES(2)=AVAIL) & (BASES(3)=AVAIL) THEN TARGET_REGISTER=2;
      CALL FORCEACCUMULATOR(MP); /* FETCH DIVIDEND IF NOT ALREADY IN REGISTER */
      TARGET_REGISTER=-1;
      I=REG(MP);
      IF I THEN
        DO; /* WE HAVE AN ODD-NUMBERED REGISTER */
           CALL EMITRR("18",0,I);   /* LR  0,REG(MP)  */
           BASES(I)=AVAIL;
           REG(MP),
           I=0;
        END;
      J=0; K=I+1; /* K IS THE NEXT ODD-NUMBERED REGISTER */
      IF BASES(K)^=AVAIL THEN
        DO; /* NEXT ODD-NUMBERED REGISTER IS NOT AVAILABLE, SO SAVE ITS CONTEN*/
           J = FINDAC; /* FIND A SPARE ACCUMULATOR */
           CALL EMITRR("18",J,K);  /* LR  J,REG(MP)+1   SAVE REGISTER */
           /* BEWARE IF THE REGISTER WE ARE SHIFTING IS THE SECOND OPERAND,SP,
              OR ITS SUBSCRIPT */
           IF TYPE(SP)=VARIABLE THEN IF INX(SP)=K THEN INX(SP)=J;
           IF TYPE(SP)=ACCUMULATOR THEN IF REG(SP)=K THEN REG(SP)=J;
        END;
      CALL EMITRX("8E", I, 0, 0, 32); /* SRDA REG(MP),32(0,0) SMEAR THE SIGN */
      BASES(K)=ACCUMULATOR;
      CALL ARITHEMIT("1D"); /* DIVIDE */
      BASES(I), BASES(K)=AVAIL;
      IF J>0 THEN
        DO; /* ORIGINAL ODD REGISTER WAS NOT AVAILABLE */
           IF DIV THEN CALL EMITRR("18", I, K); /* GET RESULT IN EVEN REGISTER*/
           IF REG(SP)^=J THEN
              DO; /* RESTORE THE SECOND REG, EXCEPT IF IT WAS OPERAND SP */
                 CALL EMITRR("18", K, J);
                 BASES(J)=AVAIL;
                 BASES(K)=ACCUMULATOR;
              END;
        END;
       ELSE /* ORIGINAL ODD REGISTER WAS AVAILABLE */
         IF DIV THEN I=K; /* RESULT IN ODD REGISTER FOR DIVISION */
      IF  I=0 THEN
        DO;   /* GET RESULT IN REGISTERS 1,2,OR 3 */
             I=FINDAC;
             CALL EMITRR("18",I,0);
        END;
       ELSE  BASES(I)=ACCUMULATOR; /* RESERVE REGISTER CONTAINING RESULT */
      REG(MP)=I; /* WHERE TO FIND RESULT */

   END  DIVIDE_CODE;


SHIFT_CODE:
   PROCEDURE (OP);
      /*  GENERATES CODE FOR THE BUILT IN FUNCTIONS  SHL  AND  SHR  */
      DECLARE OP BIT (8);
      IF CNT(MP) ^= 2 THEN
         CALL ERROR('SHIFT REQUIRES TWO ARGUMENTS',0);
      ELSE IF TYPE(MPP1) = CONSTANT THEN
         DO;
            IF OP = "89" & FIXV(MPP1) = 1 THEN
               CALL EMITRR ("1A", REG(MP), REG(MP));
            ELSE CALL EMITRX (OP, REG(MP), 0, 0, FIXV(MPP1));
         END;
      ELSE
         DO;
            CALL FORCEACCUMULATOR(MPP1);
            CALL EMITRX(OP, REG(MP), 0, REG(MPP1), 0);
            BASES(REG(MPP1)) = AVAIL;
         END;
      TYPE(MP) = ACCUMULATOR;
   END  SHIFT_CODE;



  /*                    BUILT-IN FUNCTIONS                              */


REGISTER_SETUP_CODE:
   PROCEDURE;
      CALL EMITRR("18",PBR,2);  /* SET BASE */
      CALL EMITRR("18",DBR,3);
      CALL EMITRX(STORE,BRCHREG,0,DBR,RTNADR);
      CALL EMITCONSTANT (256);
      CALL EMITRX ("5B", 1, 0, ADREG, ADRDISP);
      LIMITWORD = DP;
      CALL EMITRX (STORE, 1, 0, DBR, DP);
      CALL ENTER ('FREELIMIT', FIXEDTYPE, DP, 0);
      CALL EMITDATAWORD (0);
      CALL EMITRX(STORE, 0, 0, DBR, DP);
      CALL ENTER('PARMSTRING', CHRTYPE, DP, 0);
      CALL EMITDATAWORD(0);
      BASEDATA = DP;
      DP = DP+16;
      CALL EMITRX ("98", 4, DBR-1, DBR, DP);  /* LOAD MULTIPLE  */
      DO I = 4 TO DBR-1;
         CALL EMITRR("1A",I,DBR);
      END;
      DP = DP + SHL(DBR-4, 2);
   END REGISTER_SETUP_CODE;

RELOCATE_DESCRIPTORS_CODE:
   PROCEDURE;
      /* EMIT CODE TO RELOCATE DESCRIPTORS TO ABSOLUTE ADDRESSES */

      CALL EMITRX(LOAD,0,0,DBR,BASEDATA+8);
      CALL EMITRR("1A",0,DBR);
      CALL EMITRX(STORE,0,0,DBR,TSA);
      CALL EMITRX (STORE, 0, 0, DBR, DP);
      CALL ENTER ('FREEBASE', FIXEDTYPE, DP, 0);
      CALL EMITDATAWORD (0);
      CALL EMITRX("91",0,1,DBR,BASEDATA+12);
      K = PP;
      CALL BRANCH (1, 0);
      CALL EMITRX("96",0,1,DBR,BASEDATA+12);
      CALL EMITRX(LOAD,1,0,DBR,BASEDATA);
      CALL EMITRX (LA,SBR,1,DBR,0);
      CALL EMITRX(LOAD,2,0,DBR,BASEDATA+4);
      CALL EMITRR ("1A",2,DBR);
      J = PP;                             /* SAVE DESTINATION FOR LOOP */
      CALL EMITRX (LOAD,3,1,DBR,0);
      CALL EMITRR ("12",3,3);
      CALL BRANCH (8,PP+10);              /* ESCAPE */
      CALL EMITRR ("1A",3,2);
      CALL EMITRX (STORE,3,1,DBR,0);
      CALL EMITRX (LA,1,0,1,4);
      CALL EMITRX(CMPR,1,0,DBR,BASEDATA+4);
      CALL BRANCH (4,J);                  /* LOOP */
      CALL FIXBFW (K,PP);
      CALL BRANCH (15,0);      /*  JUMP TO FIRST COMPILED CODE */
   END RELOCATE_DESCRIPTORS_CODE;

CATENATE_CODE:
   PROCEDURE;
      /* BUILD A CATENATE SUBROUTINE  */

      CATENTRY = PP;
      CALL CHECK_STRING_OVERFLOW;
      CALL EMITRX (LOAD,1,0,A1,A2);  /*  LOAD FIRST DESCRIPTOR */
      CALL EMITRR ("18", 3, 1);  /* COPY INTO REG(3)  */
      CALL EMITRX ("5E", 3, 0, B1, B2);  /* COMBINE DESCRIPTORS  */
      CALL EMITRR ("12", 1, 1);  /* TEST FOR NULL FIRST OPERAND  */
      CALL EMITRR (BCR, 8, BRCHREG);  /* RETURN WITH RESULT IN REG(3)  */
      CALL EMITRR (CMPRR, 3, 1);  /* IS SECOND OPERAND NULL?  */
      CALL EMITRR (BCR, 8, BRCHREG);  /* RETURN WITH RESULT IN REG(3)  */
      CALL FINDADDRESS (MASKF000);
      CALL EMITRX ("54", 3, 0, ADREG, ADRDISP);  /* MASK OUT ADDRESS  */
      CALL EMITRX ("5E", 3, 0, DBR, CATCONST);  /* CORRECT LENGTH OF RESULT  */
      CALL FINDADDRESS (MOVER);  /* FIND MOVE INSTRUCTION */
      T1 = ADREG;  T2 = ADRDISP;
      CALL EMITRR ("18", 0, 3);  /* SAVE LENGTH IN REG(0)  */
      CALL FINDADDRESS (TSA);  /* FIND CURRENT TOP OF STR AREA  */
      CALL EMITRX (LOAD,2,0,ADREG,ADRDISP);
      CALL FINDADDRESS (STRL);  /* LAST STRING MADE IN STRING AREA */
      CALL EMITRX (CMPR, 1, 0, ADREG, ADRDISP); /* SKIP MOVE IF AT TOP */
      J = PP;
      CALL BRANCH (6, 0);       /* FAKE MOVE */
      CALL EMITRX (LA, 1, 0, 1, 0);
      CALL EMITRR ("16", 0, 1);
      K = PP;
      CALL BRANCH ("F", 0);
      CALL FIXBFW (J, PP);
      CALL EMITRR ("16",0,2);  /* OR IN CORRECT ADDRESS */
      CALL EMITRX ("43",3,0,A1,A2);  /* INSERT LENGTH FIELD */
      CALL EMITRX ("44",3,0,T1,T2);   /* EXECUTE THE MOVE */
      CALL EMITRX ("41",2,3,2,1);  /* UPDATE TSA */
      CALL FIXBFW (K, PP);
      CALL EMITRX (LOAD,1,0,B1,B2);  /* LOAD SECOND DESCRIPTOR */
      CALL EMITRX ("43", 3,0,B1,B2);  /* INSERT LENGTH FIELD  */
      CALL EMITRX ("44",3,0,T1,T2);  /* EXECUTE THE MOVE */
      CALL EMITRX ("41",2,3,2,1);   /*  UPDATE TSA  */
      CALL EMITRX (STORE, 0, 0, ADREG, ADRDISP);  /* STORE INTO STRL */
      CALL FINDADDRESS (TSA);
      CALL EMITRX (STORE,2,0,ADREG,ADRDISP);   /* SAVE TOP OF STR. A.  */
      CALL EMITRR ("18", 3, 0);  /* RESULT TO REG(3)  */
      CALL EMITRR (BCR, 15, BRCHREG);  /* RETURN  */
   END CATENATE_CODE;

CATNUMBER_CODE:
   PROCEDURE;
      /* CATENATES A STRING AS THE FIRST OPERAND WITH A NUMBER AS THE SECOND.
         THE NUMBER IS FIRST CONVERTED TO STRING, AND PLACED ABOVE THE TOP OF
         FREE STRING AREA.
         CATENATE IS THEN FOOLED INTO PLACING THE SECOND OPERAND AGAINST THE
         FIRST, WITHOUT HAVING TO MOVE THE FIRST OPERAND,
         ASSUMING THAT THE FIRST WAS ALREADY AT THE TOP OF STRING AREA BEFORE
         THIS SUBROUTINE WAS CALLED.  ROUTINE AVOIDS CHEWING UP THE FREE STRING
         AREA & CUTS DOWN ON MOVES.
         THIS SUBROUTINE CALLS CONVERT_CODE & THEN CATENATE. */
      CATNUMNTRY = PP;
      CALL EMITDATAWORD(0);   /* A TEMPORARY */
      I = DP - 4; /* SAVE DP */
      CALL FINDADDRESS(I);
      CALL EMITRX(STORE,BRCHREG,0,ADREG,ADRDISP); /* SAVE THE RETURN BRANCH */
      CALL FINDADDRESS(STRL);
      CALL EMITRX(LOAD, 0, 0, ADREG, ADRDISP);
      CALL FINDADDRESS(DP);   /* THE ADDRESS OF A 2-WORD SAVE AREA */
      DP = DP + 4;            /* FOR THE 2ND WORD */
      CALL EMITRX(LOAD,1,0,DBR,TSA);
      CALL EMITRX("90",0,1,ADREG,ADRDISP); /* SAVE STRL & TSA */
                                           /* STM  0,1,ADREG,ADRDISP */
      /* GET TRUE LENGTH OF FIRST STRING */
      CALL EMITRR("1B", 3,3);
      CALL EMITRX("43",3,0,A1,A2); /* LENGTH OF FIRST OPERAND */
      CALL EMITRX(LA,0,1,3,1);     /* TRUE LENGTH + A(TSA) */
      CALL EMITRX(STORE,0,0,DBR,TSA); /* UPDATE TSA */
      /* MAKE ROOM FOR FIRST OPERAND */
      CALL BRLINK_BD(0, NMBRNTRY); /* CONVERT TO STRING */
      CALL FINDADDRESS(I);         /* GET THE RETURN ADDRESS */
      CALL EMITRX(LOAD, BRCHREG, 0, ADREG, ADRDISP);
      CALL EMITRX(LOAD,1,0,A1,A2); /* LOAD FIRST DESCRIPTOR */
      CALL EMITRR("12", 1, 1); /* TEST FOR NULL FIRST OPERAND */
      CALL EMITRR( BCR, 8, BRCHREG); /* RETURN WITH RESULT IN REG(3) */
                                     /* BOTH STRL & TSA ARE PROPERLY ADJUSTED */
      CALL FINDADDRESS(I+4);
      CALL EMITRX("98",0,1,ADREG,ADRDISP); /* RESTORE OLD STRL & TSA */
      CALL FINDADDRESS(STRL);
      /* SET UP SECOND OPERAND FOR CATENATE */
      /* THE DESCRIPTOR FOR THE NUMBER */
      CALL EMITSS("D2", 3, SHL(B1, 12)+B2, SHL(ADREG,12)+ADRDISP);
      CALL EMITRX(STORE,0,0,ADREG,ADRDISP);/* STORES ORIGINAL STRL */
      /* RESTORE ORIGINAL TSA */
      CALL EMITRX(STORE,1,0,DBR,TSA);
      /* FALL THRU TO CATENATE CODE.  THEN RETURN VIA BRCHREG TO CALLER */
   END CATNUMBER_CODE;

CONVERT_CODE:
   PROCEDURE;
      /*  THE NUMBER-TO-STRING CONVERSION SUBROUTINE */

      NMBRNTRY = PP;
      CALL CHECK_STRING_OVERFLOW;         /* CALL COMPACTIFY */
      CALL EMITRX (LOAD,0,0,DBR,STRN);  /* LOAD THE NUMBER INTO REGISTER 0 */
      CALL FINDADDRESS (DP);
      CALL EMITDATAWORD("40202020");
      CALL EMITDATAWORD("20202020");
      CALL EMITDATAWORD("20202120");
      CALL EMITRX ("41",1,0,ADREG,ADRDISP); /*ADDRESS OF PATTERN */
      CALL EMITRX (LOAD,3,0,DBR,TSA); /* ADDRESS OF THE STRING */
      /* MOVE THE TEMPLATE */
      CALL EMITSS("D2", 11, "3000", "1000");  /* MVC 0(12,3),0(1)  */
      CALL EMITRR ("18", 2, 3);                  /* LR   2,3     */
      CALL EMITCONSTANT ("FFFFF8");
      CALL EMITRX ("54", 2, 0, ADREG, ADRDISP);    /* N   2,=X"FFFFFC" *     */
      CALL EMITRX ("4E", 0, 2, 0, 24);           /* CVD 0,24(2,0)
                      OFFSET 24 TO USE FREE STRING AREA AS WORK AREA */
      CALL EMITRX (LA,  1,0,3,12);
      CALL EMITRX (STORE,1,0,DBR,TSA);/*UPDATE THE STRING POINTER */
      CALL EMITRR ("06", 1, 0); /* GET READY TO POINT AT SIGNIFICANT DIGIT */
      CALL EMITSS ("DF", 11, "3000", "201A"); /* EDMK  0(12,3),26(2)  */
      CALL BRANCH(10, PP+10);         /* BRANCH OVER THE NEXT 2 INSTRUCTIONS */
      CALL EMITRR ("06",1,0);           /* MAKE ROOM FOR SIGN */
      CALL EMITRX ("92",0,BYTE('-'),1,0);/* MVI  0(1),C'-'    */
     /* THE BRANCH COMES IN HERE */
      CALL EMITRX (LOAD,3,0,DBR,TSA);     /* MAKE UP RESULT DESCRIPTOR */
      CALL EMITRR ("1B",3,1);
      CALL EMITRR ("06",3,0);
      CALL EMITRX ("89",3,0,0,24);        /* SHIFT LENGTH FIELD LEFT */
      CALL EMITRR ("1A",3,1);             /* ADD IN ADDRESS */
      CALL FINDADDRESS (STRL);            /* UPDATE POINTER TO NEWEST STRING */
      CALL EMITRX (STORE, 3, 0, ADREG, ADRDISP);
      CALL EMITRR (BCR,15,BRCHREG);       /* RETURN */
   END CONVERT_CODE;


  /*                       TIME AND DATE                                 */


PRINT_TIME:
   PROCEDURE (MESSAGE, T);
      DECLARE MESSAGE CHARACTER, T FIXED;
      MESSAGE = MESSAGE || T/360000 || ':' || T MOD 360000 / 6000 || ':'
         || T MOD 6000 / 100 || '.';
      T = T MOD 100;  /* DECIMAL FRACTION  */
      IF T < 10 THEN MESSAGE = MESSAGE || '0';
      OUTPUT = MESSAGE || T || '.';
   END PRINT_TIME;

PRINT_DATE_AND_TIME:
   PROCEDURE (MESSAGE, D, T);
      DECLARE MESSAGE CHARACTER, (D, T) FIXED, (YEAR, DAY, M) BIT(16);
     DECLARE MONTH CHARACTER INITIAL
          ('JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC ');
   DECLARE
      DAYS(12) BIT(16) INITIAL (0, 31, 60, 91, 121, 152, 182, 213, 244, 274,
         305, 335, 366);
      YEAR = D/1000 + 1900;
      DAY = D MOD 1000;
      IF (YEAR & "3") ^= 0 THEN IF DAY > 59 THEN DAY = DAY + 1; /* ^ LEAP YEAR*/
      M = 1;
      DO WHILE DAY > DAYS(M);  M = M + 1;  END;
     D = SHL(M-1, 2);
      CALL PRINT_TIME(MESSAGE || SUBSTR(MONTH, D, 4) || DAY-DAYS(M-1) || X1
         || YEAR || '.  CLOCK TIME = ', T);
   END PRINT_DATE_AND_TIME;

  /*                       INITIALIZATION                                     */



INITIALIZATION:
   PROCEDURE;
      EJECT_PAGE;
   CALL PRINT_DATE_AND_TIME(
   'X P L  -- ROYAL MELBOURNE INST. OF TECHNOLOGY -- OPTIMIZING VERSION 4 OF ',
   DATE_OF_GENERATION, TIME_OF_GENERATION);
      DOUBLE_SPACE;
      CALL PRINT_DATE_AND_TIME ('TODAY IS ', DATE, TIME);
      DOUBLE_SPACE;
      DO I = 1 TO NT;
         S = V(I);
         IF S = '<NUMBER>' THEN NUMBER = I;  ELSE
         IF S = '<IDENTIFIER>' THEN IDENT = I;  ELSE
         IF S = '<STRING>' THEN STRING = I;  ELSE
         IF S = '/' THEN DIVIDE = I;  ELSE
         IF S = '_|_' THEN EOFILE = I;  ELSE
         IF S = 'DECLARE' THEN STOPIT(I) = TRUE;  ELSE
         IF S = 'PROCEDURE' THEN STOPIT(I) = TRUE;  ELSE
         IF S = 'END' THEN STOPIT(I) = TRUE;  ELSE
         IF S = 'DO' THEN STOPIT(I) = TRUE;  ELSE
         IF S = ';' THEN STOPIT(I) = TRUE;  ELSE
         IF S = VBAR THEN ORSYMBOL = I; ELSE
         IF S = '||' THEN CONCATENATE = I; ELSE
         ;
      END;
      RESERVED_LIMIT = LENGTH(V(NT - (IDENT=NT)));
      V(EOFILE) = 'EOF';
      STOPIT(EOFILE) = TRUE;
      CHARTYPE(BYTE(' ')) = 0;
      CHARTYPE(BYTE('''')) = 2;
      CHARTYPE(BYTE('"')) = 3;
      /* MAKE THE LENGTH OF X70 70 BLANKS */
      CALL INLINE("92", 0, "45", X70);  /* MVI  X70,70. */
      DO I = 0 TO LENGTH(ALPHABET) - 1;
         J = BYTE(ALPHABET, I);
         TX(J) = I;
         NOT_LETTER_OR_DIGIT(J) = FALSE;
         CHARTYPE(J) = 4;
      END;
      DO I = 0 TO 9;
         J = BYTE(HEXCODES, I);
         NOT_LETTER_OR_DIGIT(J) = FALSE;
         CHARTYPE(J) = 5;
      END;
      DO I = V_INDEX(0) TO V_INDEX(1) - 1;
         J = BYTE(V(I));
         TX(J) = I;
         CHARTYPE(J) = 7;
      END;
      CHARTYPE(BYTE('_')) = 1; /* THE UNDERSCORE MAY NOT START AN IDENTIFIER */
      CHARTYPE(BYTE('|')) = 8;
      CHARTYPE(BYTE('/')) = 6;
      COMMUTATIVE(CMPRR),
      COMMUTATIVE("14") = TRUE;
      COMMUTATIVE("16") = TRUE;
      COMMUTATIVE("1A") = TRUE;
      RETURNED_TYPE = FIXEDTYPE;          /* DEFAULT RETURN TYPE */

      LASTBASE = DBR;  BASES(LASTBASE) = 0;
      /*              INITIALIZE SYMBOL TABLE VARIABLES */
      PP = 60;   /*  OFFSET  CODE  FOR  CONTROL  RECORD (SEE LOADER) */
      DP = 0;    /*  DATA ORIGIN  */
      DSP = 4;
      CHP = 1;
      PPLIM, DPLIM, CHPLIM = DISKBYTES;
         /* UPPER BOUND FOR EMITTER ARRAYS */
      PPORG, DPORG, CHPORG,
         /* LOWER BOUND FOR EMITTER ARRAYS */
      CURCBLK, CURDBLK, CURSBLK,
         /* CURRENT BLOCK OCCUPYING EMITTER ARRAYS */
      SHORTCFIX, SHORTDFIX, LONGCFIX, LONGDFIX,
         /* STATISTICAL COUNTERS FOR FIXUPS */
      FCP = 0;  /* POINTER INTO FIXUP ARRAY */
      NDECSY ,PROCMARK = 1;   PARCT = 0;
      /* INTEGERS FOR BRANCH ADDRESSING */
      DO I = 0 TO PROGRAMSIZE;  CALL EMITDATAWORD(SHL(I,12)); END;

      /*  WARNING, THE FOLLOWING SECTION OF INITIALIZE DEPENDS ON
          THE INITIALIZATION OF THE BUILTIN FUNCTION AND PSEUDO
          VARIABLE NAMES AND ATTRIBUTES IN THE SYMBOL TABLE ARRAYS.
      */

      IO_SAVE = DP; DP = DP + 16; /* REGSAVE FOR I/O & MONITOR_LINK */
      MASKF000 = DP;  CALL EMITDATAWORD("FF000000");

      /*  SET UP THE MOVE TEMPLATE IN DATA AREA */

      MOVER = DP;
      CALL EMITDATAWORD("D2002000");    /* MVC */
      CALL EMI