/*
                              P D P - 1 0   X P L
                              V E R S I O N   1
      A COMPILER-COMPILER FOR PROGRAMMING LANGUAGE 1.
                                               RICHARD L. BISBEY II
                                               JULY 1971

VERSION 4.0        NOVEMBER 1975.

      VERION 4 OF THE COMPILER PROCESSES THE ENTIRE XPL GRAMMAR.

VERSION 3.0        NOVEMBER, 1975.

      VERSION 3.0 CONTAINS THE FOLLOWING DIFFERENCES FROM VERSION 2.0:
      RELOCATABLE BINARY CODE OUTPUT,
      CALL INLINE FACILITY IMPLEMENTED,
      UUOS USED TO CALL THE RUN-TIME ROUTINES,
      SOME SWITCHES CAN BE SPECIFIED FROM THE TERMINAL,
      "COMPACTIFY" IS COMPILED FROM A SOURCE LIBRARY,
      REDUNDANT SAVES OF PROCEDURE RESULTS IN OTHER REGISTERS IS
         AVOIDED IN MOST INSTANCES.

      VERSION 2.0
      HASH-CODED SYMBOL TABLE,
      LEFT-TO-RIGHT GENERATION OF STRINGS FROM NUMBERS,
      SPECIAL CASE CHECKS IN STRING CATENATION ROUTINE,
      FASTER, MORE EFFICIENT PROCEDURE CALLS,
      GENERAL INPUT/OUTPUT, FILE, FILENAME PROCEDURES,
      BETTER LISTING, SYMBOL DUMP FORMAT, ETC.

             R. W. HAY,
             COMPUTER GROUP,
             DEPT. OF ELECTRICAL ENG.,
             UNIVERSITY OF TORONTO,
             TORONTO, ONTARIO, CANADA.


      THE MAIN STRUCTURE OF THE PROGRAM IS AS FOLLOWS:
            CONTENTS.
            RECOGNITION TABLES FOR THE SYNTAX ANALYZER.
            DECLARATION OF SCANNER/COMPILER VARIABLES.
            STORAGE COMPACTIFICATION PROCEDURE.
            SCANNER PROCEDURES.
            PARSER PROCEDURES.
            CODE/DATA EMITTER PROCEDURES.
            SYMBOL TABLE PROCEDURES.
            CODE GENERATION PROCEDURES.
            INITIALIZATION PROCEDURE.
            ANALYSIS ALGORITHM.
            PRODUCTION RULES.
   */

   DECLARE VERSION LITERALLY '''4.0''';

         /*   THESE ARE LALR PARSING TABLES   */
 
         DECLARE MAXR# LITERALLY '99'; /* MAX READ # */
 
         DECLARE MAXL# LITERALLY '125'; /* MAX LOOK # */
 
         DECLARE MAXP# LITERALLY '125'; /* MAX PUSH # */
 
         DECLARE MAXS# LITERALLY '234'; /* MAX STATE # */
 
         DECLARE START_STATE LITERALLY '1';
 
         DECLARE TERMINAL# LITERALLY '42'; /* # OF TERMINALS */
 
         DECLARE VOCAB# LITERALLY '91';
 
         DECLARE VOCAB(VOCAB#) CHARACTER INITIAL ('','<','(','+','^','&','*',')'
         ,';','\','-','/',',','>',':','=','^^','BY','DO','GO','IF','TO','BIT'
         ,'END','EOF','MOD','CALL','CASE','ELSE','GOTO','THEN','FIXED','LABEL'
         ,'WHILE','RETURN','DECLARE','INITIAL','<NUMBER>','<STRING>','CHARACTER'
         ,'LITERALLY','PROCEDURE','<IDENTIFIER>','<TERM>','<TYPE>','<GO TO>'
         ,'<GROUP>','<ENDING>','<PRIMARY>','<PROGRAM>','<REPLACE>','<BIT HEAD>'
         ,'<CONSTANT>','<RELATION>','<VARIABLE>','<IF CLAUSE>','<LEFT PART>'
         ,'<STATEMENT>','<TRUE PART>','<ASSIGNMENT>','<BOUND HEAD>'
         ,'<EXPRESSION>','<GROUP HEAD>','<IF STATEMENT>','<INITIAL HEAD>'
         ,'<INITIAL LIST>','<WHILE CLAUSE>','<CASE SELECTOR>','<CALL STATEMENT>'
         ,'<LOGICAL FACTOR>','<PARAMETER HEAD>','<PARAMETER LIST>'
         ,'<PROCEDURE HEAD>','<PROCEDURE NAME>','<STATEMENT LIST>'
         ,'<SUBSCRIPT HEAD>','<BASIC STATEMENT>','<GO TO STATEMENT>'
         ,'<IDENTIFIER LIST>','<LOGICAL PRIMARY>','<STEP DEFINITION>'
         ,'<LABEL DEFINITION>','<RETURN STATEMENT>','<TYPE DECLARATION>'
         ,'<ITERATION CONTROL>','<LOGICAL SECONDARY>','<STRING EXPRESSION>'
         ,'<DECLARATION ELEMENT>','<PROCEDURE DEFINITION>'
         ,'<ARITHMETIC EXPRESSION>','<DECLARATION STATEMENT>'
         ,'<IDENTIFIER SPECIFICATION>');
 
         DECLARE P# LITERALLY '109'; /* # OF PRODUCTIONS */
 
         DECLARE STATE_NAME(MAXR#) BIT(8) INITIAL (0,0,1,2,3,3,4,5,6,7,9,9,10,10
         ,11,12,13,16,17,18,19,20,21,22,23,25,26,27,33,34,35,36,37,37,40,42,42
         ,42,42,42,43,43,43,43,43,44,44,45,46,50,50,51,52,53,54,54,55,56,58,59
         ,60,61,61,61,61,61,61,61,61,61,61,62,64,66,67,68,69,69,70,71,72,73,74
         ,74,75,76,77,78,80,81,81,82,83,86,86,88,89,89,90,91);
 
         DECLARE RSIZE LITERALLY '337'; /*  READ STATES INFO  */
 
         DECLARE LSIZE LITERALLY '69'; /* LOOK AHEAD STATES INFO */
 
         DECLARE ASIZE LITERALLY '105'; /* APPLY PRODUCTION STATES INFO */
 
         DECLARE READ1(RSIZE) BIT(8) INITIAL (0,8,18,19,20,26,29,34,35,42,15,2,3
         ,9,10,37,38,42,2,37,38,42,2,37,38,42,2,3,9,10,37,38,42,2,3,9,10,37,38
         ,42,2,37,38,42,22,31,32,39,2,3,10,37,38,42,1,13,15,2,37,38,42,2,37,38
         ,42,2,37,38,42,2,42,15,2,3,10,37,38,42,2,3,9,10,37,38,42,8,27,33,42,21
         ,2,3,9,10,37,38,42,2,3,9,10,37,38,42,2,42,2,37,38,42,42,2,3,9,10,37,38
         ,42,2,3,9,10,37,38,42,2,3,9,10,37,38,42,2,42,2,7,7,38,2,14,2,40,7,12,7
         ,12,6,11,25,6,11,25,6,11,25,6,11,25,6,11,25,8,8,42,8,2,3,9,10,37,38,42
         ,2,3,9,10,37,38,42,37,7,12,2,3,10,37,38,42,12,15,15,8,18,19,20,26,29,34
         ,35,42,42,8,18,19,20,26,29,34,35,42,8,37,4,30,4,4,7,12,4,4,4,7,4,4,21,4
         ,17,4,8,18,19,20,23,26,29,34,35,42,37,38,8,8,8,5,5,42,8,22,31,32,39,8
         ,18,19,20,26,29,34,35,42,2,8,22,31,32,39,8,18,19,20,24,26,29,34,35,42,8
         ,18,19,20,23,26,29,34,35,42,2,3,9,10,37,38,42,28,8,42,8,8,18,19,20,26
         ,29,34,35,41,42,8,18,19,20,23,26,29,34,35,41,42,8,36,1,9,13,15,16,16,8
         ,3,10,3,10,8,12,2,22,31,32,39);
 
         DECLARE LOOK1(LSIZE) BIT(8) INITIAL (0,15,0,15,0,42,0,8,0,2,14,0,2,0,40
         ,0,6,11,25,0,6,11,25,0,6,11,25,0,6,11,25,0,6,11,25,0,4,0,4,0,4,0,4,0,8
         ,0,4,0,5,0,5,0,28,0,36,0,1,9,13,15,16,0,16,0,3,10,0,3,10,0);
 
         /*  PUSH STATES ARE BUILT-IN TO THE INDEX TABLES  */
 
         DECLARE APPLY1(ASIZE) BIT(8) INITIAL (0,0,80,0,56,58,71,82,83,0,56,89
         ,90,0,89,90,0,0,0,0,0,0,0,0,0,0,0,0,0,0,83,90,0,71,83,90,0,0,0,0,0,0,15
         ,0,0,9,79,99,0,0,0,0,0,0,0,57,0,55,0,0,3,18,22,27,28,29,49,50,84,0,6,0
         ,7,0,10,0,0,53,0,17,0,4,5,12,13,0,8,14,25,0,1,19,26,56,57,58,71,80,82
         ,83,89,90,0,0,72,0);
 
         DECLARE READ2(RSIZE) BIT(8) INITIAL (0,138,19,20,21,26,174,103,30,104
         ,213,3,4,10,12,234,233,105,3,234,233,105,3,234,233,105,3,4,10,12,234
         ,233,105,3,4,10,12,234,233,105,3,234,233,105,23,182,184,183,3,4,12,234
         ,233,105,211,212,210,3,234,233,105,3,234,233,105,3,234,233,105,190,106
         ,214,3,4,12,234,233,105,3,4,10,12,234,233,105,146,27,28,105,173,3,4,10
         ,12,234,233,105,3,4,10,12,234,233,105,186,166,3,234,233,105,105,3,4,10
         ,12,234,233,105,3,4,10,12,234,233,105,3,4,10,12,234,233,105,190,106,193
         ,9,185,178,231,168,231,34,189,191,162,164,8,14,25,8,14,25,8,14,25,8,14
         ,25,8,14,25,158,160,172,132,3,4,10,12,234,233,105,3,4,10,12,234,233,105
         ,33,192,194,3,4,12,234,233,105,198,197,197,138,19,20,21,26,174,103,30
         ,104,105,138,19,20,21,26,174,103,30,104,131,32,6,143,6,6,230,232,6,6,6
         ,228,6,6,22,6,18,6,138,19,20,21,102,26,174,103,30,104,234,233,148,149
         ,135,7,7,39,159,23,182,184,183,138,19,20,21,26,174,103,30,104,163,157
         ,23,182,184,183,138,19,20,21,126,26,174,103,30,104,138,19,20,21,102,26
         ,174,103,30,104,3,4,10,12,234,233,105,144,136,38,147,138,19,20,21,26
         ,174,103,30,161,104,138,19,20,21,102,26,174,103,30,161,104,134,31,100
         ,11,101,207,17,17,133,5,13,5,13,137,15,187,23,182,184,183);
 
         DECLARE LOOK2(LSIZE) BIT(8) INITIAL (0,2,208,16,209,24,165,169,29,35,35
         ,229,36,229,37,188,40,40,40,217,41,41,41,220,42,42,42,221,43,43,43,218
         ,44,44,44,219,62,170,64,155,65,154,67,195,152,69,70,153,76,199,77,200
         ,85,129,92,177,93,93,93,93,93,205,94,206,96,96,215,97,97,216);
 
         DECLARE APPLY2(ASIZE) BIT(8) INITIAL (0,0,83,82,140,141,150,128,128,127
         ,120,139,139,129,142,142,130,56,58,48,71,88,151,73,74,95,80,81,79,78
         ,156,167,145,90,90,90,89,91,75,86,47,98,176,175,121,180,46,179,45,51,60
         ,99,87,181,72,196,59,50,49,57,66,117,116,113,114,112,115,68,63,61,119
         ,118,202,201,204,203,53,123,122,125,124,108,110,109,111,107,223,224,225
         ,222,54,55,171,54,54,54,54,54,54,54,54,54,227,84,52,226);
 
         DECLARE INDEX1(MAXS#) BIT(16) INITIAL (0,1,10,11,18,22,26,33,40,44,48
         ,54,57,61,65,69,71,72,78,85,89,90,97,104,105,106,110,111,118,125,132
         ,134,135,136,137,138,140,141,142,144,146,149,152,155,158,161,162,163
         ,164,165,172,179,180,182,188,190,191,200,201,210,211,212,214,215,218
         ,219,220,222,223,225,227,228,238,240,241,242,243,244,245,246,251,260
         ,266,276,286,293,294,295,296,297,307,318,319,320,325,326,327,329,331
         ,333,1,3,5,7,9,12,14,16,20,24,28,32,36,38,40,42,44,46,48,50,52,54,56,62
         ,64,67,1,2,2,4,4,10,10,10,10,10,10,10,10,10,14,14,14,17,18,19,20,20,20
         ,20,20,21,22,22,23,24,25,26,26,26,26,27,28,29,29,30,30,30,33,37,37,38
         ,39,40,40,41,41,42,42,44,44,44,45,45,45,45,49,50,51,51,52,52,53,54,54
         ,55,55,57,59,60,60,70,70,72,72,74,74,76,76,76,76,76,76,76,76,77,77,79
         ,79,79,79,79,81,81,81,81,86,86,86,90,90,103,103,104,104);
 
         DECLARE INDEX2(MAXS#) BIT(8) INITIAL (0,9,1,7,4,4,7,7,4,4,6,3,4,4,4,2,1
         ,6,7,4,1,7,7,1,1,4,1,7,7,7,2,1,1,1,1,2,1,1,2,2,3,3,3,3,3,1,1,1,1,7,7,1
         ,2,6,2,1,9,1,9,1,1,2,1,3,1,1,2,1,2,2,1,10,2,1,1,1,1,1,1,5,9,6,10,10,7,1
         ,1,1,1,10,11,1,1,5,1,1,2,2,2,5,2,2,2,2,3,2,2,4,4,4,4,4,2,2,2,2,2,2,2,2
         ,2,2,6,2,3,3,1,0,1,0,0,1,1,1,1,1,1,1,0,1,1,2,1,2,1,1,1,2,2,2,1,3,1,3,1
         ,1,2,1,2,2,3,1,2,0,2,0,1,1,1,0,1,1,1,1,0,1,2,0,2,1,3,1,0,0,0,2,1,1,0,2
         ,0,2,2,1,2,2,1,0,1,0,2,0,2,0,1,0,2,0,0,0,1,1,1,1,1,0,2,0,2,2,1,1,0,2,2
         ,2,0,0,2,0,2,1,2,0,0);
 
 
   /*  DECLARATIONS FOR THE SCANNER                                        */
   /* TOKEN IS THE INDEX INTO THE VOCABULARY V() OF THE LAST SYMBOL SCANNED,
      CP IS THE POINTER TO THE LAST CHARACTER SCANNED IN THE CARDIMAGE,
      BCD IS THE LAST SYMBOL SCANNED (LITERAL CHARACTER STRING). */

   DECLARE TOKEN FIXED, BCD CHARACTER, CH FIXED, CP FIXED;

   /* SET UP SOME CONVENIENT ABBREVIATIONS FOR PRINTER CONTROL */

   DECLARE TRUE LITERALLY '"1"', FALSE LITERALLY '"0"',
      FOREVER LITERALLY 'WHILE TRUE',
      X70 CHARACTER INITIAL ('                                        
                              ');
   DECLARE POINTER CHARACTER INITIAL    ('                              
                                                           ^');
   /* LENGTH OF LONGEST SYMBOL IN V */
   DECLARE RESERVED_LIMIT 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 CHARTYPE(255) BIT(8), TX(255) BIT(8), CONTROL(255) BIT(1),
      NOT_LETTER_OR_DIGIT(255) BIT(1);
   /* BUFFER HOLDS THE LATEST CARDIMAGE,
      TEXT HOLDS THE PRESENT STATE OF THE INPUT TEXT
      (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 SOURCE CARD READ,
      ERROR_COUNT TABULATES THE ERRORS AS THEY ARE DETECTED,
      SEVERE_ERRORS TABULATES THOSE ERRORS OF FATAL SIGNIFICANCE.
      CURRENT_PROCEDURE CONTAINS THE NAME OF THE PROCEDURE BEING PROCESSED.
   */
   DECLARE BUFFER CHARACTER, TEXT CHARACTER, TEXT_LIMIT FIXED,
       CARD_COUNT FIXED, ERROR_COUNT FIXED,
       SEVERE_ERRORS FIXED, PREVIOUS_ERROR FIXED,
       LINE_LENGTH  FIXED,         /* LENGTH OF SOURCE STATEMENT */
       CURRENT_PROCEDURE CHARACTER;

   /* NUMBER_VALUE CONTAINS THE NUMERIC VALUE OF THE LAST CONSTANT SCANNED,
   */
   DECLARE NUMBER_VALUE FIXED, JBASE FIXED, BASE FIXED;
   /* EACH OF THE FOLLOWING CONTAINS THE INDEX INTO V() OF THE CORRESPONDING
      SYMBOL.   WE ASK:    IF TOKEN = IDENT    ETC.    */
   DECLARE IDENT FIXED, STRING FIXED, NUMBER FIXED, DIVIDE FIXED, EOFILE FIXED,
      LABELSET FIXED;
   DECLARE ORSYMBOL FIXED, CONCATENATE FIXED;
   DECLARE BALANCE CHARACTER, LB FIXED ;
   DECLARE MACRO_LIMIT LITERALLY '60', MACRO_NAME (MACRO_LIMIT) CHARACTER,
      MACRO_TEXT(MACRO_LIMIT) CHARACTER, MACRO_INDEX (255) BIT (8),
      MACRO_COUNT (MACRO_LIMIT) FIXED, MACRO_DECLARE (MACRO_LIMIT) FIXED,
      TOP_MACRO FIXED;
   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 CHECKING 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.
   */
   DECLARE STOPIT(TERMINAL#) BIT(1), FAILSOFT FIXED, COMPILING FIXED;
   /*   THE FOLLOWING SWITCH IS USED BY THE LALR PARSER   */

   DECLARE NO_LOOK_AHEAD_DONE BIT(1);
   DECLARE TARGET_REGISTER FIXED;       /* FOR FINDAR */
   DECLARE TRUELOC FIXED;               /* LOCATION OF CONSTANT 1 */
   DECLARE FALSELOC FIXED;              /* LOCATION OF CONSTANT 0 */
   DECLARE BYTEPTRS FIXED,              /* LOCATION OF 4 PTRS FOR LDB & DPB */
           PSBITS FIXED;                /* BYTE PTRS FORE MOVE */
   DECLARE STRING_CHECK FIXED,          /* COMPACTIFY CALLER */
           CATENTRY FIXED,              /* CATENATION SUBROUTINE */
           NMBRENTRY FIXED,             /* NUMBER TO STRING SUBROUTINE */
           STRCOMP FIXED,               /* STRING COMPARE SUBROUTINE */
           CALLTYPE FIXED INITIAL (1),  /* DIST BETWEEN SUB & FUNCTION */
           MOVER FIXED,                 /* STRING MOVE SUBROUTINE */
           STRING_RECOVER FIXED,        /* SYT LOCATION OF COMPACTIFY */
           COREBYTELOC FIXED,           /* SYT LOCATION OF COREBYTE */
           LIMITWORD FIXED,             /* ADDRESS OF FREELIMIT */
           TSA FIXED;                   /* ADDRESS OF FREEPOINT */
   DECLARE NDESC FIXED;                 /* ADDRESS OF NDESCRIPT               */
   DECLARE LIBRARY FIXED,               /* ADDRESS OF RUNTIME LIBRARY */
           LIBRARY_SAVE FIXED,          /* PLACE TO STORE R11 ON LIB CALLS */
           STR  FIXED;                  /* DESCRIPTOR OF LAST STRING */
   DECLARE STEPK FIXED;                 /* USED FOR DO LOOPS */
   DECLARE A FIXED, B FIXED, C FIXED;   /* FOR CATENATION & CONVERSION */
   DECLARE LENGTHMASK FIXED;            /* ADDR OF DV LENGTH MASK */
   DECLARE ADDRMASK FIXED;              /* ADDRESS OF "FFFFF" */
   DECLARE LABEL_SINK FIXED INITIAL(0); /* FOR LABEL GENERATOR */
   DECLARE LABEL_GEN CHARACTER;         /* CONTAINS LABEL FOR NEXT INST*/
   DECLARE ACC(15) FIXED;               /* KEEPS TRACK OF ACCUMULATORS */
   DECLARE AVAIL LITERALLY '0', BUSY LITERALLY '1';
    /* CALL COUNTS OF IMPORTANT PROCEDURES */
   DECLARE COUNT_SCAN FIXED, /* SCAN               */
            COUNT_INST FIXED,  /* EMITINST           */
            COUNT_FORCE FIXED, /* FORCEACCUMULATOR   */
            COUNT_ARITH FIXED, /* ARITHEMIT          */
            COUNT_STORE FIXED; /* GENSTORE           */

   DECLARE TITLE        CHARACTER,     /*TITLE LINE FOR LISTING */
           SUBTITLE     CHARACTER,     /*SUBTITLE FOR LISTING */
           PAGE_COUNT   FIXED,         /*CURRENT PAGE NUMBER FOR LISTING*/
           LINE_COUNT   FIXED,         /*NUMBER OF LINES PRINTED */
           PAGE_MAX LITERALLY '54',    /*MAX NO OF LINES ON PAGE*/
           EJECT_PAGE LITERALLY 'LINE_COUNT = PAGE_MAX+1';
   DECLARE SOURCE CHARACTER;           /*FILE NAME BEING COMPILED*/
   DECLARE DATAFILE LITERALLY '2';     /* SCRATCH FILE FOR DATA */
   DECLARE CODEFILE LITERALLY '3';     /* SCRATCH FILE FOR CODE */
   DECLARE RELFILE  LITERALLY '4';     /* BINARY OUTPUT FILE */
   DECLARE LIBFILE  LITERALLY '5';     /* SOURCE LIBRARY FILE */
   DECLARE READING  BIT(1);            /* 0 IFF READING LIBFILE */
   DECLARE DATACARD CHARACTER;         /* DATA BUFFER */
   DECLARE PP      FIXED,              /* CURRENT PROGRAM POINTER */
           CODE(3) CHARACTER,           /* THE CODE BUFFER */
           CODE_FULL(3) BIT(1),         /* FULLNESS FLAG */
           CODE_HEAD FIXED,             /* FRONT OF BUFFER */
           CODE_TAIL FIXED,             /* END OF BUFFER */
           DP      FIXED,              /* CURRENT DATA POINTER */
           DPOFFSET FIXED;             /* CURRENT DP BYTE OFFSET */
   DECLARE CODESTRING CHARACTER;     /*FOR COPYING CODE INTO DATA FILE*/

   /*   THE FOLLOWING ARE FOR RELOCATABLE BINARY CODE EMISSION */

   DECLARE BUFFERSIZE LITERALLY '18';   /* SIZE OF BINARY BUFFERS */
   DECLARE CODE_BUFFER (BUFFERSIZE) FIXED;   /*CODE (HIGH) BUFFER */
   DECLARE DATA_BUFFER (BUFFERSIZE) FIXED;   /* DATA (LOW) BUFFER */
   DECLARE LABEL_BUFFER (BUFFERSIZE) FIXED;  /* LABELS DEFINED BUFFER */
   DECLARE CODE_REL(3) FIXED,         /* BINARY CODE BUFFER (SEE CODE) */
           CODE_PP(3) FIXED,
           CODE_RBITS(3) FIXED;

   DECLARE RPTR FIXED,                  /* POINTER TO CODE_BUFFER */
           RCTR FIXED,                  /* COUNTER FOR CODE_BUFFER */
           DPTR FIXED,                   /* POINTER TO DATA_BUFFER */
           DCTR FIXED,                  /* COUNTER FOR DATA_BUFFER */
           DLOC FIXED;                   /* LOCATION OF NEXT WORD IN DATA BUFFER */
   DECLARE LABEL_COUNT FIXED;            /*NO OF LABELS IN LABEL_BUFFER */

   DECLARE FOR_MAX  LITERALLY '50';      /* MAXIMUM FORWARD REFERENCES */
   DECLARE FOR_REF   (FOR_MAX) FIXED,    /* FORWARD REFERENCED LABELS */
           FOR_LABEL (FOR_MAX) FIXED,    /* LABEL REFERENCED */
           FOR_COUNT FIXED;              /* COUNT OF CURRENT FORWARD REFS */
   DECLARE PWORD FIXED;                  /* PART-WORD ACC. FOR BYTES*/
   DECLARE STARTLOC FIXED;               /* FIRST INSTRUCTION TO BE EXECUTED */


   DECLARE CODE_TYPE LITERALLY '"(3)1000000"';   /* CODE & DATA TYPE BLOCK */
   DECLARE SYMB_TYPE LITERALLY '"(3)2000000"';   /* SYMBOL DEFN TYPE BLOCK */
   DECLARE HISEG_TYPE LITERALLY '"(3)3000000"';  /* HIGH SEGMENT TYPE BLOCK */
   DECLARE END_TYPE LITERALLY '"(3)5000000"';    /* END TYPE BLOCK */
   DECLARE NAME_TYPE LITERALLY '"(3)6000000"';   /* NAME TYPE BLOCK */
   DECLARE START_TYPE LITERALLY '"(3)7000000"';  /* START ADDRESS TYPE BLOCK */
   DECLARE INTREQ_TYPE LITERALLY '"(3)10000000"'; /* INTERNAL REQUEST TYPE BLOCK */
 

   /* END OF DEFINITIONS FOR RELOCATABLE BINARY FILES */

   DECLARE ADR     FIXED;
   DECLARE ITYPE FIXED;
   DECLARE NEWDP FIXED, NEWDSP FIXED, NEWDPOFFSET FIXED; /* FOR ALLOCATION */
   DECLARE OLDDP FIXED, OLDDSP FIXED, OLDDPOFFSET FIXED; /* FOR ALLOCATION */
   DECLARE DESCLIMIT LITERALLY '1000', /* NUMBER OF STRING DESCRIPTORS */
           DESCA (DESCLIMIT) FIXED,     /* STRING DESCRIPTOR ADDRESS */
           DESCL (DESCLIMIT) FIXED,     /* STRING DESCRIPTOR LENGTH */
           DESCREF (DESCLIMIT) FIXED,    /* LAST REFERENCE TO STRING */
           DSP     FIXED;              /* DESCRIPTOR POINTER */
   DECLARE S CHARACTER;
   DECLARE OPNAME (15) CHARACTER INITIAL (
'      .INIT..INPT..OUTP..EXIT.      .FILI..FILO..NAME.',
'CALL  INIT  UUO042UUO043UUO044UUO045UUO046CALLI OPEN  TTCALLUUO052UUO053UUO054
RENAMEIN    OUT   SETSTSSTATO GETSTSSTATZ INBUF OUTBUFINPUT OUTPUTCLOSE 
RELEASMTAPE UGETF USETI USETO LOOKUPENTER ',
'UUO100UUO101UUO102UUO103UUO104UUO105UUO106UUO107UUO110UUO111UUO112UUO113UUO114U
UO115UUO116UUO117UUO120UUO121UUO122UUO123UUO124UUO125UUO126UUO127UFA   DFN   FSC
   IBP   ILDB  LDB   IDPB  DPB   ',
'',
'MOVE  MOVEI MOVEM MOVES MOVS  MOVSI MOVSM MOVSS MOVN  MOVNI MOVNM MOVNS MOVM  M
OVMI MOVMM MOVMS IMUL  IMULI IMULM IMULB MUL   MULI  MULM  MULB  IDIV  IDIVI IDI
VM IDIVB DIV   DIVI  DIVM  DIVB  ',
'ASH   ROT   LSH   JFFO  ASHC  ROTC  LSHC  ......EXCH  BLT   AOBJP AOBJN JRST  J
FCL  XCT   ......PUSHJ PUSH  POP   POPJ  JSR   JSP   JSA   JRA   ADD   ADDI  ADD
M  ADDB  SUB   SUBI  SUBM  SUBB  ',
'CAI   CAIL  CAIE  CAILE CAIA  CAIGE CAIN  CAIG  CAM   CAML  CAME  CAMLE CAMA  C
AMGE CAMN  CAMG  JUMP  JUMPL JUMPE JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP  SKIPL SKI
PE SKIPLESKIPA SKIPGESKIPN SKIPG ',
 'AOJ   AOJL  AOJE  AOJLE AOJA  AOJGE AOJN  AOJG  AOS   AOSL  AOSE  AOSLE AOSA  A
OSGE AOSN  AOSG  SOJ   SOJL  SOJE  SOJLE SOJA  SOJGE SOJN  SOJG  SOS   SOSL  SOS
E  SOSLE SOSA  SOSGE SOSN  SOSG  ',
'SETZ  SETZI SETZM SETZB AND   ANDI  ANMD  ANDB  ANDCA ANDCAIANDCAMANDCABSETM  S
ETMI SETMM SETMB ANDCM ANDCMIANDCMMANDCMBSETA  SETAI SETAM SETAB XOR   XORI  XOR
M  XORB  IOR   IORI  IORM  IORB  ',
'ANDCB ANDCBIANDCBMANDCBBEQV   EQVI  EQVM  EQVB  SETCA SETCAISETCAMSETCABORCA  O
RCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM  ORCMI ORCMM ORCMB ORCB  ORCBI ORC
BM ORCBB SETO  SETOI SETOM SETOB ',
'HLL   HLLI  HLLM  HLLS  HRL   HRLI  HRLM  HRLS  HLLZ  HLLZI HLLZM HLLZS HRLZ  H
RLZI HRLZM HRLZS HLLO  HLLOI HLLOM HLLOS HRLO  HRLOI HRLOM HRLOS HLLE  HLLEI HLL
EM HLLES HRLE  HRLEI HRLEM HRLES ',
'HRR   HRRI  HRRM  HRRS  HLR   HLRI  HLRM  HLRS  HRRZ  HRRZI HRRZM HRRZS HLRZ  H
LRZI HLRZM HLRZS HRRO  HRROI HRROM HRROS HLRO  HLROI HLROM HLROS HRRE  HRREI HRR
EM HRRES HLRE  HLREI HLREM HLRES ',
'TRN   TLN   TRNE  TLNE  TRNA  TLNA  TRNN  TLNN  TDN   TSN   TDNE  TSNE  TDNA  T
SNA  TDNN  TSNN  TRZ   TLZ   TRZE  TLZE  TRZA  TLZA  TRZN  TLZN  TDZ   TSZ   TDZ
E  TSZE  TDZA  TSZA  TDZN  TSZN  ',
'TRC   TLC   TRCE  TLCE  TRCA  TLCA  TRCN  TLCN  TDC   TSC   TDCE  TSCE  TDCA  T
SCA  TDCN  TSCN  TRO   TLO   TROE  TLOE  TROA  TLOA  TRON  TLON  TDO   TSO   TDO
E  TSOE  TDOA  TSOA  TDON  TSON  ',
'',
'');
   DECLARE INSTRUCT(511) FIXED;         /* COUNT OF THE INSTRUCTIONS ISSUED */
         /* COMMONLY USED OPCODES */
   DECLARE ADD    FIXED INITIAL ("(3)270"),
           ADDI   FIXED INITIAL ("(3)271"),
           ADDM   FIXED INITIAL ("(3)272"),
           AND    FIXED INITIAL ("(3)404"),
           ANDI   FIXED INITIAL ("(3)405"),
           AOSA   FIXED INITIAL ("(3)354"),
           BLT    FIXED INITIAL ("(3)251"),
           CALLI  FIXED INITIAL ("(3)047"),
           CAM    FIXED INITIAL ("(3)310"),
           CAMGE  FIXED INITIAL ("(3)315"),
           CAML   FIXED INITIAL ("(3)311"),
           CAMLE  FIXED INITIAL ("(3)313"),
           CAMN   FIXED INITIAL ("(3)316"),
           CMPRHI FIXED INITIAL ("(3)317"),
           DPB    FIXED INITIAL ("(3)137"),
           HLL    FIXED INITIAL ("(3)500"),
           HLRZ   FIXED INITIAL ("(3)554"),
           HRLI   FIXED INITIAL ("(3)505"),
           HRLM   FIXED INITIAL ("(3)506"),
           HRREI  FIXED INITIAL ("(3)571"),
           IDIV   FIXED INITIAL ("(3)230"),
           IDIVI  FIXED INITIAL ("(3)231"),
           IDPB   FIXED INITIAL ("(3)136"),
           ILDB   FIXED INITIAL ("(3)134"),
           IMUL   FIXED INITIAL ("(3)220"),
           IOR    FIXED INITIAL ("(3)434"),
           JRST   FIXED INITIAL ("(3)254"),
           JUMP   FIXED INITIAL ("(3)320"),
           JUMPE  FIXED INITIAL ("(3)322"),
           JUMPGE FIXED INITIAL ("(3)325"),
           JUMPN  FIXED INITIAL ("(3)326"),
           LDB    FIXED INITIAL ("(3)135"),
           LSH    FIXED INITIAL ("(3)242"),
           LSHC   FIXED INITIAL ("(3)246"),
           MOVE   FIXED INITIAL ("(3)200"),
           MOVEI  FIXED INITIAL ("(3)201"),
           MOVEM  FIXED INITIAL ("(3)202"),
           MOVM   FIXED INITIAL ("(3)214"),
           MOVN   FIXED INITIAL ("(3)210"),
           POP    FIXED INITIAL ("(3)262"),
           POPJ   FIXED INITIAL ("(3)263"),
           PUSH   FIXED INITIAL ("(3)261"),
           PUSHJ  FIXED INITIAL ("(3)260"),
           ROT    FIXED INITIAL ("(3)241"),
           SETCA  FIXED INITIAL ("(3)450"),
           SETZM  FIXED INITIAL ("(3)402"),
           SKIP   FIXED INITIAL ("(3)330"),
           SKIPE  FIXED INITIAL ("(3)332"),
           SOJG   FIXED INITIAL ("(3)367"),
           SUB    FIXED INITIAL ("(3)274"),
           SUBI   FIXED INITIAL ("(3)275");
   DECLARE COMPARESWAP (7) FIXED INITIAL (0,7,2,5,0,3,6,1);
   DECLARE STILLCOND FIXED,            /* PEEP HOLE FOR BOOL BRANCHING */
           STILLINZERO FIXED;          /* PEEPHOLE FOR REDUNDANT MOVES */
   DECLARE STATEMENT_COUNT FIXED;      /* A COUNT OF THE XPL STATEMENTS */
   DECLARE IDCOMPARES FIXED;
   DECLARE X1 CHARACTER INITIAL (' ');
   DECLARE X2 CHARACTER INITIAL ('  ');
   DECLARE X3 CHARACTER INITIAL ('   ');
   DECLARE X4 CHARACTER INITIAL ('    ');
   DECLARE X7 CHARACTER INITIAL ('       ');
   DECLARE INFO CHARACTER;         /* FOR LISTING INFORMATION*/
   DECLARE CHAR_TEMP CHARACTER;
   DECLARE I_STRING CHARACTER;      /* FOR I_FORMAT */
   DECLARE I FIXED, J FIXED, K FIXED, L FIXED;
   DECLARE PROCMARK FIXED, NDECSY FIXED, MAXNDECSY FIXED, PARCT FIXED;
   DECLARE RETURNED_TYPE FIXED;
   DECLARE LABELTYPE     LITERALLY  '1',
           ACCUMULATOR   LITERALLY  '2',
           VARIABLE      LITERALLY  '3',
           CONSTANT      LITERALLY  '4',
           CHRTYPE       LITERALLY  '6',
           FIXEDTYPE     LITERALLY  '7',
           BYTETYPE      LITERALLY  '8',
           FORWARDTYPE   LITERALLY  '9',
           DESCRIPT      LITERALLY '10',
           SPECIAL       LITERALLY '11',
           FORWARDCALL   LITERALLY '12',
           PROCTYPE      LITERALLY '13',
           CHARPROCTYPE  LITERALLY '14';
   DECLARE TYPENAME (14) CHARACTER INITIAL ('', 'LABEL    ', '', '', '', '',
           'CHARACTER', 'FIXED    ', 'BIT (9)  ' , '', '', '', '',
           'PROCEDURE','CHARACTER PROCEDURE');
   /*  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.  CHANGES SHOULD BE MADE OBSERVING DUE CAUTION TO
       AVOID MESSING THINGS UP.
   */
   DECLARE SYTSIZE LITERALLY '420';     /* THE SYMBOL TABLE SIZE */
   DECLARE SYT (SYTSIZE) CHARACTER      /* THE VARIABLE NAME */
      INITIAL ('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', 'RUNTIME', 'FILENAME',
         'COMPACTIFY', 'FREELIMIT', 'FREEBASE');
   DECLARE SYTYPE (SYTSIZE) BIT (8)     /* TYPE OF VARIABLE */
      INITIAL (FIXEDTYPE, BYTETYPE, FIXEDTYPE, FIXEDTYPE,
         FIXEDTYPE, SPECIAL, SPECIAL, SPECIAL, SPECIAL, SPECIAL,
         SPECIAL, SPECIAL, SPECIAL, SPECIAL, SPECIAL, SPECIAL,
          SPECIAL, SPECIAL, SPECIAL, SPECIAL, SPECIAL,
         SPECIAL, SPECIAL, SPECIAL, SPECIAL,
         FORWARDCALL, FIXEDTYPE, FIXEDTYPE);
   DECLARE SYTLOC (SYTSIZE) FIXED       /* LOCATION OF VARIABLE */
      INITIAL (0,0,0,0,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
          0,0,0);
   DECLARE SYTSEG (SYTSIZE) BIT(8)      /* SEGMENT OF VARIABLE */
      INITIAL (0,0,1,3,5,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4,1,1);
   DECLARE SYTCO (SYTSIZE) FIXED;       /* A COUNT OF REFERENCES */
   DECLARE SYTCARD (SYTSIZE) FIXED;     /* WHERE SYMBOL IS DEFINED */

   DECLARE HASH (255)      FIXED,       /* HASH TABLE INTO SYMBOL TABLE*/
           PTR  (SYTSIZE)  FIXED,       /* POINTS TO NEXT SYMBOL IN HASH*/
           IDX             FIXED;       /* INDEX WHILE USING HASH*/

   /*  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 '50';  /* SIZE OF STACK  */
   DECLARE STATE_STACK (STACKSIZE)  BIT (8);
   DECLARE TYPE        (STACKSIZE)  FIXED;
   DECLARE REG         (STACKSIZE)  FIXED;
   DECLARE INX         (STACKSIZE)  FIXED;
   DECLARE CNT         (STACKSIZE)  FIXED;
   DECLARE VAR         (STACKSIZE)  CHARACTER;
   DECLARE FIXV        (STACKSIZE)  FIXED;
   DECLARE PPSAVE      (STACKSIZE)  FIXED;
   DECLARE FIXL        (STACKSIZE)  FIXED;
   DECLARE SP FIXED, MP FIXED, MPP1 FIXED;

   DECLARE CASELIMIT LITERALLY '175',
           CASESTACK (CASELIMIT) FIXED, /* CONTAINS ADDR OF STMTS OF CASE */
           CASEP  FIXED;                /* POINTS TO CURRENT CASESTACK ENTRY */

   DECLARE CODEMSG  CHARACTER INITIAL ('CODE = '),
           DATAMSG  CHARACTER INITIAL ('DATA = '),
           BACKMSG  CHARACTER INITIAL ('BACK UP CODE EMITTER'),
           FILEMSG  CHARACTER INITIAL ('MISSING NUMBER FOR FILE');


/*
          G L O B A L   P R O C E D U R E S
*/

I_FORMAT:
   PROCEDURE (NUMBER, WIDTH);
   DECLARE NUMBER  FIXED,
           WIDTH   FIXED;
   DECLARE L       FIXED;
   I_STRING = NUMBER;
   L = LENGTH (I_STRING);
   IF L < WIDTH THEN
         I_STRING = SUBSTR(X70,0,WIDTH-L) ^^ I_STRING;
   END  I_FORMAT;

PRINTLINE:
   PROCEDURE (LINE, IND);
   DECLARE LINE CHARACTER,             /*LINE TO BE PRINTED */
           IND FIXED;                  /*FORMAT INDICATOR*/
   DECLARE CTL(5) CHARACTER INITIAL ('0','1','','','','');
   DECLARE SKIPS (5) FIXED INITIAL (2,99,0,0,0,0);
   IF LINE_COUNT > PAGE_MAX THEN
      DO;
         PAGE_COUNT = PAGE_COUNT + 1;
         OUTPUT(1) = TITLE ^^ PAGE_COUNT;
         OUTPUT = SUBTITLE;
         OUTPUT = ' ';
         LINE_COUNT = 0;
      END;
   IF IND < 0 ^ IND > 5 THEN
      DO;
         OUTPUT = LINE;
         LINE_COUNT = LINE_COUNT + 1;
      END;
   ELSE
      DO;
         OUTPUT(1) = CTL(IND) ^^ LINE;
         LINE_COUNT = LINE_COUNT + SKIPS(IND);
      END;
END PRINTLINE;
   ERROR:
      PROCEDURE (MSG, SEVERITY);
   /* PRINT THE ERROR MESSAGE WITH A POINTER POINTING TO THE CURRENT TOKEN
      BEING SCANNED.  IF SOURCE LISTING IS DISABLED, ALSO PRINT THE CURRENT
      SOURCE IMAGE.
   */
      DECLARE MSG CHARACTER, SEVERITY FIXED;
      DECLARE I FIXED;
      ERROR_COUNT = ERROR_COUNT + 1;
      IF CONTROL(BYTE('L')) = 0 THEN
         DO;
            I = 5 - LENGTH(CARD_COUNT);
            CALL PRINTLINE (SUBSTR (X70, 0, I) ^^ CARD_COUNT ^^ X4 ^^ BUFFER,-1);
         END;
      CALL PRINTLINE (SUBSTR(POINTER,LENGTH(POINTER)-7-
            (LINE_LENGTH+CP-TEXT_LIMIT-LB-1)),-1);

      OUTPUT(-1) = CARD_COUNT ^^ X4 ^^ BUFFER;
      OUTPUT(-1) = X7 ^^ MSG;

      IF PREVIOUS_ERROR > 0 THEN
         MSG = MSG ^^ '. LAST PREVIOUS ERROR WAS ON LINE ' ^^ PREVIOUS_ERROR;
      CALL PRINTLINE ('*** ERROR. ' ^^ MSG,-1);
      PREVIOUS_ERROR = CARD_COUNT;
      IF SEVERITY > 0 THEN
         IF SEVERE_ERRORS > 25 THEN
            DO;
                CALL PRINTLINE ('*** TOO MANY SEVERE ERRORS, COMPILATION ABORTED ***',0);
                COMPILING = FALSE;
             END;
           ELSE SEVERE_ERRORS = SEVERE_ERRORS + 1;
   END ERROR;
   /*                THE SCANNER PROCEDURES              */
   BUILD_BCD:
      PROCEDURE (C);
      DECLARE C BIT(9);
      IF LENGTH(BCD) > 0 THEN BCD = BCD ^^ X1;
      ELSE BCD = SUBSTR(X1 ^^ X1, 1);
      COREBYTE(FREEPOINT-1) = C;
   END BUILD_BCD;
   GET_CARD:
      PROCEDURE;
      /* DOES ALL CARD READING AND LISTING                                 */
      DECLARE I FIXED, TEMPO CHARACTER, TEMP2 CHARACTER;
      IF LB \= 0 THEN
         DO;
            IF CP >= 255 THEN
               DO;
                  TEXT = SUBSTR(TEXT, LB);
                  CP = CP - LB;
                  CALL ERROR ('IDENTIFIER TOO LONG', 0);
               END;
               IF LB > 255 - CP THEN I = 255 - CP;
               ELSE I = LB;
               LB = LB - I;
               TEXT = TEXT ^^ SUBSTR(BALANCE, 0, I);
               BALANCE = SUBSTR(BALANCE, I);
               TEXT_LIMIT = LENGTH(TEXT) - 1;
               RETURN;
         END;
      EXPANSION_COUNT = 0;    /* CHECKED IN SCANNER  */
      IF READING THEN   /* READING IS FALSE INITIALLY, TO READ LIBRARY */
         DO;
            BUFFER = INPUT;
            IF LENGTH(BUFFER) = 0 THEN
               DO;
                  CALL ERROR ('EOF MISSING', 0);
                  BUFFER = ' /* '' /* */ EOF; END; EOF; END; EOF';
               END;
            ELSE CARD_COUNT = CARD_COUNT + 1;
         END;
      ELSE
         DO;
            BUFFER = INPUT(LIBFILE);
            IF LENGTH(BUFFER) = 0 THEN
               DO;
                  READING = TRUE;
                  BUFFER = INPUT;
                  CARD_COUNT = CARD_COUNT + 1;
                  STATEMENT_COUNT = 0;
                  CONTROL(BYTE('L')) = TRUE & \ CONTROL(BYTE('K'));
               END;
         END;
      LINE_LENGTH = LENGTH (BUFFER);
      IF CP + LENGTH(BUFFER) > 255 THEN
         DO;
            I = 255 - CP;
            TEXT = TEXT ^^ SUBSTR(BUFFER, 0, I);
            BALANCE = SUBSTR(BUFFER, I);
            LB = LENGTH(BALANCE);
         END;
      ELSE TEXT = TEXT ^^ BUFFER;
      TEXT_LIMIT = LENGTH(TEXT) - 1;
      IF CONTROL(BYTE('M')) THEN CALL PRINTLINE(BUFFER,-1);
      ELSE IF CONTROL(BYTE('L')) THEN
         DO;
            TEMPO = CARD_COUNT;
            I = 5 - LENGTH (TEMPO);
            TEMPO = SUBSTR(X70, 0, I) ^^ TEMPO ^^ X2 ^^ BUFFER;
            I = 88 - LENGTH(TEMPO);
            IF I >= 70 THEN
               DO;
                  I = I - 70;
                  TEMPO = TEMPO ^^ X70;
               END;
            IF I > 0 THEN TEMPO = TEMPO ^^ SUBSTR(X70, 0, I);
            TEMP2 = CURRENT_PROCEDURE ^^ INFO;
            IF CONTROL(BYTE('F')) THEN
                   TEMP2 = X2 ^^ PP ^^ X1 ^^ DP ^^ X1 ^^ DSP ^^ TEMP2;
            IF LENGTH (TEMP2) > 44 THEN TEMP2 = SUBSTR (TEMP2,0,44);
            CALL PRINTLINE (TEMPO ^^ TEMP2,-1);
         END;
      INFO = '';           /* CLEAR INFORMATION BUFFER */
   END GET_CARD;
   CHAR:
      PROCEDURE;
      CP = CP + 1;
      IF CP <= TEXT_LIMIT THEN RETURN;
      CP = 0;
      TEXT = '';
      CALL GET_CARD;
   END CHAR;
   DEBLANK:
      PROCEDURE;
      CALL CHAR;
      DO WHILE BYTE (TEXT, CP) = BYTE (' ');
         CALL CHAR;
      END;
   END DEBLANK;
   BCHAR:
      PROCEDURE;
      DO FOREVER;
         CALL DEBLANK;
         CH = BYTE(TEXT, CP);
         IF CH \= BYTE ('(') THEN RETURN;
         /*  (BASE WIDTH)  */
          CALL DEBLANK;
         JBASE = BYTE (TEXT, CP) - BYTE ('0');  /* WIDTH */
         IF JBASE < 1 ^ JBASE > 4 THEN
            DO;
               CALL ERROR ('ILLEGAL BIT STRING WIDTH: ' ^^ SUBSTR(TEXT,CP,1),0);
               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;
   SCAN:
      PROCEDURE;     /* GET THE NEXT TOKEN FROM THE TEXT  */
      DECLARE S1 FIXED, S2 FIXED;
   DECLARE LSTRNGM CHARACTER INITIAL ('STRING TOO LONG');
   DECLARE LBITM CHARACTER INITIAL ('BIT STRING TOO LONG');
    COUNT_SCAN = COUNT_SCAN + 1;
      FAILSOFT = TRUE;
      BCD = '';  NUMBER_VALUE = 0;
   RESCAN:
      IF CP > TEXT_LIMIT THEN
         DO;
            TEXT = '';
            CALL GET_CARD;
         END;
      ELSE
         DO;
            TEXT_LIMIT = TEXT_LIMIT - CP;
            TEXT = SUBSTR(TEXT, CP);
         END;
      CP = 0;
   /*  BRANCH ON NEXT CHARACTER IN TEXT                  */
      DO CASE CHARTYPE(BYTE(TEXT));
         /*  CASE 0  */
         /* ILLEGAL CHARACTERS FALL HERE  */
         CALL ERROR ('ILLEGAL CHARACTER: ' ^^ SUBSTR (TEXT, 0, 1), 0);
         /*  CASE 1  */
         /*  BLANK  */
         DO CP = 1 TO TEXT_LIMIT;
            IF BYTE (TEXT, CP) \= BYTE (' ') THEN GOTO RESCAN;
         END;
         /*  CASE 2  */
         DO FOREVER;   /* STRING QUOTE ('):  CHARACTER STRING       */
            TOKEN = STRING;
            DO CP = CP + 1 TO TEXT_LIMIT;
               IF BYTE (TEXT, CP) = BYTE ('''') THEN
                  DO;
                     IF LENGTH(BCD) + CP > 257 THEN
                        DO;
                           CALL ERROR (LSTRNGM, 0);
                           RETURN;
                        END;
                     IF CP > 1 THEN
                     BCD = BCD ^^ SUBSTR(TEXT, 1, CP-1);
                     CALL CHAR;
                      IF BYTE (TEXT, CP) = BYTE ('''') THEN
                         IF LENGTH(BCD) = 255 THEN
                           DO;
                             CALL ERROR (LSTRNGM, 0);
                             RETURN;
                           END;
                        ELSE
                           DO;
                              BCD = BCD ^^ SUBSTR(TEXT, CP, 1);
                              GO TO RESCAN;
                           END;
                     RETURN;
                  END;
            END;
            /*  WE HAVE RUN OFF A CARD  */
            IF LENGTH(BCD) + CP > 257 THEN
               DO;
                 CALL ERROR (LSTRNGM, 0);
                 RETURN;
               END;
            IF CP > 1 THEN BCD = BCD ^^ SUBSTR(TEXT, 1, CP-1);
            TEXT = X1;
            CP = 0;
            CALL GET_CARD;
         END;
         /*  CASE 3  */
         DO;      /*  BIT QUOTE("):  BIT STRING  */
            JBASE = 4;  BASE = 16;  /* DEFAULT WIDTH */
            TOKEN = NUMBER;
            S1 = 0;
            CALL BCHAR;
            DO WHILE CH \= BYTE ('"');
               S1 = S1 + JBASE;
               IF CH >= BYTE ('0') & CH <= BYTE ('9') THEN S2 = CH - BYTE ('0');
               ELSE S2 = CH + 10 - BYTE ('A');
               IF S2 >= BASE ^ S2 < 0 THEN
                  CALL ERROR ('ILLEGAL CHARACTER IN BIT STRING: '
                  ^^ SUBSTR(TEXT, CP, 1), 0);
               IF S1 > 36 THEN TOKEN = STRING;
               IF TOKEN = STRING THEN
                  DO WHILE S1 - JBASE >= 9;
                     IF LENGTH(BCD) >= 255 THEN
                        DO;
                           CALL ERROR ( LBITM, 0);
                           RETURN;
                        END;
                     S1 = S1 - 9;
                     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) >= 255 THEN CALL ERROR (LBITM,0);
               ELSE CALL BUILD_BCD (SHL(NUMBER_VALUE, 9 - 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  */
                     BCD = SUBSTR(TEXT, 0, CP);
                     IF CP > 1 THEN IF CP <= RESERVED_LIMIT THEN
                        /* CHECK FOR RESERVED WORDS */
                        DO I = 1 TO TERMINAL#;
                           IF BCD = VOCAB(I) THEN
                              DO;
                                 TOKEN = I;
                                 RETURN;
                              END;
                        END;
                     DO I = MACRO_INDEX(CP-1) TO MACRO_INDEX(CP) - 1;
                        IF BCD = MACRO_NAME(I) THEN
                           DO;
                            MACRO_COUNT(I) = MACRO_COUNT(I) + 1;
                              BCD = MACRO_TEXT(I);
                              IF EXPANSION_COUNT < EXPANSION_LIMIT THEN
                                 EXPANSION_COUNT = EXPANSION_COUNT + 1;
                              ELSE CALL PRINTLINE ('** WARNING, TOO MANY EXPANSIONS FOR
 THE MACRO: ' ^^ 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',0);
                                    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 RESCAN;
                           END;
                     END;
                     /*  RESERVED WORDS EXIT HIGHER:  THEREFORE <IDENTIFIER> */
                     TOKEN = IDENT;
                     RETURN;
                  END;
            END;
            /*  END OF CARD  */
            CALL GET_CARD;
            CP = CP - 1;
         END;
         /*  CASE 5  */
          DO FOREVER;   /*  DIGIT:  A NUMBER  */
            TOKEN = NUMBER;
            DO CP = CP TO TEXT_LIMIT;
               S1 = BYTE(TEXT, CP);
               IF S1 < BYTE ('0') ^ S1 > BYTE ('9') THEN RETURN;
               NUMBER_VALUE = 10 * NUMBER_VALUE + S1 - BYTE ('0');
            END;
            CALL GET_CARD;
         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  */
            S1, S2 = BYTE (' ');
            DO WHILE S1 \= BYTE ('*') ^ S2 \= BYTE ('/');
               IF S1 = BYTE ('$') THEN /* A CONTROL CHAR */
                    CONTROL(S2) = \CONTROL(S2) & 1;
               S1 = S2;
               CALL CHAR;
               S2 = 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  ^^  */
            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  */
      GO TO RESCAN;
   END SCAN;
   /*
            C O D E   E M I S S I O N   P R O C E D U R E S
 */
FLUSH_DATA_BUFFER:
   PROCEDURE;
      /* CLEAN OUT THE DATA BUFFER AND STICK ALL CURRENT CONTENTS
         INTO THE REL FILE */
      DECLARE I FIXED, J FIXED;
      IF (DPTR+DCTR) > 1 THEN
         DO;
            J = (DPTR/19)*18 + DCTR -1;
            FILE(RELFILE) = CODE_TYPE + J;
            I = DPTR+DCTR-1;
            DO J = 0 TO I;
               FILE(RELFILE) = DATA_BUFFER(J);
               END;
         END;
      DPTR = 0;
      DCTR = 1;
   END FLUSH_DATA_BUFFER;
FLUSH_CODE_BUFFER:
   PROCEDURE;
      /* CLEAN OUT THE CODE BUFFER AND STICK ALL CURRENT CONTENTS
         INTO THE REL FILE */
      DECLARE I FIXED, J FIXED;
      IF (RPTR+RCTR) > 1 THEN
         DO;
            I = (RPTR/19)*18 + RCTR -1;
            J = RPTR+RCTR-1;
            FILE (RELFILE) = CODE_TYPE+I;
            DO I = 0 TO J;
               FILE(RELFILE) = CODE_BUFFER(I);
               END;
         END;
      RPTR = 0;
      RCTR = 1;
   END FLUSH_CODE_BUFFER;
RADIX50:
   PROCEDURE (SYMBOL);
   /* PROCEDURE TO RETURN THE RADIX-50 REPRESENTATION OF A SYMBOL.
      ONLY THE FIRST 6 CHARACTERS ARE USED. */
   DECLARE SYMBOL CHARACTER;
   DECLARE (I,J,K,L) FIXED;

   J = 0;
   IF LENGTH(SYMBOL) < 6 THEN SYMBOL = SYMBOL ^^ X7;
   DO L = 0 TO 5;
      I = BYTE(SYMBOL,L);
      IF I = BYTE(' ') THEN K = 0;
         ELSE IF I = BYTE ('.') THEN K = "(3)45";
         ELSE IF I = BYTE ('$') THEN K = "(3)46";
         ELSE IF I = BYTE ('%') THEN K = "(3)47";
         ELSE IF I >= BYTE ('0') & I <= BYTE ('9') THEN
                    K = I-BYTE('0') + "(3)1";
         ELSE IF I >= BYTE ('A') & I <= BYTE ('Z') THEN
                    K = I - BYTE ('A') + "(3)13";
         ELSE RETURN J;
      J = J * "(3)50" + K;
      END;
   RETURN J;
   END RADIX50;
OUTPUT_CODEWORD:
   PROCEDURE;
   /* SPIT OUT THE INSTRUCTION AT CODEXXX(CODE_TAIL) */
   IF CODE_FULL(CODE_TAIL) THEN
      DO;
         IF CONTROL(BYTE('A')) THEN OUTPUT (CODEFILE) = CODE (CODE_TAIL);
         IF RCTR+RPTR = 1 THEN
            DO;
               CODE_BUFFER(0) =SHL(1,34);
               CODE_BUFFER(1) = CODE_PP(CODE_TAIL) + "(3)400000";
               RCTR = RCTR +1;
            END;
         CODE_BUFFER(RPTR) = SHL(CODE_RBITS(CODE_TAIL),36-RCTR*2)^CODE_BUFFER(RPTR);
         CODE_BUFFER(RPTR+RCTR) = CODE_REL(CODE_TAIL);
         RCTR = RCTR +1;
         IF RPTR+RCTR > BUFFERSIZE THEN CALL FLUSH_CODE_BUFFER;
         IF RCTR > 18 THEN
            DO;
               RPTR = RPTR +19;
               RCTR = 1;
               CODE_BUFFER(RPTR) = 0;
            END;
      END;
   CODE_FULL(CODE_TAIL) = FALSE;
   CODE_TAIL = (CODE_TAIL+1) & 3;
   END OUTPUT_CODEWORD;
FLUSH_LABELS:
   PROCEDURE;
      /* CLEAN OUT LABEL BUFFER BY GENERATING INTERNAL REQUEST
         TYPE BLOCK AND DEFINING ALL LABELS NOW KNOWN */
      DECLARE I FIXED;
      IF LABEL_COUNT = 0 THEN RETURN;
      DO WHILE CODE_TAIL \= CODE_HEAD;
         CALL OUTPUT_CODEWORD;
         END;
      CALL OUTPUT_CODEWORD;
      CODE_TAIL = CODE_HEAD;      /* RESET POINTERS, SINCE BUFFERS NOW EMPTY */
      STILLCOND, STILLINZERO = 0; /* MAKE SURE PEEPHOLE WORKS */
      CALL FLUSH_CODE_BUFFER;
      FILE (RELFILE) = INTREQ_TYPE+LABEL_COUNT;
      DO I = 0 TO LABEL_COUNT;
         FILE (RELFILE) = LABEL_BUFFER(I);
         END;
      LABEL_COUNT = 0;
      LABEL_BUFFER(0) = 0;
   END FLUSH_LABELS;
OUTPUT_DATAWORD:
   PROCEDURE (W,LOC);
      /* OUTPUT A WORD TO THE LOW SEGMENT */
      DECLARE W  FIXED, LOC FIXED;
      IF (DPTR+DCTR)>BUFFERSIZE ^ DLOC \= LOC THEN CALL FLUSH_DATA_BUFFER;
      IF DPTR+DCTR = 1 THEN
         DO;
            DATA_BUFFER(0) = "(3)200000000000";
            DATA_BUFFER(1) = LOC;
            DATA_BUFFER(2) = W;
            DLOC = LOC + 1;
            DCTR = DCTR + 2;
            RETURN;
         END;
      DATA_BUFFER (DPTR+DCTR) = W;
      DCTR = DCTR +1;
      DLOC = DLOC + 1;
      IF DPTR+DCTR > BUFFERSIZE THEN CALL FLUSH_DATA_BUFFER;
      IF DCTR > 18 THEN
        DO;
            DCTR = 1;
            DPTR = DPTR + 19;
            DATA_BUFFER(DPTR) = 0;
         END;
   END OUTPUT_DATAWORD;
FLUSH_DATACARD:PROCEDURE;
      IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('B')) THEN
         DO;
            DATACARD = DATACARD ^^ '; D' ^^ DP;
            IF CONTROL(BYTE('A')) THEN OUTPUT (DATAFILE) = DATACARD;
            IF CONTROL(BYTE('B')) THEN CALL PRINTLINE (DATAMSG ^^ DATACARD,-1);
         END;
      CALL OUTPUT_DATAWORD (PWORD,DP);
      PWORD = 0;
      DPOFFSET = 0;
      DP = DP + 1;
END FLUSH_DATACARD;
EMITBLOCK:
   PROCEDURE (I);
      /* RESERVE A BLOCK OF I WORDS */
      DECLARE I FIXED;
      IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('B')) THEN
         DO;
            DATACARD = '       REPEAT ' ^^ I ^^ ',<0>; D' ^^ DP;
            IF CONTROL(BYTE('A')) THEN OUTPUT (DATAFILE) = DATACARD;
            IF CONTROL(BYTE('B')) THEN CALL PRINTLINE (DATAMSG ^^ DATACARD,-1);
         END;
      DP = DP + I;
END EMITBLOCK;
EMITDATAWORD:
   PROCEDURE (W);
      DECLARE W FIXED;
      /* SEND AN 80 CHARACTER CARD TO THE DATA FILE */
      IF DPOFFSET > 0 THEN CALL FLUSH_DATACARD;
      IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('B')) THEN
         DO;
            DATACARD = X7 ^^ W ^^ '; D' ^^ DP;
            IF CONTROL(BYTE('A')) THEN OUTPUT (DATAFILE) = DATACARD;
            IF CONTROL(BYTE('B')) THEN CALL PRINTLINE (DATAMSG ^^ DATACARD,-1);
         END;
      CALL OUTPUT_DATAWORD(W,DP);
      DP = DP + 1;
END EMITDATAWORD;
EMITBYTE:
   PROCEDURE (C);
      DECLARE C FIXED;
      /* SEND ONE 9-BIT BYTE TO THE DATA AREA */
      IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('B')) THEN
         IF DPOFFSET = 0 THEN DATACARD = '       BYTE (9)'^^ C;
         ELSE DATACARD = DATACARD ^^ ',' ^^ C;
      PWORD = PWORD + SHL(C&"(3)777",9*(3-DPOFFSET));
      DPOFFSET = DPOFFSET + 1;
      IF DPOFFSET = 4 THEN CALL FLUSH_DATACARD;
END EMITBYTE;
EMITCONSTANT:
   PROCEDURE (C);
      DECLARE C FIXED;
      DECLARE CTAB (100) FIXED, CADD (100) FIXED, NC FIXED, I FIXED;
      /* SEE IF C HAS ALREADY BEEN EMITED, AND IF NOT, EMIT IT.  SET UP ADR.  */
      DO I = 1 TO NC;                  /* STEP THRU THE CONSTANTS */
         IF CTAB (I) = C THEN
            DO;
               ADR = CADD (I);
               RETURN;
            END;
      END;
      CTAB (I) = C;
      CALL EMITDATAWORD (C);
      ADR, CADD (I) = DP - 1;
      IF I < 100 THEN NC = I;
      IF CONTROL(BYTE('C')) THEN CALL PRINTLINE ('* CONSTANT ' ^^ NC ^^ ' = ' ^^ C,-1);
         ELSE IF CONTROL(BYTE('L')) THEN INFO=INFO^^ ' C'^^ NC ^^' = ' ^^ C;
END EMITCONSTANT;
EMITCODEWORD:PROCEDURE (W,WORD,RBITS);
       DECLARE W CHARACTER;
      DECLARE WORD FIXED;
      DECLARE RBITS FIXED;
      /* SEND AN 80 CHARACTER CODE CARD TO THE BUFFER AREA */
      CODE_HEAD = (CODE_HEAD+1) & 3;
      IF CODE_HEAD = CODE_TAIL THEN CALL OUTPUT_CODEWORD;
      IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('E')) THEN
            CODE(CODE_HEAD) = LABEL_GEN ^^ W;
      IF CONTROL(BYTE('E')) THEN
            CALL PRINTLINE (CODEMSG ^^ CODE(CODE_HEAD),-1);
      CODE_REL(CODE_HEAD) = WORD;
      CODE_PP(CODE_HEAD) = PP;
      CODE_RBITS(CODE_HEAD) = RBITS;
      CODE_FULL(CODE_HEAD) = TRUE;
      LABEL_GEN = '';
      STILLCOND, STILLINZERO = 0;
      PP = PP + 1;
END EMITCODEWORD;
OUTPUTLABEL:
   PROCEDURE (J);
   DECLARE J FIXED;
   LABEL_COUNT = LABEL_COUNT+1;
   LABEL_BUFFER(0) = SHL(3,36-LABEL_COUNT*2)^LABEL_BUFFER(0);
   LABEL_BUFFER(LABEL_COUNT) = J;
   IF(LABEL_COUNT >= BUFFERSIZE) THEN CALL FLUSH_LABELS;
   END OUTPUTLABEL;
EMITLABEL:PROCEDURE(L,R);
      DECLARE L FIXED;
      DECLARE R FIXED;
      DECLARE I FIXED;
      DECLARE J FIXED;
      IF R = 3 THEN
         DO;
            IF DESCREF(L) = 0 THEN RETURN;
            J = SHL(DESCREF(L),18) + DP;
            CALL OUTPUTLABEL(J);
            DESCREF(L) = 0;
            RETURN;
         END;
      STILLINZERO = 0;    /* DON'T TRY OPTIMIZING OVER LABEL */
      J = SHL(R,18) + L;
      DO I = 1 TO FOR_COUNT;
         IF J = FOR_LABEL(I) THEN
            DO;
               J = SHL(FOR_REF(I)+"(3)400000",18);
               IF R = 4 THEN J = J + PP + "(3)400000";
                        ELSE J = J + DP;
               CALL OUTPUTLABEL(J);
               J = I;
               DO WHILE J < FOR_COUNT;
                  FOR_LABEL(J) = FOR_LABEL(J+1);
                  FOR_REF(J) = FOR_REF(J+1);
                  J = J + 1;
               END;
               FOR_LABEL(FOR_COUNT) = 0;
               FOR_REF(FOR_COUNT) = 0;
               FOR_COUNT = FOR_COUNT -1;
               /* PUT A LABEL ON THE NEXT INSTRUCTION GENERATED */
               IF R = 4 & (CONTROL(BYTE('A')) ^ CONTROL(BYTE('E'))) THEN
                            LABEL_GEN = LABEL_GEN ^^ '$' ^^ L ^^ ':';
               RETURN;
            END;
      END;
      IF R = 4 & (CONTROL(BYTE('A')) ^ CONTROL(BYTE('E'))) THEN
          LABEL_GEN = LABEL_GEN ^^ '$' ^^ L ^^ ':';
      RETURN;
END EMITLABEL;
REFCHECK:
   PROCEDURE (I);
      /* CHECK TO SEE IF THIS SATISFIES ANY FORWARD REFERENCES.
         IF SO, SET UP LABEL BUFFER.  IF NOT, CHECK IF THIS
         SHOULD BE CHAINED. */
      DECLARE I FIXED;
      DECLARE J FIXED;
      IF SHR(I,18) = 3 THEN
         DO;
            I = I & "(3)777777";
            J = DESCREF(I);
            DESCREF(I) = PP + "(3)400000";
            RETURN J;
         END;
      J = 1;
      DO WHILE J <= FOR_COUNT;
         IF FOR_LABEL(J) = I THEN
            DO;
               I = FOR_REF(J) + "(3)400000";
               FOR_REF(J) = PP;
               RETURN I;
            END;
         J=J+1;
      END;
      FOR_COUNT = FOR_COUNT +1;
      IF FOR_COUNT > FOR_MAX THEN CALL ERROR ('TOO MANY FORWARD REFERENCES',3);
      FOR_REF(FOR_COUNT) = PP;
      FOR_LABEL(FOR_COUNT) = I;
      RETURN 0;
   END REFCHECK;
EMITINST:PROCEDURE (OPCODE,TREG,INDIRECT,OPERAND,IREG,RELOCATION);
      DECLARE OPCODE FIXED,
              TREG FIXED,
              INDIRECT FIXED,
              OPERAND FIXED,
              IREG FIXED,
              RELOCATION FIXED;
      DECLARE RBITS FIXED,
              WORD FIXED;
      /* EMIT A 80 CHARACTER INSTRUCTION IMAGE */
      DECLARE RELOC (5) CHARACTER
              INITIAL ('', 'D+', 'P+', 'S+', '$', '$');
      DECLARE I FIXED,
              J FIXED,
              CARD CHARACTER,
              INDIR (1) CHARACTER INITIAL ('', '@');
      COUNT_INST = COUNT_INST + 1;

      WORD = SHL(OPCODE,27) + SHL(TREG&"F",23) + SHL(INDIRECT&1,22)
             + SHL(IREG&"F",18);
      DO CASE RELOCATION;
         /* CASE 0 : ABSOLUTE ADDRESS - NO RELOCATION */
         DO;
            WORD = WORD + (OPERAND&"(3)777777");
            RBITS = 0;
         END;

         /* CASE 1 : RELATIVE TO THE BEGINNING OF DATA SEGMENT */
         DO;
            WORD = WORD + (OPERAND&"(3)777777");
            RBITS = 1;
         END;

         /* CASE 2 : RELATIVE TO BEGINNING OF CODE SEGMENT */
         DO;
            WORD = WORD + (OPERAND&"(3)777777") + "(3)400000";
            RBITS = 1;
         END;

         /* CASE 3 : RELATIVE TO BEGINNING OF STRINGS */
         DO;
            I = SHL(RELOCATION,18) + (OPERAND&"(3)777777");
            J = REFCHECK(I);
            WORD = WORD + J;
            IF J = 0 THEN RBITS = 0;
                     ELSE RBITS = 1;
         END;

         /* CASE 4 : FORWARD LABEL REFERENCE IN CODE AREA */
         DO;
            J = REFCHECK("(3)4000000" + (OPERAND&"(3)777777"));
            WORD = WORD + J;
            IF J = 0 THEN RBITS = 0;
                     ELSE RBITS = 1;
         END;

         /* CASE 5 : FORWARD LABEL REFERENCE IN DATA AREA */
         DO;
            J = REFCHECK("(3)5000000" + (OPERAND&"(3)777777"));
            WORD = WORD + J;
            IF J = 0 THEN RBITS = 0;
                     ELSE RBITS = 1;
         END;
      END;  /* END OF DO CASE RELOCATION */

      IF CONTROL(BYTE('A')) ^ CONTROL(BYTE('E')) THEN
         DO;
            I = SHR(OPCODE,5);
            CARD = X7 ^^ SUBSTR(OPNAME(I),(OPCODE-I*32)*6,6) ^^ X1 ^^TREG ^^ ','
                   ^^ INDIR(INDIRECT) ^^ RELOC(RELOCATION) ^^ OPERAND;
            IF IREG > 0 THEN CARD = CARD ^^ '(' ^^ IREG ^^ ')';
            CARD = CARD ^^ '; P' ^^ PP;
         END;
      INSTRUCT(OPCODE) = INSTRUCT(OPCODE) + 1;
      CALL EMITCODEWORD (CARD,WORD,RBITS);
END EMITINST;
EMITDESC:PROCEDURE (L,A);
      DECLARE L FIXED,
              A FIXED;
      /* SEND A LENGTH AND STRING ADDRESS TO THE DESCRIPTOR AREA */
      IF DSP > DESCLIMIT THEN
         DO;
            CALL ERROR ('TOO MANY STRINGS',1);
            DSP = 0;
         END;
       IF CONTROL(BYTE('B')) THEN
         CALL PRINTLINE (X70 ^^ 'DESC =        ' ^^ L ^^ ',' ^^ A ^^ '; S' ^^ DSP,-1);
      DESCL(DSP) = L;
      DESCA(DSP) = A;
      DSP = DSP + 1;
END EMITDESC;
FINDLABEL:PROCEDURE;
      LABEL_SINK = LABEL_SINK + 1;
      RETURN (LABEL_SINK);
END FINDLABEL;
 /*
           S Y M B O L   T A B L E   P R O C E D U R E S
 */

HASHER:
   PROCEDURE (ID);          /* CALCULATE HASH INDEX INTO HASH TABLE*/
   DECLARE ID   CHARACTER;
   DECLARE L    FIXED;
   L = LENGTH (ID);
   RETURN (BYTE (ID) + BYTE (ID, L-1) + SHL (L,4)) & "FF";
   END HASHER;

ENTER:PROCEDURE (N, T, L, S);
      DECLARE T FIXED, L FIXED, S FIXED;
      DECLARE N CHARACTER;
 /* ENTER THE NAME N IN THE SYMBOL TABLE WITH TYPE T AT LOCATION L SEGMENT S */
      DECLARE I FIXED, K FIXED;
      IDX = HASHER (N);
      I = HASH (IDX);
      DO WHILE I >= PROCMARK;
         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
                        CALL PRINTLINE (X70 ^^ 'FIXED REFERENCES TO: ' ^^ N,-1);
                     IF K = FORWARDTYPE THEN
                        DO;
                           CALL EMITLABEL(SYTLOC(I),4);
                           SYTLOC(I) = L;
                           SYTSEG(I) = S;
                        END;
                     SYTYPE (I) = T;
                  END;
               ELSE IF PROCMARK + PARCT < I THEN
                  CALL ERROR ('DUPLICATE DECLARATION FOR: ' ^^ N, 0);
               RETURN I;
            END;
         I = PTR (I);
      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;
      SYTYPE (NDECSY) = T;
      SYTLOC (NDECSY) = L;
      SYTSEG (NDECSY) = S;
      SYTCO (NDECSY) = 0;
      SYTCARD (NDECSY) = CARD_COUNT;
      PTR (NDECSY) = HASH (IDX);
      HASH (IDX) = NDECSY;
      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, AND 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) = SYTLOC (I);    /* BUILTIN FUNCTION */
               ELSE
                  FIXV (P) = 0;
               INX (P) = 0;       /* LOCATION OF INDEX */
               REG(P) = 0;
               SYTCO (I) = SYTCO (I) + 1;
               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);
      FIXL (P) = ENTER (VAR (P), FIXEDTYPE, DP-1, 1);
      CNT (P) = 0;
      FIXV (P) = 0;
      INX (P) = 0;
      SYTCO (NDECSY) = 1;            /* COUNT FIRST REFERENCE */
      SYTCARD (NDECSY) = -1;         /* FLAG UNDECLARED IDENTIFIER */
      TYPE (P) = VARIABLE;
END UNDECLARED_ID;
 /*
        A R I T H E M E T I C   P R O C E D U R E S
 */
CLEARARS:
   PROCEDURE;
      /* FREE ALL THE TEMPROARY ARITHEMETIC REGISTERS */
      DO I = 0 TO 11;
         ACC(I) = AVAIL;
      END;
END CLEARARS;
FINDAR:
   PROCEDURE;
       DECLARE I FIXED;
      /* GET A TEMPORARY ARITHEMETIC REGISTER */
      IF TARGET_REGISTER > -1 THEN
         IF ACC (TARGET_REGISTER) = AVAIL THEN
            DO;
               ACC (TARGET_REGISTER) = BUSY;
               RETURN TARGET_REGISTER;
            END;
      DO I = 1 TO 11;
         IF ACC(I) = AVAIL THEN
            DO;
               ACC(I) = BUSY;
               RETURN (I);
            END;
      END;
      CALL ERROR ('USED ALL ACCUMULATORS', 0);
      RETURN (0);
END FINDAR;
MOVESTACKS:
   PROCEDURE (F, T);
      DECLARE F FIXED, T FIXED;
      /* MOVE ALL COMPILER STACKS DOWN FROM F TO T */
      TYPE (T) = TYPE (F);
      REG (T) = REG (F);
      CNT (T) = CNT (F);
      VAR (T) = VAR (F);
      FIXL (T) = FIXL (F);
      FIXV (T) = FIXV (F);
      INX (T) = INX (F);
      PPSAVE (T) = PPSAVE (F);
END MOVESTACKS;
FORCEADDRESS:
   PROCEDURE(SP);
      /* GENERATES THE ADDRESS OF <VARIABLE> IN THE ANALYSIS STACK
         AT SP.
      */
      DECLARE SP FIXED, J FIXED, R FIXED;
      R = FINDAR;
      J = FIXL(SP);
      CALL EMITINST (MOVEI,R,0,SYTLOC(J),0,SYTSEG(J));
      REG(J) = R;
END FORCEADDRESS;
SETINIT:
   PROCEDURE;
      /* PLACES INITIAL VALUES INTO DATA AREA */
      DECLARE TMIIIL CHARACTER INITIAL ('TOO MANY ITEMS IN INITIAL LIST');
      IF ITYPE = CHRTYPE THEN
         DO;
            IF DSP < NEWDSP THEN
               DO;
                  IF TYPE (MPP1) \= CHRTYPE THEN S = FIXV (MPP1);
                  ELSE S = VAR (MPP1);     /* THE STRING */
                  I = LENGTH (S);
                  IF I = 0 THEN
                     CALL EMITDESC (0,0);
                  ELSE
                     DO;
                        CALL EMITDESC (I, DPOFFSET+SHL(DP,2));
                        DO J = 0 TO I - 1;
                           CALL EMITBYTE (BYTE (S, J));
                        END;
                      END;
               END;
            ELSE CALL ERROR (TMIIIL,0);
         END;
      ELSE
         IF TYPE (MPP1) \= CONSTANT THEN
            CALL ERROR ('ILLEGAL CONSTANT IN INITIAL LIST',0);
         ELSE
            IF ITYPE = FIXEDTYPE THEN
               DO;
               IF DP < NEWDP THEN CALL EMITDATAWORD (FIXV(MPP1));
               ELSE CALL ERROR (TMIIIL,0);
               END;
            ELSE   /* MUST BE BYTETYPE */
               IF DP < NEWDP ^ (DP = NEWDP & DPOFFSET < NEWDPOFFSET) THEN
                  CALL EMITBYTE(FIXV(MPP1));
               ELSE CALL ERROR (TMIIIL,0);
END SETINIT;
SAVE_ACS:
   PROCEDURE (N);
      /* GENERATE CODE TO SAVE BUSY ACS, UP TO AC-N */
      DECLARE N FIXED;
      DECLARE I FIXED;
      DO I = 1 TO N;
         IF (ACC(I) = BUSY) THEN CALL EMITINST (PUSH,15,0,I,0,0);
      END;
END SAVE_ACS;
RESTORE_ACS:
   PROCEDURE (N);
      /* GENERATE CODE TO RESTORE BUSY ACS, UP TO AC-N  */
      DECLARE N FIXED;
      DECLARE I FIXED, J FIXED;
      DO I = 1 TO N;
         J = N - I + 1;
         IF (ACC(J) = BUSY) THEN CALL EMITINST (POP,15,0,J,0,0);
      END;
END RESTORE_ACS;
PROC_START:
   PROCEDURE;
      /* GENERATES CODE FOR THE HEAD OF A PROCEDURE */
      PPSAVE(MP) = FINDLABEL;           /* SOMETHING TO GOTO */
      CALL EMITINST (JRST,0,0,PPSAVE(MP),0,4); /* GO AROUND PROC */
      IF SYTSEG(FIXL(MP)) = 4 THEN CALL EMITLABEL(SYTLOC(FIXL(MP)),4);
      SYTSEG(FIXL(MP)) = 2;
      SYTLOC(FIXL(MP)) = PP;            /* ADDR OF PROC */
END PROC_START;
TDECLARE:
   PROCEDURE (DIM);
   /* ALLOCATES STORAGE FOR IDENTIFIERS IN DECLARATION */
      DECLARE DIM FIXED;
      DECLARE I   FIXED;
   ALLOCATE:
      PROCEDURE (P, DIM);
         /* ALLOCATES STORAGE FOR THE IDENTIFIER AT P IN THE ANALYSIS
            STACK WITH DIMENSION DIM
         */
         DECLARE P FIXED, DIM FIXED, J FIXED, K FIXED;
         DIM = DIM + 1;                    /* ACTUAL NUMBER OF ITEMS */
         DO CASE TYPE (P);
            ;    /*  CASE 0 -- DUMMY */
            ;    /*  CASE 1 -- LABEL TYPE */
            ;    /*  CASE 2 -- ACCUMULATOR */
            ;    /*  CASE 3 -- VARIABLE */
            ;    /*  CASE 4 -- CONSTANT */
            ;    /*  CASE 5 -- CONDITION */
            DO;   /* CASE 6 -- CHRTYPE */
               J = DSP; K = 3;
               NEWDSP = DSP + DIM;
            END;
            DO;  /*  CASE 7 -- FIXEDTYPE */
               IF DPOFFSET > 0 THEN
                  DO;
                     CALL FLUSH_DATACARD;
                     OLDDP = DP;
                     OLDDPOFFSET = 0;
                  END;
               J = DP; K = 1;
               NEWDP = DP + DIM; NEWDPOFFSET = 0;
            END;
            DO;  /*  CASE 8 -- BYTETYPE */
               IF DPOFFSET > 0 THEN
                  IF I = 1 THEN 
                     DO;
                        CALL FLUSH_DATACARD;
                        OLDDP = DP; OLDDPOFFSET = 0;
                     END;
                  ELSE
                     DO;
                        DP = DP + 1; DPOFFSET = 0;
                     END;
               NEWDPOFFSET = DIM MOD 4;
               NEWDP = DP + DIM/4;
               J = DP; K = 1;
            END;
            DO;  /*  CASE 9 -- FORWARDTYPE */
               J = FINDLABEL; K = 4;
               NEWDP = DP; NEWDPOFFSET = DPOFFSET; /* COPY OLD POINTERS  */
            END;
            ;    /*  CASE 10 -- DESCRIPT */
            ;    /*  CASE 11 -- SPECIAL */
            ;    /*  CASE 12 -- FORWARDCALL */
            ;    /*  CASE 13 -- PROCTYPE */
            ;    /*  CASE 14 -- CHARPROCTYPE */
         END; /* CASE ON TYPE (P) */
         SYTYPE (FIXL(P)) = TYPE (P);
         SYTLOC (FIXL (P)) = J;
         SYTSEG (FIXL (P)) = K;
   END ALLOCATE;

      OLDDP = DP;
      OLDDSP = DSP;
      OLDDPOFFSET = DPOFFSET;
      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);
         DP = NEWDP;
         DSP = NEWDSP;
         DPOFFSET = NEWDPOFFSET;
         END;
      DP = OLDDP;
      DSP = OLDDSP;
      DPOFFSET = OLDDPOFFSET;
END TDECLARE;
CHECK_STRING_OVERFLOW:
   PROCEDURE;
      /* GENERATE A CHECK TO SEE IF COMPACTIFY NEEDS TO BE CALLED */
      CALL EMITINST (PUSHJ,15,0,STRING_CHECK,0,2);
END CHECK_STRING_OVERFLOW;
CALLSUB:PROCEDURE (SL,F,P);
      /* GENERATES CODE TO CALL A FUNCTION OR PROCEDURE AT SL
         ALSO DOES HOUSEKEEPING FOR RETURN VALUES
      */
      DECLARE SL FIXED, F FIXED, P FIXED;
      CALL SAVE_ACS (11);
      CALL EMITINST (PUSHJ,15,0,SL,0,SYTSEG(FIXL(P)));
      CALL RESTORE_ACS (11);
      IF F = 1 THEN
         DO;  /* MOVE RETURNED VALUE FROM REGISTER ZERO */
            I = FINDAR;
            IF I \= 0 THEN CALL EMITINST (MOVE,I,0,0,0,0);
            TYPE(P) = ACCUMULATOR;
            REG(P) = I;
            ACC(I) = BUSY;
            STILLINZERO = I;
         END;
END CALLSUB;
BACKUP:
   PROCEDURE;
         CODE_FULL(CODE_HEAD) = FALSE;
         CODE_HEAD = (CODE_HEAD-1) & 3;
         INSTRUCT(MOVE) = INSTRUCT(MOVE) -1;
         PP = PP - 1;
         STILLINZERO = 0;
         IF CONTROL(BYTE('E')) THEN
            CALL PRINTLINE (BACKMSG,-1);
   END BACKUP;
DELETE_MOVE:
   PROCEDURE (P,OP,AC,IND,OPERAND,INDEX,RELOC);
   /*  CHECK STILLINZERO FLAG TO SEE IF THE DATUM ABOUT TO
        BE MOVED IS STILL IN REGISTER ZERO.  IF SO, THEN DELETE 
        THE LAST INSTRUCTION GENERATED (IF A "MOVE"),
        AND MOVE IT DIRECTLY FROM 0 TO THE DESRIED DEST.
        THIS IS DESIGNED TO ELIMINATE MOST EXTRA MOVES
        OF FUNCTION RESULTS. */
      DECLARE P FIXED;
      DECLARE OP FIXED, AC FIXED, IND FIXED, OPERAND FIXED,
           INDEX FIXED, RELOC FIXED;
      IF STILLINZERO \= 0 THEN
         DO;
            IF OP = MOVEM & STILLINZERO = AC THEN
               DO;
                  CALL BACKUP;
                  ACC(REG(P)) = AVAIL;
                  REG(P) = 0;
                  AC = 0;
               END;
            ELSE IF OP = MOVE  & STILLINZERO = OPERAND
                               & (IND + INDEX + RELOC) = 0 THEN
               DO;
                  CALL BACKUP;
                  ACC(REG(P)) = AVAIL;
                  REG(P) = 0;
                  OPERAND = 0;
               END;
         END;
      CALL EMITINST (OP,AC,IND,OPERAND,INDEX,RELOC);
   END DELETE_MOVE;
EMIT_INLINE:
   PROCEDURE (FLAG);
   /* GENERATE AN ARBITRARY INSTRUCTION SPECIFIED BY PROGRAMMER */
      DECLARE FLAG BIT(1);
      DECLARE FL FIXED;
      DECLARE INST(5) FIXED;
      DECLARE BINLM CHARACTER INITIAL ('IMPROPER ARGUMENT TO INLINE');
      IF CNT(MP) < 5 THEN
         DO;
            IF TYPE(MPP1) = CONSTANT THEN INST(CNT(MP)-1) = FIXV(MPP1);
            ELSE CALL ERROR (BINLM,1);
            IF FLAG THEN CALL ERROR (BINLM,1);
         END;
      ELSE IF CNT(MP) = 5 THEN
         DO;
            IF TYPE(MPP1) = CONSTANT THEN
               DO;
                  INST(4) = FIXV(MPP1);
                  INST(5) = 0;
               END;
            ELSE IF TYPE(MPP1) = VARIABLE THEN
               DO;
                  FL = FIXL(MPP1);
                  INST(4) = SYTLOC(FL);
                  INST(5) = SYTSEG(FL);
               END;
            ELSE CALL ERROR (BINLM,1);
            CALL EMITINST (INST(0),INST(1),INST(2),INST(4),INST(3),INST(5));
            REG(MP) = INST(1);
            TYPE(MP) = ACCUMULATOR;
         END;
      ELSE CALL ERROR (BINLM,1);  /* TOO MANY ARGS TO INLINE */
   END EMIT_INLINE;
LIBRARY_CALL:   PROCEDURE (RESULT, CODE, MP, SP);
   /*
   GENERATE THE CODE FOR A CALL TO THE RUN-TIME ROUTINES.
   */
   DECLARE RESULT FIXED,   /* 0 = L.H.S. OF = */
           CODE FIXED,     /* CODE FOR RUN-TIME ROUTINE*/
           MP   FIXED,     /* STACK POINTER */
           SP   FIXED;     /* TOP OF STACK POINTER */
   DECLARE R    FIXED;

   IF RESULT = 0 THEN
      DO;
         IF STILLINZERO = REG(SP) THEN
            DO;
               CALL BACKUP;
               ACC(REG(SP)) = AVAIL;
               REG(SP) = 0;
            END;
         R = REG(SP);
      END;
   ELSE
      R = FINDAR;
   IF CNT(MP) > 0 THEN CALL EMITINST (CODE+1,R,0,0,REG(MP),0);
                  ELSE CALL EMITINST (CODE+1,R,0,0,0,0);
   IF RESULT \= 0 THEN
      DO;
         REG(MP) = R;
         TYPE(MP) = RESULT;
      END;
   END LIBRARY_CALL;
MONITOR_CALL:   PROCEDURE (CODE, P, JOBFLG);
   /*
   ROUTINE TO GENERATE CODE FOR PDP-10 CALLI UUO.
   */
   DECLARE CODE  FIXED,    /* CALLI NUMBER */
          JOBFLG FIXED,  /* CLEAR AC FLAG */
           P     FIXED;    /* STACK POINTER*/
   DECLARE R     FIXED;    /* CONTAINS REGISTER TO USE */

   R = FINDAR;
   IF JOBFLG THEN CALL EMITINST (MOVEI,R,0,0,0,0);
   CALL EMITINST (CALLI,R,0,CODE,0,0);
   REG(P) = R;
   TYPE(P) = ACCUMULATOR;
END MONITOR_CALL;
FORCEACCUMULATOR:PROCEDURE (P);
      DECLARE P FIXED;
      /* FORCE THE OPERAND AT P INTO AN ACCUMULATOR */
      DECLARE SL FIXED, TP FIXED, SFP FIXED, SS FIXED;
      DECLARE T1 CHARACTER;
      DECLARE R FIXED;
      COUNT_FORCE = COUNT_FORCE + 1;
      TP = TYPE(P);
      IF TP = VARIABLE THEN
          DO;
            SL = SYTLOC(FIXL(P));
            SS = SYTSEG(FIXL(P));
            SFP = SYTYPE(FIXL(P));
            IF SFP = PROCTYPE ^ SFP = FORWARDCALL ^ SFP = CHARPROCTYPE THEN
               DO;
                  CALL CALLSUB (SL,CALLTYPE,P);
                  R = FIXL(P)+CNT(P)+1;
                  IF LENGTH(SYT(R)) = 0 THEN
                     IF R <= NDECSY THEN
                        CALL PRINTLINE ('** WARNING--NOT ALL PARAMETERS SUPPLIED.',-1);
                  IF SFP = CHARPROCTYPE THEN TYPE(P) = DESCRIPT;
               END;
            ELSE IF SFP = SPECIAL THEN
               DO;
                  IF SL = 6 THEN
                     DO;  /* BUILTIN FUNCTION INPUT */
                        CALL CHECK_STRING_OVERFLOW;
                        CALL EMITINST (MOVE,13,0,TSA,0,1);
                        CALL LIBRARY_CALL (DESCRIPT,1,P,0);
                        CALL EMITINST (MOVEM,13,0,TSA,0,1);
                        CALL EMITINST (MOVEM,12,0,STR,0,3);
                     END;
                  ELSE IF SL = 8 THEN
                     DO;  /* BUILT-IN FUNCTION FILE */
                      IF CNT(P) \= 1 THEN CALL ERROR (FILEMSG,0);
                         ELSE CALL LIBRARY_CALL (ACCUMULATOR,5,P,0);
                     END;
                  ELSE IF SL = 12 THEN
                     DO;  /* EXIT */
                        CALL EMITINST (4,0,0,0,0,0);
                     END;
                  ELSE IF SL = 13 THEN CALL MONITOR_CALL (19,P,0);
                  ELSE IF SL = 14 THEN CALL MONITOR_CALL (12,P,0);
                  ELSE IF SL = 19 THEN CALL MONITOR_CALL (23,P,1);
                  ELSE CALL ERROR ('ILLEGAL USE OF ' ^^ SYT(FIXL(P)),0);
               END;
            ELSE
               DO;  /* FETCH THE VARIABLE (ALL ELSE HAS FAILED) */
                  IF SFP \= BYTETYPE THEN
                     DO;   /* WE DON'T HAVE TO DO CRAZY ADDRESSING */
                        R = FINDAR;     /* GET REG FOR RESULT */
                        CALL EMITINST (MOVE,R,0,SL,INX(P),SS);
                     END;
                  ELSE
                     DO;  /* BYTE ADDRESSING */
                        IF INX(P) \= 0 THEN
                           DO; /* GOOD GRIEF, SUBSCRIPTING OF BYTES */
                              R = FINDAR;
                              CALL EMITINST (MOVE,12,0,INX(P),0,0);
                              CALL EMITINST (LSH,12,0,    -2,0,0);
                              CALL EMITINST (ANDI,INX(P),0,3,0,0);
                              IF (SL ^ SS) \= 0 THEN CALL EMITINST (ADDI,12,0,SL,0,SS);
                              CALL EMITINST (LDB,R,0,BYTEPTRS,INX(P),1);
                           END;
                         ELSE
                           DO; /* NON-SUBSCRIPTED BYTE */
                              R = FINDAR;
                              CALL EMITINST (MOVEI,12,0,SL,0,SS);
                              CALL EMITINST (LDB,R,0,BYTEPTRS,0,1);
                           END;
                     END;
                  IF SFP = CHRTYPE THEN TYPE(P) = DESCRIPT;
                  ELSE TYPE(P) = ACCUMULATOR;
                  REG(P) = R;
                  IF INX(P) \= 0 THEN ACC(INX(P)) = AVAIL;
               END;
         END;
      ELSE IF TP = CONSTANT THEN
         DO;  /* FETCH A CONSTANT INTO AN ACCUMULATOR */
            R = FINDAR;
            IF FIXV(P) < "20000" & FIXV(P) > - "20000" THEN
               CALL EMITINST (HRREI,R,0,FIXV(P),0,0);
            ELSE
               DO;  /* PUT DOWN A CONSTANT AND PICK IT UP */
                  CALL EMITCONSTANT (FIXV(P));
                  CALL EMITINST (MOVE,R,0,ADR,0,1);
               END;
            REG(P) = R;
            TYPE(P) = ACCUMULATOR;
         END;
      ELSE IF TP = CHRTYPE THEN
         DO;  /* FETCH A DESCRIPTOR INTO AN ACCUMULATOR */
            R = FINDAR;
            TYPE(P) = DESCRIPT;
            REG(P) = R;
            T1 = VAR(P);
            SL = LENGTH(T1);
            IF SL = 0 THEN CALL EMITINST (MOVEI,R,0,0,0,0);
            ELSE
               DO;  /* GENERATE DESCRIPTOR AND STRING, THEN PICK IT UP */
                  CALL EMITINST (MOVE,R,0,DSP,0,3);
                  CALL EMITDESC (SL,SHL(DP,2)+DPOFFSET);
                  DO SL = 0 TO SL-1;
                     CALL EMITBYTE (BYTE(T1,SL));
                  END;
               END;
         END;
      ELSE IF TP \= ACCUMULATOR THEN IF TP \= DESCRIPT THEN
               CALL ERROR ('FORCEACCUMULATOR FAILED ***',1);
END FORCEACCUMULATOR;
FORCEDESCRIPTOR:
   PROCEDURE (P);
      /* GET A DESCRIPTOR FOR THE OPERAND P */
      DECLARE P FIXED;
      CALL FORCEACCUMULATOR (P);
      IF TYPE (P) \= DESCRIPT THEN
         DO; /* USE THE NUMBER TO DECIMAL STRING CONVERSION ROUTINE */
            CALL DELETE_MOVE (P,MOVEM,REG(P),0,C,0,1);  /* SAVE AS C */
            ACC(REG(P)) = AVAIL;
            CALL SAVE_ACS (1);
            CALL EMITINST (PUSHJ,15,0,NMBRENTRY,0,2);
            CALL RESTORE_ACS (1);
            ACC(REG(P)) = BUSY;
            IF REG(P) \= 0 THEN CALL EMITINST (MOVE,REG(P),0,0,0,0);
            TYPE (P) = DESCRIPT;             /* IT IS NOW A STRING */
            STILLINZERO = REG(P);
         END;
END FORCEDESCRIPTOR;
GENSTORE:PROCEDURE (MP, SP);
      DECLARE MP FIXED, SP FIXED;
      /* GENERATE TYPE CONVERSION (IF NECESSARY) & STORAGE CODE --
         ALSO HANDLES OUTPUT ON THE LEFT OF THE REPLACEMENT OPERATOR
      */
      DECLARE SL FIXED, SFP FIXED, SS FIXED;
      COUNT_STORE = COUNT_STORE + 1;
      SL = SYTLOC(FIXL(MP));
      SS = SYTSEG(FIXL(MP));
      SFP = SYTYPE(FIXL(MP));
      IF SFP = SPECIAL THEN
         DO;
            IF SL = 7 THEN
               DO;  /* BUILTIN FUNCTION OUTPUT */
                  CALL FORCEDESCRIPTOR(SP);
                  CALL LIBRARY_CALL (0,2,MP,SP);
               END;
            ELSE IF SL = 8 THEN
               DO;   /* BUILTIN FUNCTION FILE */
                  IF CNT(MP) \= 1 THEN
                     CALL ERROR (FILEMSG,0);
                  CALL FORCEACCUMULATOR (SP);
                  CALL LIBRARY_CALL (0,6,MP,SP);
               END;
            ELSE IF SL = 20 THEN
               DO;    /* BUILT-IN FUNCTION  FILENAME */
                  CALL FORCEDESCRIPTOR(SP);
                  CALL LIBRARY_CALL (0,7,MP,SP);
               END;
            ELSE CALL ERROR ('ILLEGAL USE OF ' ^^ SYT(FIXL(MP)),0);
         END;
      ELSE
         DO;
            IF SFP = CHRTYPE THEN
               DO;
                  CALL FORCEDESCRIPTOR(SP);
                  CALL DELETE_MOVE (SP,MOVEM,REG(SP),0,SL,INX(MP),SS);
               END;
            ELSE IF TYPE(SP) = DESCRIPT ^ TYPE(SP) = CHRTYPE THEN
                 CALL ERROR ('ASSIGNMENT REQUIRES ILLEGAL TYPE CONVERSION.',0);
            ELSE
               DO;     /* FIXEDTYPE OR BYTETYPE */
                  IF SFP = FIXEDTYPE THEN
                     DO;
                     IF TYPE(SP) = CONSTANT & FIXV(SP) = 0 THEN
                        CALL EMITINST(SETZM,0,0,SL,INX(MP),SS);
                        ELSE
                           DO;
                              CALL FORCEACCUMULATOR(SP);
                              CALL DELETE_MOVE (SP,MOVEM,REG(SP),0,SL,INX(MP),SS);
                           END;
                     END;
                  ELSE
                     DO;      /* MUST BE BYTETYPE */
                        CALL FORCEACCUMULATOR(SP);
                        IF INX(MP) \= 0 THEN
                           DO;  /* GOOD GRIEF, SUBSCRIPTING */
                               CALL EMITINST (MOVE,12,0,INX(MP),0,0);
                               CALL EMITINST (LSH,12,0,    -2,0,0);
                               CALL EMITINST (ANDI,INX(MP),0,3,0,0);
                               IF (SL ^ SS) \= 0 THEN CALL EMITINST (ADDI,12,0,SL,0,SS);
                               CALL EMITINST (DPB,REG(SP),0,BYTEPTRS,INX(MP),1);
                           END;
                        ELSE
                           DO;
                               CALL EMITINST (MOVEI,12,0,SL,0,SS);
                               CALL EMITINST (DPB,REG(SP),0,BYTEPTRS,0,1);
                           END;
                     END;
               END;
         END;
      ACC(INX(MP)) = AVAIL;
      CALL MOVESTACKS (SP,MP);
END GENSTORE;
SHOULDCOMMUTE:PROCEDURE;
      IF TYPE(SP) = CONSTANT THEN RETURN (FALSE);
      IF TYPE(MP) = CONSTANT THEN RETURN (TRUE);
      IF TYPE(SP) = VARIABLE & SYTYPE(FIXL(SP)) = FIXEDTYPE THEN RETURN (FALSE);
      IF TYPE(MP) = VARIABLE & SYTYPE(FIXL(MP)) = FIXEDTYPE THEN RETURN (TRUE);
      RETURN FALSE;
END SHOULDCOMMUTE;
ARITHEMIT:PROCEDURE(OP,COMMUTATIVE);
   DECLARE OP FIXED, COMMUTATIVE FIXED, TP FIXED;
   DECLARE AWASD CHARACTER INITIAL ('ARITHMETIC WITH A STRING DESCRIPTOR');
   /* EMIT AN INSTRUCTION FOR AN INFIX OPERATOR -- CONNECT MP & SP */
   COUNT_ARITH = COUNT_ARITH + 1;
   TP = 0;
   IF COMMUTATIVE THEN
      IF SHOULDCOMMUTE THEN
         DO;
            TP = MP; MP = SP; SP = TP;
            IF OP >= CAM & OP <= CMPRHI THEN OP = COMPARESWAP(OP-CAM)+CAM;
         END;
   CALL FORCEACCUMULATOR(MP);  /* GET THE LEFT ONE INTO AN ACCUMULATOR */
   IF TYPE(MP) = DESCRIPT THEN CALL ERROR (AWASD,0);
   ELSE IF TYPE(SP) = VARIABLE & SYTYPE(FIXL(SP)) = FIXEDTYPE THEN
      DO;  /* OPERATE FROM STORAGE */
         CALL EMITINST (OP,REG(MP),0,SYTLOC(FIXL(SP)),INX(SP),SYTSEG(FIXL(SP)));
         ACC(INX(SP)) = AVAIL;
      END;
   ELSE IF TYPE(SP) = CONSTANT THEN
      DO;
         IF FIXV(SP) < "40000" & FIXV(SP) >= 0 THEN /* USE IMMEDIATE */
            DO;
               IF OP >= CAM & OP <= CMPRHI THEN OP=OP-9; /* SOB CODE ORDER */
                  CALL EMITINST(OP+1,REG(MP),0,FIXV(SP),0,0);
            END;
         ELSE
            DO;
               CALL EMITCONSTANT (FIXV(SP));
               CALL EMITINST (OP,REG(MP),0,ADR,0,1);
            END;
      END;
   ELSE
       DO;
         CALL FORCEACCUMULATOR(SP);
         IF TYPE(SP) \= ACCUMULATOR THEN CALL ERROR (AWASD,0);
         ELSE CALL EMITINST (OP,REG(MP),0,REG(SP),0,0);
         ACC(REG(SP)) = AVAIL;
      END;
   IF TP \= 0 THEN
      DO;
         SP = MP; MP = TP;
         CALL MOVESTACKS (SP,MP);
      END;
END ARITHEMIT;
BOOLBRANCH:PROCEDURE (SP,MP);
   DECLARE SP FIXED, MP FIXED, R FIXED;
   /* GENERATE A CONDITIONAL BRANCH FOR DO WHILE OR AN IF STATEMENT
      PLACE THE ADDRESS OF THIS BRANCH IN FIXL(MP)
   */
   IF STILLCOND \= 0 THEN
      DO;  /* WE HAVE NOT GENERATED CODE SINCE SETTING THE CONDITION */
         /* REMOVE THE MOVEI =1 AND MOVEI =0 AROUND THE CAM? */
         CODE_HEAD = (CODE_HEAD-2) &3; /* BACK UP PTR */
         R = (CODE_HEAD + 1) & 3;
         CODE(CODE_HEAD) = CODE(R);
         CODE_REL(CODE_HEAD) = CODE_REL(R);
         CODE_PP(CODE_HEAD) = CODE_PP(R) -1;
         CODE_RBITS(CODE_HEAD) = CODE_RBITS(R);
         CODE_FULL(R) = FALSE;
         CODE_FULL(R+1&3) = FALSE;
         PP = PP - 2;
         CODE(CODE_HEAD) = CODE(CODE_HEAD) ^^ ' P' ^^ PP-1;
         IF CONTROL(BYTE('E')) THEN
            DO;
               CALL PRINTLINE (BACKMSG,-1);
               CALL PRINTLINE (CODEMSG ^^ CODE(CODE_HEAD),-1);
            END;
         INSTRUCT(MOVEI) = INSTRUCT(MOVEI) - 2;
         ACC(REG(SP)) = AVAIL;          /* FREE CONDITION REGISTER */
         R = 4;                         /* JUMP ALWAYS */
      END;
   ELSE
      DO;
         CALL FORCEACCUMULATOR(SP);
         CALL EMITINST (ANDI,REG(SP),0,1,0,0);  /* TEST ONLY LOW ORDER BIT */
         ACC(REG(SP)) = AVAIL;          /* FREE UP VARIABLE REGISTER */
         R = 2;                         /* JUMP IF REGISTER ZERO */
      END;
   FIXL(MP) = FINDLABEL;                /* GET A NEW LABEL */
   CALL EMITINST (JUMP+R,REG(SP),0,FIXL(MP),0,4);
END BOOLBRANCH;
SETLIMIT:
   PROCEDURE;
      /* SETS DO LOOP LIMIT FOR <ITERATION CONTROL> */
      IF TYPE (MPP1) = CONSTANT THEN
         CALL EMITCONSTANT (FIXV(MPP1));
      ELSE
         DO;
            CALL FORCEACCUMULATOR (MPP1);  /* GET LOOP LIMIT */
            CALL EMITDATAWORD (0);
            ADR = DP - 1;
            CALL EMITINST(MOVEM,REG(MPP1),0,ADR,0,1); /* SAVE IT */
            ACC(REG(MPP1)) = AVAIL;
         END;
      FIXV (MP) = ADR;
 END SETLIMIT;
STUFF_PARAMETER:
   PROCEDURE;
      /* GENERATE CODE TO SEND AN ACTUAL PARAMETER TO A PROCEDURE */
      DECLARE (I,J) FIXED;
      I = FIXL (MP) + CNT (MP);  J = SYTLOC (I);
      IF LENGTH (SYT(I)) = 0 THEN
         DO;
            SYTCO (I) = SYTCO (I) + 1;  /* COUNT THE REFERENCE                */
               DO;
                  IF SYTYPE(I) = BYTETYPE THEN
                    DO;
                       CALL FORCEACCUMULATOR(MPP1);
                       CALL EMITINST (MOVEI,12,0,J,0,SYTSEG(I));
                       CALL EMITINST (DPB,REG(MPP1),0,BYTEPTRS,0,1);
                    END;
                  ELSE
                    DO;
                       IF TYPE(MPP1) = CONSTANT & FIXV(MPP1) = 0 THEN
                          DO;
                             CALL EMITINST (SETZM,0,0,J,0,SYTSEG(I));
                             RETURN;
                          END;
                       CALL FORCEACCUMULATOR (MPP1);
                       CALL DELETE_MOVE (MPP1,MOVEM,REG(MPP1),0,J,0,SYTSEG(I));
                    END;
                  ACC(REG(MPP1)) = AVAIL;
               END;
         END;
      ELSE
         CALL ERROR ('TOO MANY ACTUAL PARAMETERS', 1);
END STUFF_PARAMETER;
DIVIDE_CODE:PROCEDURE(T);
   DECLARE T FIXED, I FIXED;
   /* EMIT CODE TO PERFORM A DIVIDE (T=1) OR MOD (T=0) */
   /* FIND A FREE REGISTER PAIR FOR THE DIVIDEND */
   IF TYPE(MP) = ACCUMULATOR THEN
      DO;   /* WE MAY BE ABLE TO USE THE REGISTER TO THE RIGHT */
         I = REG(MP);
         IF ACC(I+1) = AVAIL THEN GOTO FITS;
      END;
   DO I = T TO 11;
      IF ACC(I) = AVAIL THEN IF ACC(I+1) = AVAIL THEN GOTO FIT;
   END;
   CALL ERROR ('NO FREE REGISTERS FOR DIVISION OR MOD.',0);
   RETURN;
FIT:
   TARGET_REGISTER = I;
   CALL FORCEACCUMULATOR(MP);
   TARGET_REGISTER = -1;
   IF REG(MP) \= I THEN
      DO;
         CALL EMITINST (MOVE,I,0,REG(MP),0,0);
         ACC(REG(MP)) = AVAIL;
         REG(MP) = I;
      END;
      ACC(I) = BUSY;
 FITS:
   ACC(I+1) = BUSY;
   CALL ARITHEMIT (IDIV,0);
   IF T = 0 THEN
      DO;  /* MOD, SWITCH REGISTER TO POINT TO REMAINDER */
         ACC(I) = AVAIL;                /* FREE QUOTIENT */
         REG(MP) = I+1;                 /* POINT TO REMAINDER */
      END;
   ELSE ACC(I+1) = AVAIL;               /* FREE REMAINDER */
   IF REG(MP) =12 THEN
      DO;  /* TRANSFER THE MOD REMAINDER FROM A SCRATCH REGISTER */
         I = FINDAR;
         CALL EMITINST (MOVE,I,0,REG(MP),0,0);
         ACC(REG(MP)) = AVAIL;
         REG(MP) = I;
      END;
END DIVIDE_CODE;
SHIFT_CODE:
   PROCEDURE (OP);
      DECLARE OP FIXED;
      /* GENERATE CODE FOR THE BUILTIN FUNCTIONS SHL AND SHR */
      /* OP: LEFT = 0, RIGHT = 1 */
      SP = MPP1;
      IF CNT (MP) \= 2 THEN
         CALL ERROR ('SHIFT REQUIRES TWO ARGUMENTS', 0);
      ELSE
         IF TYPE (MPP1) = CONSTANT THEN
            DO;
               IF OP = 1 THEN FIXV(MPP1) = -FIXV(MPP1);
               CALL EMITINST(LSH,REG(MP),0,FIXV(MPP1),0,0);
            END;
      ELSE
         DO;
            /* DO SHIFT WITH VARIABLE */
            CALL FORCEACCUMULATOR(MPP1);
            IF OP = 1 THEN
                  CALL EMITINST (MOVN,REG(MPP1),0,REG(MPP1),0,0);
            CALL EMITINST (LSH,REG(MP),0,0,REG(MPP1),0);
            ACC(REG(MPP1)) = AVAIL;
         END;
      TYPE(MP) = ACCUMULATOR;
END SHIFT_CODE;
STRINGCOMPARE:
   PROCEDURE;
      /* GENERATES CODE TO COMPARE THE STRINGS AT SP AND MP.
         COMPARISONS ARE DONE FIRST ON LENGTH, AND SECOND ON A
         CHARACTER BY CHARACTER COMPARISON USING THE PDP-10 COLLATING
         SEQUENCE.
      */
      CALL FORCEDESCRIPTOR (SP);
      CALL DELETE_MOVE (SP,MOVEM,REG(SP),0,B,0,3);
      ACC(REG(SP)) = AVAIL;
      CALL FORCEDESCRIPTOR (MP);
      CALL DELETE_MOVE (MP,MOVEM,REG(MP),0,A,0,3);
      CALL SAVE_ACS (5);
      CALL EMITINST (PUSHJ,15,0,STRCOMP,0,2); /* CALL STRING COMPARE */
      CALL RESTORE_ACS (5);
      CALL EMITINST (MOVEI,REG(MP),0,1,0,0);
       CALL EMITINST (SKIP+INX(MPP1),0,0,0,0,0);
      CALL EMITINST (MOVEI,REG(MP),0,0,0,0);
      TYPE(MP) = ACCUMULATOR;
      STILLCOND = INX(MPP1);
END STRINGCOMPARE;
SYMBOLDUMP:
   PROCEDURE;
      /* LIST THE SYMBOLS IN THE PROCEDURE THAT HAS JUST BEEN
         COMPILED IF TOGGLE S IS ENABLED AND L IS ENABLED.
      */
      DECLARE SUBTITLE_SAVE CHARACTER;
      DECLARE HEADING CHARACTER INITIAL ('TYPE       LOC   SEGMENT DEFINED REF COUNT');
      DECLARE SEG(4) CHARACTER INITIAL ('ABSOLUTE','    DATA',' PROGRAM',
               '  STRING','   LABEL');
      DECLARE EXCHANGES FIXED, I FIXED, LMAX FIXED,
         J FIXED, K FIXED, L FIXED, M FIXED, SYTSORT (SYTSIZE) FIXED;
      DECLARE BLANKS CHARACTER,
              TAG    CHARACTER;

   STRING_GT:
      PROCEDURE (A,B);
         /* DO AN HONEST STRING COMPARISON:
            XPL CAN BE TRUSTED ONLY IF STRINGS ARE OF THE SAME LENGTH.
            IF LENGTHS DIFFER, LET XPL SEE ONLY THE SHORTER, AND THE
            MATCHING PART OF THE LONGER, AND ARRANGE COMPARISONS SO
            THAT RESULT IS RIGHT.   */
         DECLARE A CHARACTER,
                 B CHARACTER;
         DECLARE LA FIXED,  LB FIXED;

         LA = LENGTH (A);
         LB = LENGTH (B);
         IF LA = LB THEN RETURN (A > B);
         ELSE IF LA > LB THEN RETURN (SUBSTR (A,0,LB) >= B);
              ELSE RETURN (A > SUBSTR(B,0,LA));
      END STRING_GT;

      IF CONTROL(BYTE('L'))  = 0 THEN RETURN; /* DON'T DUMP IF NOT LISTING */
      IF PROCMARK <= NDECSY THEN
         DO;
            CALL PRINTLINE ('SYMBOL TABLE DUMP',0);
            LMAX = 15;
            DO I = PROCMARK TO NDECSY;  /* PAD ALL NAMES TO THE SAME LENGTH */
               IF LENGTH (SYT (I)) > LMAX THEN
                  LMAX = LENGTH (SYT (I));
               SYTSORT (I) = I;
            END;
            IF LMAX > 70 THEN LMAX = 70;
            BLANKS = SUBSTR (X70,0,LMAX);
            EXCHANGES = TRUE;
            K = NDECSY - PROCMARK;
            DO WHILE EXCHANGES;
               EXCHANGES = FALSE;
               DO J = 0 TO K - 1;
                  I = NDECSY - J;
                  L = I - 1;
                  IF STRING_GT(SYT (SYTSORT(L)),SYT(SYTSORT(I))) THEN
                     DO;
                        M = SYTSORT (I);
                        SYTSORT (I) = SYTSORT (L);
                        SYTSORT (L) = M;
                        EXCHANGES = TRUE;
                        K = J;          /* RECORD THE LAST SWAP */
                     END;
                END;
            END;
            I = PROCMARK;
            DO WHILE LENGTH (SYT (SYTSORT (I))) = 0;
               I = I + 1;               /* IGNORE NULL NAMES */
            END;
            SUBTITLE_SAVE = SUBTITLE;
            SUBTITLE = 'SYMBOL' ^^ SUBSTR(BLANKS,0,LMAX-5) ^^ HEADING;
            CALL PRINTLINE (SUBTITLE,0);
            DO I = I TO NDECSY;
               K = SYTSORT (I);
               TAG = SYT(K) ^^ SUBSTR(X70,0,LMAX-LENGTH(SYT(K)));
               CALL I_FORMAT (SYTLOC(K),5);
               TAG = TAG ^^ X1 ^^ TYPENAME(SYTYPE(K)) ^^ X1 ^^ I_STRING;
               CALL I_FORMAT (SYTCARD(K),5);
               TAG = TAG ^^ X1 ^^ SEG(SYTSEG(K)) ^^ X2 ^^ I_STRING;
               CALL I_FORMAT (SYTCO(K),5);
               IF SYTCO(K) = 0 THEN I_STRING = I_STRING ^^ ' *';
               CALL PRINTLINE (TAG ^^ X3 ^^ I_STRING,-1);

               K = K + 1;
               DO WHILE (LENGTH (SYT (K)) = 0) & (K <= NDECSY);
                  J = K - SYTSORT (I);
                  TAG = '  PARAMETER  ' ^^ J ^^ SUBSTR(BLANKS,13) ^^
                        TYPENAME(SYTYPE(K));
                  CALL I_FORMAT (SYTLOC(K),5);
                  TAG = TAG ^^ X1 ^^ I_STRING;
                  CALL I_FORMAT (SYTCARD(K),5);
                  TAG = TAG ^^ X1 ^^ SEG(SYTSEG(K)) ^^ X2 ^^ I_STRING;
                  CALL I_FORMAT (SYTCO(K),5);
                  CALL PRINTLINE (TAG ^^ X3 ^^ I_STRING,-1);
                  K = K + 1;
               END;
            END;
            SUBTITLE = SUBTITLE_SAVE;
         END;
         EJECT_PAGE;
END SYMBOLDUMP;
DUMPIT:
   PROCEDURE;
      DECLARE CHAR360 CHARACTER;
      DECLARE T1 CHARACTER, T2 CHARACTER, L FIXED, LL FIXED;
      /* PUT OUT STATISTICS KEPT WITHIN THE COMPILER */
     IF TOP_MACRO >= 0 THEN
          DO; /* DUMP MACRO DICTIONARY */
             CALL PRINTLINE ( 'MACRO DEFINITIONS:',0);
             CALL PRINTLINE (X1,-1);
             L = LENGTH (MACRO_NAME(TOP_MACRO));
             IF L > 70 THEN L = 70;
             SUBTITLE = 'NAME' ^^ SUBSTR (X70,0,L-2) ^^
                        'AT LINE REF COUNT LITERAL VALUE';
             CALL PRINTLINE (SUBTITLE,-1);
             DO I = 0 TO TOP_MACRO;
                K = LENGTH (MACRO_NAME(I));
                IF K < L THEN
                   DO;
                       CHAR360 = SUBSTR (X70,0,L-K);
                       MACRO_NAME (I) = MACRO_NAME (I) ^^ CHAR360;
                   END;
                ELSE
                   MACRO_NAME(I) = SUBSTR(MACRO_NAME(I),0,L);
                T1 = MACRO_DECLARE(I);
                T2 = MACRO_COUNT(I);
                LL = LENGTH (T1);
                IF LL < 8 THEN T1 = SUBSTR(X70,0,8-LL) ^^ T1;
                LL = LENGTH (T2);
                IF LL < 9 THEN T2 = SUBSTR(X70,0,9-LL) ^^ T2;
                CALL PRINTLINE (MACRO_NAME(I) ^^ T1 ^^ T2 ^^ X4 ^^ MACRO_TEXT(I),-1);
             END;
          END;
      SUBTITLE = '';
      CALL PRINTLINE (X1,-1);
      CALL PRINTLINE ('ID COMPARES       = ' ^^ IDCOMPARES,-1);
      CALL PRINTLINE ('SYMBOL TABLE SIZE = ' ^^ MAXNDECSY,-1);
      CALL PRINTLINE ('MACRO DEFINITIONS = ' ^^ TOP_MACRO + 1,-1);
      CALL PRINTLINE ('SCAN              = ' ^^ COUNT_SCAN,-1);
      CALL PRINTLINE ('EMITINST          = ' ^^ COUNT_INST,-1);
      CALL PRINTLINE ('FORCE ACCUMULATOR = ' ^^ COUNT_FORCE,-1);
      CALL PRINTLINE ('ARITHEMIT         = ' ^^ COUNT_ARITH,-1);
      CALL PRINTLINE ('GENERATE STORE    = ' ^^ COUNT_STORE,-1);
      CALL PRINTLINE ('FREE STRING AREA  = ' ^^ FREELIMIT - FREEBASE,-1);
      CALL PRINTLINE ('COMPACTIFICATIONS = ' ^^ COUNT_COMPACT,-1);
      SUBTITLE = 'INSTRUCTION FREQUENCIES';
      EJECT_PAGE;
      DO I = 0 TO 15;
         J = I * 32;
         DO K = 0 TO 31;
            IF INSTRUCT(J+K) > 0 THEN
                CALL PRINTLINE (SUBSTR(OPNAME(I),K*6,6) ^^ X4 ^^ INSTRUCT(J+K),-1);
         END;
      END;
END DUMPIT;
   INITIALIZE:
      PROCEDURE;
      DECLARE CH CHARACTER;
      DECLARE TIME1 FIXED, HOURS FIXED, MINUTES FIXED, SECS FIXED;
      DECLARE DATE1 FIXED, DAY FIXED, YEAR FIXED, L FIXED;
      DECLARE MONTH CHARACTER;
      DECLARE MONTHS (11)CHARACTER INITIAL ('-JAN-',
            '-FEB-','-MAR-','-APR-','-MAY-','-JUN-','-JUL-','-AUG-',
            '-SEP-','-OCT-','-NOV-','-DEC-');
      OUTPUT(-2) = 'FILENAME TO BE COMPILED: ';
      CHAR_TEMP = INPUT(-1);
      SOURCE = '';
      CONTROL(BYTE('A')) = FALSE;
      CONTROL(BYTE('D')) = TRUE;
      CONTROL(BYTE('S')) = TRUE;
      DO I = 0 TO LENGTH(CHAR_TEMP)-1;
         CH =  SUBSTR(CHAR_TEMP,I,1);
         IF BYTE(CH) = BYTE('/') THEN
            DO;
               CH = SUBSTR(CHAR_TEMP,I+1,1);
               CONTROL(BYTE(CH)) = \ CONTROL(BYTE(CH));
               I = I + 1;
            END;
         ELSE
            SOURCE = SOURCE ^^ CH;
         END;
      FILENAME (0) = 'SYSIN:' ^^ SOURCE ^^ '.XPL';
      FILENAME (1) = 'SYSOUT:' ^^ SOURCE ^^ '.LST';
      IF CONTROL(BYTE('A')) THEN
         DO;
            FILENAME (DATAFILE) = SOURCE ^^ '.MAC';
            FILENAME(CODEFILE) = SOURCE ^^ '.TMP';
         END;
      FILENAME(RELFILE) = SOURCE ^^ '.REL';
      TIME1 = (TIME+500)/ 1000;
      HOURS = TIME1 /3600;
      MINUTES = (TIME1 MOD 3600) / 60;
      SECS = TIME1 MOD 60;
      DATE1 = DATE;
      DAY = DATE1 MOD 31 + 1;
      DATE1 = DATE1 / 31;
      MONTH = MONTHS(DATE1 MOD 12);
      YEAR = DATE1 / 12 + 1964;
      TITLE = '1' ^^ SOURCE ^^ '.XPL  COMPILED ' ^^ DAY ^^ MONTH ^^
             YEAR ^^ '  AT ' ^^HOURS ^^ ':' ^^ MINUTES ^^ ':' ^^ SECS
             ^^ ' BY VERSION ' ^^ VERSION;
      L = LENGTH (TITLE);
      TITLE = TITLE ^^ SUBSTR(X70,0,90-L) ^^ 'PAGE ';
      SUBTITLE = ' LINE    SOURCE STATEMENT' ^^ SUBSTR(X70,7)
            ^^ 'PROCEDURE AND COMPILER INFORMATION';
      PAGE_COUNT = 0;
      LINE_COUNT = 99;
      DO I = 1 TO TERMINAL#;
         S = VOCAB(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 = 'EOF' 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 = '^' THEN ORSYMBOL = I; ELSE
         IF S = '^^' THEN CONCATENATE = I;
      END;
      IF IDENT = TERMINAL# THEN RESERVED_LIMIT = LENGTH(VOCAB(TERMINAL#-1));
      ELSE RESERVED_LIMIT = LENGTH(VOCAB(TERMINAL#));
      STOPIT(EOFILE) = TRUE;
   DO I = TERMINAL# TO  VOCAB#;
      S = VOCAB(I);
      IF S = '<LABEL DEFINITION>' THEN LABELSET = I;
   END;
      CHARTYPE (BYTE(' ')) = 1;
      CHARTYPE (BYTE('''')) = 2;
      CHARTYPE (BYTE('"')) = 3;
      DO I = 0 TO 255;
         NOT_LETTER_OR_DIGIT(I) = TRUE;
      END;
      DO I = 0 TO 29;
         J = BYTE('ABCDEFGHIJKLMNOPQRSTUVWXYZ_$@#', I);
         NOT_LETTER_OR_DIGIT(J) = FALSE;
         CHARTYPE(J) = 4;
      END;
      DO I = 0 TO 9;
         J = BYTE('0123456789', I);
         NOT_LETTER_OR_DIGIT(J) = FALSE;
         CHARTYPE(J) = 5;
       END;
      I = 1;
      DO WHILE (LENGTH(VOCAB(I))= 1);
         J = BYTE(VOCAB(I));
         TX(J) = I;
         CHARTYPE(J) = 7;
         I = I + 1;
      END;
      CHARTYPE(BYTE('^')) = 8;
      CHARTYPE (BYTE('/')) = 6;
      PP = 0;            /* PROGRAM ORIGIN */
      DP = 0;            /* DATA ORIGIN */
      DPOFFSET = 0;
      DSP = 0;           /* DESCRIPTOR ORIGIN */
      RETURNED_TYPE = FIXEDTYPE;     /* INITIAL DEFAULT TYPE */
      TOP_MACRO = -1;
      TARGET_REGISTER = -1;

      CODEMSG = X70 ^^ CODEMSG;
      DATAMSG = X70 ^^ DATAMSG;
      BACKMSG = X70 ^^ BACKMSG;

/*    INITIALIZE THE SYMBOL TABLE AND ITS HASH TABLE */
      PROCMARK = 25; NDECSY = 27; PARCT = 0;
      DO I = 0 TO SYTSIZE;
         PTR (I) = -1;
      END;
      DO I = 0 TO "FF";
         HASH (I) = -1;
      END;
      DO I = 0 TO NDECSY;
         IDX = HASHER (SYT(I));
         PTR (I) = HASH (IDX);
         HASH (IDX) = I;
      END;
      RPTR, DPTR, DLOC,FOR_COUNT, LABEL_COUNT = 0;
      RCTR, DCTR = 1;

      FILE(RELFILE) = NAME_TYPE + 2;
      FILE(RELFILE) = 0;
      FILE(RELFILE) = RADIX50(SOURCE);
      FILE(RELFILE) = "(3)17000000" + 0;
      FILE(RELFILE) = HISEG_TYPE + 1;
      FILE(RELFILE) = "(3)200000000000" ;
      FILE(RELFILE) = "(3)400000400000";

      CODE_HEAD, CODE_TAIL = 0;
      CODE_FULL(0) = FALSE;
      IF CONTROL(BYTE('A')) THEN
         DO;
            LABEL_GEN = 'P:';                /* ORG THE CODE SEGMENT */
            OUTPUT (DATAFILE) = '       TITLE ' ^^ SOURCE ;
            OUTPUT (DATAFILE) = '       TWOSEG 400000;';
            OUTPUT (DATAFILE) = '       RELOC 0;';
            OUTPUT (DATAFILE) = '       RADIX 10;';
            OUTPUT (CODEFILE) = '       RELOC ^O400000;';
            OUTPUT (DATAFILE) = '       OPDEF   .INIT. [1B8];';
            OUTPUT (DATAFILE) = '       OPDEF   .INPT. [2B8];';
            OUTPUT (DATAFILE) = '       OPDEF   .OUTP. [3B8];';
            OUTPUT (DATAFILE) = '       OPDEF   .EXIT. [4B8];';
            OUTPUT (DATAFILE) = '       OPDEF   .FILI. [6B8];';
            OUTPUT (DATAFILE) = '       OPDEF   .FILO. [7B8];';
            OUTPUT (DATAFILE) = '       OPDEF   .NAME. [8B8];';
            OUTPUT (DATAFILE) = 'D:';
         END;
      BYTEPTRS = DP;
      CALL EMITDATAWORD ("(3)331114000000"); /*   POINT 9,0(12),8 */
      CALL EMITDATAWORD ("(3)221114000000"); /*   POINT 9,0(12),17 */
      CALL EMITDATAWORD ("(3)111114000000"); /*   POINT 9,0(12),26 */
      CALL EMITDATAWORD ("(3)001114000000"); /*   POINT 9,0(12),35 */
      PSBITS = DP;
      CALL EMITDATAWORD ("(3)331100000000"); /*   POINT 9,0,8  */
      CALL EMITDATAWORD ("(3)221100000000"); /*   POINT 9,0,17 */
      CALL EMITDATAWORD ("(3)111100000000"); /*   POINT 9,0,26 */
      CALL EMITDATAWORD ("(3)001100000000"); /*   POINT 9,0,35 */
      CALL EMITCONSTANT (1);            /* ENTER A 1 */
      TRUELOC = ADR;                    /* SAVE ITS ADDRESS */
      CALL EMITCONSTANT (0);            /* ENTER A 0 */
      FALSELOC = ADR;                   /* SAVE ITS ADDRESS */
      TSA = DP; SYTLOC(2) = DP;         /* FREEPOINT */
      CALL EMITDATAWORD (0);
      NDESC, SYTLOC(4) = FINDLABEL;     /* NDESCRIPT */
      COREBYTELOC = 1;                  /* SYT LOCATION OF COREBYTE */
      STRING_RECOVER = 25;              /* SYT LOCATION OF COMPACTIFY */
      SYTLOC(25) = FINDLABEL;           /* LABEL FOR COMPACTIFY */
      LIMITWORD = DP; SYTLOC(26) = DP;  /* FREELIMIT */
      CALL EMITDATAWORD (0);
      STR = DSP;                        /* PLACE TO SAVE LAST STRING GENERATED */
      CALL EMITDESC (0,0);
      LIBRARY_SAVE = DP;                /* PLACE TO SAVE R11 ON LIB CALLS */
      CALL EMITDATAWORD (0);
      LIBRARY = DP;                     /* ADDRESS OF LIBRARY GOES HERE */
      IF CONTROL(BYTE('A')) THEN
         DO;
            OUTPUT (DATAFILE) = '       XPLLIB;';
            OUTPUT (DATAFILE) = '       EXTERN XPLLIB;';
         END;
      DP = DP + 1;
      CALL EMITCONSTANT ("FFFFF");      /* MASK FOR ADDRESSES ONLY  */
      ADDRMASK = ADR;                   /* SAVE IT                  */
      CALL EMITCONSTANT(-134217728);  /* DV LENGTH FIELD */
      LENGTHMASK = ADR;

/* CHECK-STRING-OVERFLOW  SEE IF COMPACTIFY NEEDS TO BE CALLED */

      CALL EMITBLOCK (15);
      I = DP - 15;
      STRING_CHECK = PP;
      CALL EMITINST (MOVE,0,0,TSA,0,1); /* PICK UP TOP OF STRINGS */
      CALL EMITINST (CAMGE,0,0,LIMITWORD,0,1); /* COMPARE WITH LIMIT WORD */
      CALL EMITINST (POPJ,15,0,0,0,0);
      CALL EMITINST (MOVEI,0,0,I,0,1);
      CALL EMITINST (HRLI,0,0,1,0,0);
      CALL EMITINST (BLT,0,0,I+14,0,1);
      CALL EMITINST (PUSHJ,15,0,SYTLOC(STRING_RECOVER),0,SYTSEG(STRING_RECOVER));
      CALL EMITINST (MOVEI,0,0,1,0,0);
      CALL EMITINST (HRLI,0,0,I,0,1);
      CALL EMITINST (BLT,0,0,14,0,0);
      CALL EMITINST (POPJ,15,0,0,0,0);
      SYTCO (STRING_RECOVER) = SYTCO (STRING_RECOVER) + 1;

 /* STRING COMPARISON */

      A = DSP;
      CALL EMITDESC (0,0);
      B = DSP;
      CALL EMITDESC (0,0);
      STRCOMP = PP;
      CALL EMITINST (MOVE,0,0,A,0,3);   /* FETCH LEFT DESCRIPTOR */
      CALL EMITINST (LSH,0,0,    -27,0,0);
      CALL EMITINST (MOVE,1,0,B,0,3);    /* FETCH RIGHT DESCRIPTOR */
      CALL EMITINST (LSH,1,0,    -27,0,0);
      CALL EMITINST (SUB,0,0,1,0,0);    /* SUBTRACT THE LENGTHS */
      CALL EMITINST (JUMPE,0,0,PP+2,0,2);
      CALL EMITINST (POPJ,15,0,0,0,0);   /* RETURN W/ -, 0, OR + IF LENGTH \= */
      CALL EMITINST (MOVEI,2,0,0,0,0);  /* CLEAR A LENGTH REGISTER */
      CALL EMITINST (MOVE,3,0,A,0,3);
      CALL EMITINST (SUBI,3,0,1,0,0);
      CALL EMITINST (LSHC,2,0,  9,0,0); /* ISOLATE THE LENGTH */
      CALL EMITINST (LSHC,3,0,-11,0,0); /* ISOLATE BYTE INDEX IN R4 */
      CALL EMITINST (LSH,4,0,    -34,0,0);
      CALL EMITINST (HLL,3,0,PSBITS,4,1); /* BUILD BYTE PTR IN R3 */
      CALL EMITINST (MOVE,4,0,B,0,3);
      CALL EMITINST (SUBI,4,0,1,0,0);
      CALL EMITINST (LSHC,4,0,    -2,0,0);
      CALL EMITINST (LSH,5,0,    -34,0,0);
      CALL EMITINST (HLL,4,0,PSBITS,5,1); /* BUILD BYTE PTR IN R4 */

      /* ONE CHARACTER GOES INTO R0 WHILE THE OTHER GOES INTO R1.  LENGTH IS
         CONTROLLED IN R2 AND THE BYTE PTRS ARE IN R3 & R4 FOR SPEED.
      */
      CALL EMITINST (ILDB,0,0,3,0,0);   /* FETCH 1ST BYTE */
      CALL EMITINST (ILDB,1,0,4,0,0);   /* FETCH 2ND BYTE */
      CALL EMITINST (CAMN,0,0,1,0,0);   /* SKIP IF \= */
      CALL EMITINST (SOJG,2,0,PP-3,0,2);/* LOOP FOR ALL BYTES */
      CALL EMITINST (SUB,0,0,1,0,0);    /* SUB DIFF BYTES OR LAST TWO EQUAL */
      CALL EMITINST (POPJ,15,0,0,0,0);

 /* MOVE CHARACTER SUBROUTINE */

      MOVER = PP;
      /* USES REGISTERS 1, 2, 11, 12, & 13 */
      CALL EMITINST (SUBI,12,0,1,0,0);  /* DECR ADDR OF SOURCE */
      CALL EMITINST (MOVEI,11,0,0,0,0); /* CLEAR LENGTH REG */
      CALL EMITINST (LSHC,11,0,  9,0,0);/* ISOLATE LENGTH */
      CALL EMITINST (LSHC,12,0,-11,0,0);/* ISOLATE BYTE INDEX */
      CALL EMITINST (LSH,13,0,    -34,0,0);
      CALL EMITINST (HLL,12,0,PSBITS,13,1); /* MAKE FROM BYTEPTR */
      CALL EMITINST (MOVE,13,0,11,0,0); /* COPY LENGTH */
      CALL EMITINST (ADD,13,0,1,0,0);   /* CREATE NEW TSA */
      CALL EMITINST (SUBI,1,0,1,0,0);   /* DECR TO ADDR */
      CALL EMITINST (LSHC,1,0,    -2,0,0); /* ISOLATE BYTE INDEX */
      CALL EMITINST (LSH,2,0,    -34,0,0);
      CALL EMITINST (HLL,1,0,PSBITS,2,1);  /* TO BYTEPTR */

      /* CHARACTER GOES INTO R2, LENGTH IS IN R11, AND THE NEW TSA IS IN R13.
         BYTEPTRS ARE IN R1 & R12 FOR SPEED.
      */
      CALL EMITINST (ILDB,2,0,12,0,0);  /* FETCH A BYTE */
      CALL EMITINST (IDPB,2,0,1,0,0);   /* STORE A BYTE */
      CALL EMITINST (SOJG,11,0,PP-2,0,2);  /* LOOP FOR ALL BYTES */
      CALL EMITINST (MOVE,1,0,13,0,0);  /* RETURN WITH NEW TSA */
      CALL EMITINST (POPJ,15,0,0,0,0);

 /* CATENATION SUBROUTINE */

      CATENTRY = PP;
      CALL CHECK_STRING_OVERFLOW;       /* SQUEEZE CORE IF NECESSARY */
      CALL EMITINST (MOVE,0,0,B,0,3);   /* SEE IF LENGTH (B) = 0 */
      CALL EMITINST (AND,0,0,LENGTHMASK,0,1);
      CALL EMITINST (JUMPN,0,0,PP+3,0,2);
      CALL EMITINST (MOVE,0,0,A,0,3);   /* YES, RETURN WITH A */
      CALL EMITINST (POPJ,15,0,0,0,0);
      CALL EMITINST (MOVE,1,0,A,0,3);   /* SEE IF LENGTH(A) = 0 */
      CALL EMITINST (AND,1,0,LENGTHMASK,0,1);
      CALL EMITINST (JUMPN,1,0,PP+3,0,2);
      CALL EMITINST (MOVE,0,0,B,0,3);   /* YES, RETURN WITH B */
      CALL EMITINST (POPJ,15,0,0,0,0);

      /*  WE HAVE TO CONSTRUCT A NEW STRING.  CHECK TO SEE IF STRING 'A'
        IS ADJACENT TO THE FIRST AVAILABLE BYTE.  IF IT IS, WE NEED
        ONLY ACTUALLY MOVE STRING 'B' AND DUMMY UP A NEW DESCRIPTOR.  */

      CALL EMITINST (ROT,1,0,9,0,0);     /* PUT L(A) IN LOW END */
      CALL EMITINST (ADD,1,0,A,0,3);     /* ADD A DESC. */
      CALL EMITINST (AND,1,0,ADDRMASK,0,1); /* KEEP ONLY BYTE ADDRESS */
      CALL EMITINST (ADD,0,0,A,0,3);     /* ADD L(B) TO DESC. A */
      CALL EMITINST (MOVE,12,0,B,0,3);     /* GE DESC. B */
      CALL EMITINST (AND,12,0,ADDRMASK,0,1);/* KEEP BYTE ADDRESS */
      CALL EMITINST (CAMN,12,0,1,0,0);    /* IS THIS SAME AS END(A)+1? */
      CALL EMITINST (JRST,0,0,PP+11,0,2);  /*YES. THEN DONE */
      CALL EMITINST (CAML,1,0,TSA,0,1);  /* IS 'A' LAST STRING ? */
      CALL EMITINST (JRST,0,0,PP+6,0,2); /* YES. JUMP TO JUST MOVE B */
      CALL EMITINST (AND,0,0,LENGTHMASK,0,1); /* NO. MAKE NEW DESC. */
      CALL EMITINST (IOR,0,0,TSA,0,1);  /* NEW DOPE VECTOR */
      CALL EMITINST (MOVE,1,0,TSA,0,1); /* TARGET OF MOVE */
      CALL EMITINST (MOVE,12,0,A,0,3);  /* SOURCE OF MOVE & LENGTH */
      CALL EMITINST (PUSHJ,15,0,MOVER,0,2);   /* CALL MOVE SUBROUTINE */
      CALL EMITINST (MOVE,12,0,B,0,3);  /* SOURCE OF MOVE */
      CALL EMITINST (PUSHJ,15,0,MOVER,0,2);   /* CALL MOVE SUBROUTINE*/
      CALL EMITINST (MOVEM,1,0,TSA,0,1);/* SAVE NEW TSA */
      CALL EMITINST (MOVEM,0,0,STR,0,3);  /* SAVE LAST STRING DESCRIPTOR */
      CALL EMITINST (POPJ,15,0,0,0,0);

 /* NUMBER TO STRING CONVERSION */

      NMBRENTRY = PP;
      /* USES REGISTERS 0,1,12,13 */

      CALL EMITBLOCK (1);
      C = DP - 1;
      CALL CHECK_STRING_OVERFLOW;
      CALL EMITINST (MOVE,12,0,TSA,0,1);   /* GET LOC'N FIRST FREE BYTE*/
      CALL EMITINST (SUBI,12,0,1,0,0);    /* ADJUST FOR IDBP */
      CALL EMITINST (MOVEI,13,0,0,0,0);    /* CLEAR 13 FOR SHIFT */
      CALL EMITINST (LSHC,12,0,-2,0,0);    /* WORD ADDRESS TO 12 */
      CALL EMITINST (ROT,13,0,2,0,0);      /* DISPL. TO 13 */
      CALL EMITINST (HLL,12,0,PSBITS,13,1);/* MAKE BYTE POINTER IN 12 */
      CALL EMITINST (MOVE,0,0,C,0,1);      /* LOAD NUMBER TO BE CONVERTED */
      CALL EMITINST (MOVEI,13,0,0,0,0);    /* CLEAR COUNT OF BYTES */
      CALL EMITINST (JUMPGE,0,0,PP+5,0,2); /* JUMP AROUND SIGN IF >= 0 */
      CALL EMITINST (MOVEI,1,0,BYTE('-'),0,0);/* PUT - INTO REG. */
      CALL EMITINST (IDPB,1,0,12,0,0);     /* PUT BYTE AWAY */
      CALL EMITINST (MOVEI,13,0,1,0,0);    /* SET BYTE COUNT TO 1 */
      CALL EMITINST (MOVM,0,0,0,0,0);      /* MAKE NUMBER POSITIVE */
      CALL EMITINST (PUSHJ,15,0,PP+8,0,2); /* GENERATE BYTE STRING */
      CALL EMITINST (ROT,13,0,-9,0,0);     /* PUT BYTE COUNT IN LENGTH */
      CALL EMITINST (MOVE,0,0,TSA,0,1);    /* PICK STARTING ADDRESS OF STRING */
      CALL EMITINST (ADD,0,0,13,0,0);      /* ADD LENGTH TO MAKE DESC. */
      CALL EMITINST (ROT,13,0,9,0,0);      /* PUT COUNT BACK */
      CALL EMITINST (ADDM,13,0,TSA,0,1);   /* ADJUST TSA FOR NEXT TIME */
      CALL EMITINST (MOVEM,0,0,STR,0,3);   /* SAVE NEW DESCRIPTOR */
      CALL EMITINST (POPJ,15,0,0,0,0);     /* RETURN */

      /* SUBROUTINE TO CONVERT NUMBER TO CHAR STRING BY REPETITIVE
         DIVISION.  PUTS OUT DIGITS FROM HIGH-TO-LOW ORDER. */

      CALL EMITINST (IDIVI,0,0,10,0,0);    /* QUOTIENT TO 0, REMAINDER TO 1 */
      CALL EMITINST (HRLM,1,0,0,15,0);     /* SAVE REMAINDER ON STACK */
      CALL EMITINST (JUMPE,0,0,PP+2,0,2);  /* IF QUOTIENT = 0, ALL DIGITS */
      CALL EMITINST (PUSHJ,15,0,PP-3,0,2); /* LOOP BACK FOR NEXT DIGIT */
      CALL EMITINST (HLRZ,1,0,0,15,0);     /* RETRIEVE DIGIT FROM STACK */
      CALL EMITINST (ADDI,1,0,BYTE('0'),0,0); /* CONVERT TO ASCII CHARACTER */
      CALL EMITINST (IDPB,1,0,12,0,0);     /* STUFF BYTE OUT */
      CALL EMITINST (ADDI,13,0,1,0,0);     /* INCREMENT BYTE COUNTER */
      CALL EMITINST (POPJ,15,0,0,0,0);     /* RETURN (FOR MORE OR TO CALLER */

   /* THE COMPILED PROGRAM WILL BEGIN EXECUTION HERE.  MAKE THE FIRST JUMP
      POINT HERE, INITIALIZE THE LIBRARY, AND FALL INTO COMPILE CODE.
   */

      STARTLOC = PP;                      /* START LOCATION */
      CALL EMITLABEL (0,4);               /* ORG PROGRAM HERE */
      /* INITIALIZE LIBRARY ROUTINE, FREEBASE, FREELIMIT, & FREEPOINT */
      CALL EMITINST (JUMP,0,0,0,0,0);   /* PATCH NOP */
      CALL EMITINST (1,0,0,0,0,0);      /* INIT LIB CODE */
      CALL EMITINST (MOVEM,12,0,TSA,0,1); /* SAVE AS FREEPOINT */
      CALL EMITINST (MOVEM,12,0,DP,0,1); /* SAVE AS FREEBASE */
      SYTLOC (27) = DP;
      CALL EMITDATAWORD (0);
      CALL EMITINST (SUBI,13,0,256,0,0);
      CALL EMITINST (MOVEM,13,0,LIMITWORD,0,1); /* SAVE AS FREELIMIT */
      /* ROUTINE TO RELOCATE STRING DESCRIPTORS */
      CALL EMITINST (MOVEI,12,0,0,0,1); /* GET ADDRESS OF DATA SEGMENT */
      CALL EMITINST (LSH,12,0,  2,0,0);    /* MULTIPLY BY 4 FOR BYTE ADDRESS*/
      CALL EMITINST (MOVE,13,0,NDESC,0,5);   /* GET # DESCRIPTORS AS INDEX */
      CALL EMITINST (SKIPE,0,0,0,13,3); /* DON'T CHANGE NULL DESC.S */
      CALL EMITINST (ADDM,12,0,0,13,3); /* ADD RELOC TO A DESCRIPTOR */
      CALL EMITINST (SOJG,13,0,PP-2,0,2);    /* LOOP THRU ALL DESCRIPTORS */
      CP = 0;  TEXT = '';  TEXT_LIMIT = -1;
      COMPILING = TRUE;
      READING = CONTROL(BYTE('X'));
      IF READING THEN
          CONTROL(BYTE('L')) = \ (CONTROL(BYTE('K')) ^ CONTROL(BYTE('M'))) & 1;
      FILENAME(LIBFILE) = 'LIB:XPL.LIB';
      CURRENT_PROCEDURE = '*';
      CALL SCAN;
      NO_LOOK_AHEAD_DONE = FALSE;
   END INITIALIZE;
STACK_DUMP:
   PROCEDURE;
      DECLARE LINE CHARACTER;
      IF \ CONTROL(BYTE('R')) THEN RETURN;  /* 'R' IS BARF SWITCH */
      LINE = 'PARTIAL PARSE TO THIS POINT IS: ';
      DO I = 0 TO SP;
         IF LENGTH(LINE) > 105 THEN
            DO;
               CALL PRINTLINE (LINE,-1);
               LINE = X4;
            END;
         LINE = LINE ^^ X1 ^^ VOCAB(STATE_NAME(STATE_STACK(I)));
      END;
      CALL PRINTLINE (LINE,-1);
   END STACK_DUMP;

  /*                  THE SYNTHESIS ALGORITHM FOR XPL                      */


SYNTHESIZE:
PROCEDURE(PRODUCTION_NUMBER);
   DECLARE PRODUCTION_NUMBER FIXED;
   DECLARE TOOMSG CHARACTER INITIAL ('TOO MANY ARGUMENTS FOR ');

   STACK_CASE:
      PROCEDURE (DATUM);
         DECLARE DATUM FIXED;
         DECLARE DCLRM CHARACTER
               INITIAL ('TOO MANY CASES OR FACTORED DECLARATIONS');
         IF CASEP >= CASELIMIT THEN CALL ERROR (DCLRM,1);
                               ELSE CASEP = CASEP + 1;
         CASESTACK(CASEP) = DATUM;
   END STACK_CASE;

      DO CASE (PRODUCTION_NUMBER);
   /*  ONE STATEMENT FOR EACH PRODUCTION OF THE GRAMMAR*/
   ;      /*  CASE 0 IS A DUMMY, BECAUSE WE NUMBER PRODUCTIONS FROM 1  */

/*      1   <PROGRAM> ::= <STATEMENT LIST> EOF                       */
DO;  /* END OF COMPILING */
   COMPILING = FALSE;
   IF MP \= 0  THEN
      DO;
         CALL ERROR ('INPUT DID NOT PARSE TO <PROGRAM>.', 1);
         CALL STACK_DUMP;
      END;
   DO I = PROCMARK TO NDECSY;
      IF SYTYPE (I) = FORWARDTYPE ^ SYTYPE (I) = FORWARDCALL THEN
         IF SYTCO (I) > 0 THEN
             CALL ERROR ('UNDEFINED LABEL OR PROCEDURE: ' ^^ SYT(I),1);
   END;
      IF DPOFFSET > 0 THEN CALL FLUSH_DATACARD;
END;

/*      2   <STATEMENT LIST> ::= <STATEMENT>                         */
   ;
/*      3                      ^ <STATEMENT LIST> <STATEMENT>        */
   ;
/*      4   <STATEMENT> ::= <BASIC STATEMENT>                        */
   DO;
      STATEMENT_COUNT = STATEMENT_COUNT + 1;
      CALL CLEARARS;
   END;

/*      5                 ^ <IF STATEMENT>                           */
   CALL CLEARARS;
/*      6   <BASIC STATEMENT> ::= <ASSIGNMENT> ;                     */
   ;
/*      7                       ^ <GROUP> ;                          */
   ;
/*      8                       ^ <PROCEDURE DEFINITION> ;           */
   ;
/*      9                       ^ <RETURN STATEMENT> ;               */
   ;
/*     10                       ^ <CALL STATEMENT> ;                 */
   ;
/*     11                       ^ <GO TO STATEMENT> ;                */
   ;
/*     12                       ^ <DECLARATION STATEMENT> ;          */
   ;
/*     13                       ^ ;                                  */
   ;
/*     14                       ^ <LABEL DEFINITION>                 */
/*     14                         <BASIC STATEMENT>                  */
   ;
/*     15   <IF STATEMENT> ::= <IF CLAUSE> <STATEMENT>               */
   CALL EMITLABEL(FIXL(MP),4);            /* FIX ESCAPE BRANCH */
/*     16                    ^ <IF CLAUSE> <TRUE PART> <STATEMENT>   */
   CALL EMITLABEL (FIXL(MPP1),4);         /* FIX ESCAPE BRANCH */
/*     17                    ^ <LABEL DEFINITION> <IF STATEMENT>     */
   ;
/*     18   <IF CLAUSE> ::= IF <EXPRESSION> THEN                     */
      CALL BOOLBRANCH(MPP1,MP);  /* BRANCH ON FALSE OVER TRUE PART */

/*     19   <TRUE PART> ::= <BASIC STATEMENT> ELSE                   */
   DO; /* SAVE THE PROGRAM POINTER AND EMIT THE CONDITIONAL BRANCH */
      FIXL(MP) = FINDLABEL;
      CALL EMITINST(JRST ,0,0,FIXL(MP),0,4);
      CALL EMITLABEL (FIXL(MP-1),4);      /* COMPLETE HOP AROUND TRUE */
      CALL CLEARARS;
   END;

/*     20   <GROUP> ::= <GROUP HEAD> <ENDING>                        */
        /* BRANCH BACK TO LOOP AND FIX ESCAPE BRANCH */
      IF INX (MP) = 1 ^ INX (MP) = 2 THEN
         DO;  /* STEP OR WHILE LOOP FIXUP */
            CALL EMITINST (JRST ,0,0,PPSAVE(MP),0,2);
            CALL EMITLABEL(FIXL(MP),4);
         END;
       ELSE IF INX (MP) = 3 THEN
         DO;  /* CASE GROUP */
            CALL EMITLABEL(FIXL(MP),4);   /* FIX BRANCH INTO JUMP LIST */
            DO I = PPSAVE (MP) TO CASEP - 1;
               CALL EMITINST (JRST ,0,0,CASESTACK(I),0,2); /* JUMP LIST */
               END;
            CASEP = PPSAVE (MP) - 1;
            CALL EMITLABEL(FIXV(MP),4);   /* FIX ESCAPE BRANCH */
         END;

/*     21   <GROUP HEAD> ::= DO ;                                    */
   INX (MP) = 0;                       /* ZERO DENOTES ORDINARY GROUP */

/*     22                  ^ DO <STEP DEFINITION> ;                  */
   DO;
      CALL MOVESTACKS (MPP1, MP);
      INX (MP) = 1;                    /* ONE DENOTES STEP */
      CALL CLEARARS;
   END;

/*     23                  ^ DO <WHILE CLAUSE> ;                     */
   DO;
      CALL MOVESTACKS (MPP1,MP);
      INX (MP) = 2;                    /* TWO DENOTES WHILE */
      CALL CLEARARS;
   END;

/*     24                  ^ DO <CASE SELECTOR> ;                    */
   DO;
      CALL MOVESTACKS (MPP1, MP);
      INX (MP) = 3;                    /* THREE DENOTES CASE */
      CALL CLEARARS;
      INFO = INFO ^^ ' CASE 0.';
   END;

/*     25                  ^ <GROUP HEAD> <STATEMENT>                */
   IF INX (MP) = 3 THEN
      DO; /* CASE GROUP, MUST RECORD STATEMENT ADDRESSES */
         CALL EMITINST (JRST ,0,0,FIXV(MP),0,4);
         CALL STACK_CASE (PP);
         INFO = INFO ^^ ' CASE ' ^^ CASEP - PPSAVE(MP) ^^ '.';
      END;

/*     26   <STEP DEFINITION> ::= <VARIABLE> <REPLACE>               */
/*     26                         <EXPRESSION> <ITERATION CONTROL>   */
   DO; /* EMIT CODE FOR STEPPING DO LOOPS */
      CALL FORCEACCUMULATOR (MP+2);     /* GET INITIAL VALUE */
      STEPK = FINDLABEL;
      CALL EMITINST (JRST ,0,0,STEPK,0,4);/* BRANCH AROUND INCR CODE */
      PPSAVE(MP) = PP;                  /* SAVE ADDRESS FOR LATER FIX */
      IF CNT (MP) > 0 THEN CALL ERROR ('DO INDEX MAY NOT BE SUBSCRIPTED',0);

                       /*  INCREMENT INDUCTION VARIABLE */
      IF SYTYPE(FIXL(MP)) = FIXEDTYPE & FIXL(SP) = TRUELOC THEN
         DO;           /* USE AOS IF INCREMENTING BY 1 */
            REG(MP) = REG(MP+2);
            CALL EMITINST (AOSA,REG(MP),0,SYTLOC(FIXL(MP)),0,1);
            TYPE(MP) = ACCUMULATOR;
         END;
      ELSE
         DO;           /* CAN'T USE AOS INST. */
            ACC(REG(MP+2)) = AVAIL;     /* MAKE SURE SAME REGISTER IS USED */
            TARGET_REGISTER = REG(MP+2);
            CALL FORCEACCUMULATOR (MP); /* FETCH THE INDEX     */
            TARGET_REGISTER = -1;
            CALL EMITINST(ADD,REG(MP),0,FIXL(MP+3),0,1);
         END;
                       /* UPDATE INDUCTION VARIABLE AND TEST FOR END */
      CALL EMITLABEL(STEPK,4);
      CALL GENSTORE (MP,MP);
      CALL EMITINST (CAMLE,REG(MP),0,FIXV(SP),0,1);
      FIXL (MP) = FINDLABEL;
      CALL EMITINST (JRST ,0,0,FIXL(MP),0,4);
      ACC(REG(MP)) = AVAIL;
   END;

/*     27   <ITERATION CONTROL> ::= TO <EXPRESSION>                  */
   DO;
      FIXL(MP) = TRUELOC;   /* POINT AT THE CONSTANT ONE FOR STEP */
      CALL SETLIMIT;
   END;

/*     28                         ^ TO <EXPRESSION> BY               */
/*     28                           <EXPRESSION>                     */
   DO;
      IF TYPE (SP) = CONSTANT THEN CALL EMITCONSTANT (FIXV(SP));
      ELSE
         DO;
            CALL FORCEACCUMULATOR (SP);
            CALL EMITDATAWORD (0);
            ADR = DP - 1;
            CALL EMITINST (MOVEM,REG(SP),0,ADR,0,1);
            ACC(REG(SP)) = AVAIL;
         END;
      FIXL (MP) =ADR;
      CALL SETLIMIT;
   END;

/*     29   <WHILE CLAUSE> ::= WHILE <EXPRESSION>                    */
   CALL BOOLBRANCH (SP,MP);

/*     30   <CASE SELECTOR> ::= CASE <EXPRESSION>                    */
   /* THE FOLLOWING USE IS MADE OF THE PARALLEL STACKS BELOW <CASE SELECTOR>
         PPSAVE     PREVIOUS MAXIMUM CASE STACK POINTER
         FIXL       ADDRESS OF INDEXED GOTO INTO LIST
         FIXV       ADDRESS OF ESCAPE GOTO FOR CASES
   */
   DO;
      CALL FORCEACCUMULATOR (SP);       /* GET THE INDEX IN TO AR */
      ACC(REG(SP)) = AVAIL;
      FIXL(MP) = FINDLABEL;
      CALL EMITINST (JRST ,0,1,FIXL(MP),REG(SP),4);/* INDIRECT INDEXED BRANCH */
      FIXV(MP) = FINDLABEL;             /* ADDRESS OF ESCAPE BRANCH */
      CALL STACK_CASE (PP);
      PPSAVE (MP) = CASEP;
   END;

/*     31   <PROCEDURE DEFINITION> ::= <PROCEDURE HEAD>              */
/*     31                              <STATEMENT LIST> <ENDING>     */
   /* THE FOLLOWING USE IS MADE OF THE PARALLEL STACKS BELOW
      <PROCEDURE HEAD>
      PPSAVE           ADDRESS OF PREVIOUS PROC RETURN
      FIXL             ADDRESS OF PREVIOUS PROC ACCUMULATOR AREA
      FIXV             POINTER TO SYMBOL TABLE FOR THIS BLOCK
      CNT              COUNT OF THE PARAMETERS OF PREVIOUS PROC
   */
   DO;   /* PROCEDURE IS DEFINED, RESTORE SYMBOL TABLE */
      IF LENGTH (VAR(SP)) > 0 THEN
         IF SUBSTR (CURRENT_PROCEDURE,1) \= VAR(SP) THEN
            CALL ERROR ('PROCEDURE' ^^ CURRENT_PROCEDURE ^^ ' CLOSED BY END '
                        ^^ VAR(SP), 0);
      IF CONTROL(BYTE('S')) THEN CALL SYMBOLDUMP;
      DO I = PROCMARK TO NDECSY;
         IF SYTYPE (I) = FORWARDTYPE ^ SYTYPE (I) = FORWARDCALL THEN
            IF SYTCO (I) > 0 THEN
               CALL ERROR ('UNDEFINED LABEL OR PROCEDURE: ' ^^ SYT (I), 1);
      END;
      DO I = 0 TO (NDECSY + 1) - (PROCMARK + PARCT);
         J = NDECSY - I;
         IF (J >= (PROCMARK + PARCT)) & (LENGTH(SYT(J)) > 0) THEN
            DO;
               HASH (HASHER(SYT(J))) = PTR (J);
               PTR (J) = -1;
            END;
      END;
      DO I = PROCMARK + PARCT TO NDECSY;
          SYT (I) = X1;
      END;
      NDECSY = PROCMARK + PARCT - 1;
      /* PARAMETER ADDRESSES MUST BE SAVED BUT NAMES DISCARDED */
      IF PARCT > 0 THEN
         DO J = 0 TO NDECSY - PROCMARK;
            I = NDECSY - J;
            IF SYTYPE (I) = 0 THEN
               DO;
                  CALL ERROR ('UNDECLARED PARAMETER: ' ^^ SYT (I), 0);
                  SYTYPE (I) = FIXEDTYPE;
                  CALL EMITDATAWORD (0);
                  SYTLOC(I) = DP -1;
               END;
            HASH (HASHER(SYT(I))) = PTR (I);
            PTR (I) = -1;
            SYT (I) = '';
         END;
      PROCMARK = FIXV (MP);
      PARCT = CNT (MP);
      CURRENT_PROCEDURE = VAR (MP);
      /* EMIT A GRATUITOUS RETURN */
      CALL EMITINST (POPJ,15,0,0,0,0);
      /* COMPLETE JUMP AROUND THE PROCEDURE DEFINITION */
      CALL EMITLABEL(PPSAVE(MP),4);
      RETURNED_TYPE = TYPE(MP);
   END;

/*     32   <PROCEDURE HEAD> ::= <PROCEDURE NAME> ;                  */
   DO;      /* MUST POINT AT FIRST PARAMETER EVEN IF NON EXISTANT */
      /* SAVE OLD PARAMETER COUNT */
      CNT (MP) = PARCT;
      PARCT = 0;
      /* SAVE OLD PROCEDURE MARK IN SYMBOL TABLE */
      FIXV(MP) = PROCMARK;
      PROCMARK = NDECSY + 1;
      TYPE(MP) = RETURNED_TYPE;
      RETURNED_TYPE = 0;
      CALL PROC_START;
   END;

/*     33                      ^ <PROCEDURE NAME> <TYPE> ;           */
   DO;
      CNT (MP) = PARCT;           /* SAVE OLD PARAMETER COUNT */
      PARCT = 0;
      FIXV(MP) = PROCMARK;        /* SAVE OLD PROCEDURE MARK IN SYMBOL TABLE */
      PROCMARK = NDECSY + 1;
      TYPE(MP) = RETURNED_TYPE;
      RETURNED_TYPE = TYPE(SP-1);
      IF RETURNED_TYPE = CHRTYPE THEN SYTYPE(FIXL(MP)) = CHARPROCTYPE;
      CALL PROC_START;
   END;

/*     34                      ^ <PROCEDURE NAME> <PARAMETER LIST>   */
/*     34                        ;                                   */
   DO;
      CNT(MP) = CNT(MPP1);  /* SAVE PARAMETER COUNT */
      FIXV(MP) = FIXV (MPP1);
      TYPE(MP) = RETURNED_TYPE;
      RETURNED_TYPE = 0;
      CALL PROC_START;
   END;

/*     35                      ^ <PROCEDURE NAME> <PARAMETER LIST>   */
/*     35                        <TYPE> ;                            */
   DO;
      CNT(MP) = CNT(MPP1);  /* SAVE PARAMETER COUNT */
      FIXV(MP) = FIXV (MPP1);
      TYPE(MP) = RETURNED_TYPE;
      RETURNED_TYPE = TYPE(SP-1);
      IF RETURNED_TYPE = CHRTYPE THEN SYTYPE(FIXL(MP)) = CHARPROCTYPE;
      CALL PROC_START;
   END;

/*     36   <PROCEDURE NAME> ::= <LABEL DEFINITION> PROCEDURE        */
   DO;
      SYTYPE (FIXL (MP)) = PROCTYPE;
      S = CURRENT_PROCEDURE;
      CURRENT_PROCEDURE = X1 ^^ VAR (MP);
      VAR (MP) = S;
   END;


/*     37   <PARAMETER LIST> ::= <PARAMETER HEAD> <IDENTIFIER> )     */
   DO;
      PARCT = PARCT + 1;   /* BUMP THE PARAMETER COUNT */
      CALL ENTER (VAR(MPP1), 0, 0, 0);
   END;

/*     38   <PARAMETER HEAD> ::= (                                   */
   DO;  /* POINT AT THE FIRST PARAMETER FOR SYMBOL TABLE */
      FIXV(MP) = PROCMARK;
      PROCMARK = NDECSY + 1;
      CNT (MP) = PARCT;        /* SAVE OLD PARAMETER COUNT */
      PARCT = 0;
   END;

/*     39                      ^ <PARAMETER HEAD> <IDENTIFIER> ,     */
   DO;
       PARCT = PARCT + 1;          /* BUMP THE PARAMETER COUNT */
      CALL ENTER (VAR(MPP1), 0, 0, 0);
   END;

/*     40   <ENDING> ::= END                                         */
   ;
/*     41              ^ END <IDENTIFIER>                            */
   VAR (MP) = VAR (SP);

/*     42              ^ <LABEL DEFINITION> <ENDING>                 */
   ;
/*     43   <LABEL DEFINITION> ::= <IDENTIFIER> :                    */
   FIXL(MP) = ENTER (VAR(MP), LABELTYPE, PP, 2);

/*     44   <RETURN STATEMENT> ::= RETURN                            */
   DO;
      CALL EMITINST (POPJ,15,0,0,0,0);
   END;

/*     45                        ^ RETURN <EXPRESSION>               */
   DO;  /* EMIT A RETURN AND PASS A VALUE */
      TARGET_REGISTER = 0;
      IF RETURNED_TYPE = CHRTYPE THEN
         CALL FORCEDESCRIPTOR(SP);
      ELSE
         CALL FORCEACCUMULATOR (SP);
      TARGET_REGISTER = -1;
      IF REG(SP) \= 0 THEN CALL EMITINST(MOVE,0,0,REG(SP),0,0);
      CALL EMITINST (POPJ,15,0,0,0,0);
   END;
/*     46   <CALL STATEMENT> ::= CALL <VARIABLE>                     */
   DO;
      I = SYTYPE(FIXL(SP));
      IF I=PROCTYPE ^ I=FORWARDCALL ^ I = CHARPROCTYPE
                    ^ (I=SPECIAL & SYTLOC(FIXL(SP))=12)
                    ^ (I=SPECIAL & SYTLOC(FIXL(SP))=9)  THEN
         DO;
            CALLTYPE = 0;               /* NO RETURN VALUE */
            CALL FORCEACCUMULATOR(SP);
            CALLTYPE = 1;
         END;
      ELSE CALL ERROR ('UNDEFINED PROCEDURE: ' ^^ SYT(FIXL(SP)),0);
   END;

/*     47   <GO TO STATEMENT> ::= <GO TO> <IDENTIFIER>               */
   DO;
      CALL ID_LOOKUP(SP);
      J = FIXL (SP);
      IF J < 0 THEN
         DO;  /* FIRST OCURRANCE OF THE LABEL */
            I = FINDLABEL;
            CALL EMITINST (JRST ,0,0,I,0,4);
            J = ENTER (VAR(SP),FORWARDTYPE,I,4);
            SYTCO (J) = 1;
         END;
      ELSE IF SYTYPE(J) = LABELTYPE ^ SYTYPE(J) = FORWARDTYPE THEN
          CALL EMITINST (JRST ,0,0,SYTLOC(J),0,SYTSEG(J));
      ELSE
        CALL ERROR ('TARGET OF GOTO IS NOT A LABEL', 0);
   END;

/*     48   <GO TO> ::= GO TO                                        */
   ;
/*     49             ^ GOTO                                         */
   ;
/*     50   <DECLARATION STATEMENT> ::= DECLARE                      */
/*     50                               <DECLARATION ELEMENT>        */
   ;
/*     51                             ^ <DECLARATION STATEMENT> ,    */
/*     51                               <DECLARATION ELEMENT>        */
   ;
/*     52   <DECLARATION ELEMENT> ::= <TYPE DECLARATION>             */
      IF TYPE (MP) = CHRTYPE THEN
         DO WHILE (DSP < NEWDSP);
            CALL EMITDESC (0,0);
         END;
      ELSE
         DO;
            IF DP < NEWDP THEN
               DO;
                  IF DPOFFSET > 0 THEN CALL FLUSH_DATACARD;
                  IF DP < NEWDP THEN CALL EMITBLOCK (NEWDP-DP);
               END;
            DO WHILE (DPOFFSET < NEWDPOFFSET);
               CALL EMITBYTE(0);
            END;
         END;

/*     53                           ^ <IDENTIFIER> LITERALLY         */
/*     53                             <STRING>                       */
   IF TOP_MACRO >= MACRO_LIMIT THEN
      CALL ERROR ('MACRO TABLE OVERFLOW', 1);
   ELSE DO;
      TOP_MACRO = TOP_MACRO + 1;
      I = LENGTH(VAR(MP));
      J = MACRO_INDEX(I);
      DO L = 1 TO TOP_MACRO - J;
         K = TOP_MACRO - L;
         MACRO_NAME(K+1) = MACRO_NAME(K);
         MACRO_TEXT(K+1) = MACRO_TEXT(K);
         MACRO_COUNT(K+1) = MACRO_COUNT(K);
         MACRO_DECLARE(K+1) = MACRO_DECLARE(K);
      END;
      MACRO_NAME(J) = VAR(MP);
      MACRO_TEXT(J) = VAR(SP);
      MACRO_COUNT(J) = 0;
      MACRO_DECLARE(J) = CARD_COUNT;
      DO J = I TO 255;
         MACRO_INDEX(J) = MACRO_INDEX(J) + 1;
      END;
   END;

/*     54   <TYPE DECLARATION> ::= <IDENTIFIER SPECIFICATION>        */
/*     54                          <TYPE>                            */
   CALL TDECLARE (0);

/*     55                        ^ <BOUND HEAD> <NUMBER> ) <TYPE>    */
   CALL TDECLARE (FIXV(MPP1));

/*     56                        ^ <TYPE DECLARATION>                */
/*     56                          <INITIAL LIST>                    */
   ;
/*     57   <TYPE> ::= FIXED                                         */
   TYPE (MP) = FIXEDTYPE;
/*     58            ^ CHARACTER                                     */
   TYPE (MP) = CHRTYPE;
/*     59            ^ LABEL                                         */
   TYPE (MP) = FORWARDTYPE;

/*     60            ^ <BIT HEAD> <NUMBER> )                         */
   IF FIXV(MPP1) <= 9 THEN TYPE (MP) = BYTETYPE; ELSE
      IF FIXV (MPP1) <= 36 THEN TYPE (MP) = FIXEDTYPE; ELSE
         TYPE (MP) = CHRTYPE;

/*     61   <BIT HEAD> ::= BIT (                                     */
   ;
/*     62   <BOUND HEAD> ::= <IDENTIFIER SPECIFICATION> (            */
   ;
/*     63   <IDENTIFIER SPECIFICATION> ::= <IDENTIFIER>              */
   DO;
      INX(MP) = 1;
      FIXL(MP) = CASEP;
      CALL STACK_CASE (ENTER(VAR(MP),0,0,0));
   END;
/*     64                                ^ <IDENTIFIER LIST>         */
/*     64                                  <IDENTIFIER> )            */
   DO;
      INX(MP) = INX(MP) + 1;
      CALL STACK_CASE (ENTER(VAR(MPP1),0,0,0));
   END;
/*     65   <IDENTIFIER LIST> ::= (                                  */
   DO;
      INX(MP) = 0;
      FIXL(MP) = CASEP;
   END;
/*     66                       ^ <IDENTIFIER LIST> <IDENTIFIER> ,   */
   DO;
      INX(MP) = INX(MP) + 1;
      CALL STACK_CASE (ENTER(VAR(MPP1),0,0,0));
   END;

/*     67   <INITIAL LIST> ::= <INITIAL HEAD> <CONSTANT> )           */
   CALL SETINIT;

/*     68   <INITIAL HEAD> ::= INITIAL (                             */
   IF INX(MP-1) = 1 THEN
      ITYPE = TYPE (MP-1);  /* COPY INFORMATION FROM <TYPE DECLARATION> */
   ELSE
      DO;
         CALL ERROR ('INITIAL MAY NOT BE USED WITH IDENTIFIER LIST',0);
         ITYPE = 0;
      END;

/*     69                    ^ <INITIAL HEAD> <CONSTANT> ,           */
   CALL SETINIT;
/*     70   <ASSIGNMENT> ::= <VARIABLE> <REPLACE> <EXPRESSION>       */
   CALL GENSTORE(MP,SP);
/*     71                  ^ <LEFT PART> <ASSIGNMENT>                */
   CALL GENSTORE(MP,SP);
/*     72   <REPLACE> ::= =                                          */
   ;
/*     73   <LEFT PART> ::= <VARIABLE> ,                             */
   ;
/*     74   <EXPRESSION> ::= <LOGICAL FACTOR>                        */
   ;
/*     75                  ^ <EXPRESSION> ^ <LOGICAL FACTOR>         */
   CALL ARITHEMIT (IOR,1);
/*     76   <LOGICAL FACTOR> ::= <LOGICAL SECONDARY>                 */
   ;
/*     77                      ^ <LOGICAL FACTOR> &                  */
/*     77                        <LOGICAL SECONDARY>                 */
   CALL ARITHEMIT (AND,1);
/*     78   <LOGICAL SECONDARY> ::= <LOGICAL PRIMARY>                */
   ;
/*     79                         ^ \ <LOGICAL PRIMARY>              */
   DO;
      CALL MOVESTACKS (SP, MP);
       /* GET 1'S COMPLEMENT */
      CALL FORCEACCUMULATOR(MP);
      CALL EMITINST (SETCA,REG(MP),0,0,0,0);
   END;

/*     80   <LOGICAL PRIMARY> ::= <STRING EXPRESSION>                */
   ;
/*     81                       ^ <STRING EXPRESSION> <RELATION>     */
/*     81                         <STRING EXPRESSION>                */
      /* RELATIONS ARE ENCODED AS TO THEIR CAM? INSTRICTION CODE */
      /*
         <     1
         >     7
         \=    6
         =     2
         <=    3
         \>    3
         >=    5
         \<    5
      */
   DO;
      I = TYPE (MP);
      J = TYPE (SP);
      IF I = DESCRIPT ^ I = CHRTYPE THEN CALL STRINGCOMPARE; ELSE
      IF I = VARIABLE & SYTYPE(FIXL(MP)) = CHRTYPE THEN CALL STRINGCOMPARE; ELSE
      IF J = DESCRIPT ^ J = CHRTYPE THEN CALL STRINGCOMPARE; ELSE
      IF J = VARIABLE & SYTYPE(FIXL(SP)) = CHRTYPE THEN CALL STRINGCOMPARE; ELSE
         DO;
            IF I = VARIABLE & SYTYPE(FIXL(MP)) = BYTETYPE THEN
                   CALL FORCEACCUMULATOR(MP);
            IF J = VARIABLE & SYTYPE(FIXL(SP)) = BYTETYPE THEN
                   CALL FORCEACCUMULATOR(SP);
            IF SHOULDCOMMUTE THEN CALL FORCEACCUMULATOR(SP);
            ELSE CALL FORCEACCUMULATOR(MP);
            I = FINDAR;
            CALL EMITINST(MOVEI,I,0,1,0,0);
            CALL ARITHEMIT (CAM+INX(MPP1),1);
            CALL EMITINST (MOVEI,I,0,0,0,0);
            STILLCOND = INX(MPP1);
            ACC(REG(MP))=AVAIL;
            REG(MP) = I;
            TYPE(MP) = ACCUMULATOR;
         END;
   END;

/*     82   <RELATION> ::= =                                         */
   INX(MP) = 2;
/*     83                ^ <                                         */
   INX(MP) = 1;
/*     84                ^ >                                         */
   INX(MP) = 7;
/*     85                ^ \ =                                       */
   INX(MP) = 6;
/*     86                ^ \ <                                       */
   INX (MP) = 5;
/*     87                ^ \ >                                       */
   INX(MP) = 3;
/*     88                ^ < =                                       */
   INX(MP) = 3;
/*     89                ^ > =                                       */
   INX (MP) = 5;
/*     90   <STRING EXPRESSION> ::= <ARITHMETIC EXPRESSION>          */
   ;

/*     91                         ^ <STRING EXPRESSION> ^^           */
/*     91                           <ARITHMETIC EXPRESSION>          */
    DO; /* CATENATE TWO STRINGS */
      CALL FORCEDESCRIPTOR (MP);
      CALL DELETE_MOVE (MP,MOVEM,REG(MP),0,A,0,3);
      ACC(REG(MP)) = AVAIL;
      CALL FORCEDESCRIPTOR (SP);
      CALL DELETE_MOVE (SP,MOVEM,REG(SP),0,B,0,3);
      ACC(REG(SP)) = AVAIL;
      CALL SAVE_ACS (2);
      IF ACC(11) \= AVAIL THEN CALL EMITINST (PUSH,15,0,11,0,0);
      CALL EMITINST (PUSHJ,15,0,CATENTRY,0,2);
      IF ACC(11) \= AVAIL THEN CALL EMITINST (POP,15,0,11,0,0);
      CALL RESTORE_ACS (2);
      I = FINDAR;
      CALL EMITINST (MOVE,I,0,0,0,0);
      STILLINZERO = I;
      REG(MP) = I;
   END;

/*     92   <ARITHMETIC EXPRESSION> ::= <TERM>                       */
   ;
/*     93                             ^ <ARITHMETIC EXPRESSION> +    */
/*     93                               <TERM>                       */
   CALL ARITHEMIT (ADD,1);
/*     94                             ^ <ARITHMETIC EXPRESSION> -    */
/*     94                               <TERM>                       */
   CALL ARITHEMIT (SUB,0);
/*     95                             ^ + <TERM>                     */
   CALL MOVESTACKS (MPP1, MP);

/*     96                             ^ - <TERM>                     */
   DO;
      CALL MOVESTACKS (MPP1, MP);
      IF TYPE (MP) = CONSTANT THEN FIXV (MP) = - FIXV (MP);
      ELSE
         DO;
            CALL FORCEACCUMULATOR (MP);
            CALL EMITINST (MOVN,REG(MP),0,REG(MP),0,0);
         END;
   END;

/*     97   <TERM> ::= <PRIMARY>                                     */
   ;
/*     98            ^ <TERM> * <PRIMARY>                            */
   CALL ARITHEMIT (IMUL,1);
/*     99            ^ <TERM> / <PRIMARY>                            */
   CALL DIVIDE_CODE(1);
/*    100            ^ <TERM> MOD <PRIMARY>                          */
   CALL DIVIDE_CODE(0);
/*    101   <PRIMARY> ::= <CONSTANT>                                 */
   ;
/*    102               ^ <VARIABLE>                                 */
   ;
/*    103               ^ ( <EXPRESSION> )                           */
   CALL MOVESTACKS (MPP1, MP);

/*    104   <VARIABLE> ::= <IDENTIFIER>                              */
   /* THE FOLLOWING USE IS MADE OF THE PARALLEL STACKS BELOW <VARIABLE>
          CNT      THE NUMBER OF SUBSCRIPTS
          FIXL     THE SYMBOL TABLE POINTER
          FIXV     BUILTIN CODE IF SPECIAL
          TYPE     VARIABLE
          INX      ZERO OR ACCUMULATOR OF SUBSCRIPT
      AFTER THE VARIABLE IS FORCED INTO AN ACCUMULATOR
          TYPE     ACCUMULATOR OR DESCRIPT
          REG      CURRENT ACCUMULATOR
   */
   DO;   /* FIND THE IDENTIFIER IN THE SYMBOL TABLE */
      CALL ID_LOOKUP (MP);
       IF FIXL (MP) = -1 THEN CALL UNDECLARED_ID (MP);
   END;

/*    105                ^ <SUBSCRIPT HEAD> <EXPRESSION> )           */

   DO; /* EITHER A PROCEDURE CALL, ARRAY, OR BUILTIN FUNCTION */
      CNT (MP) = CNT (MP) + 1;          /* COUNT SUBSCRIPTS */
      I = FIXV (MP);                    /* ZERO OR BUILTIN FUNCTION NUMBER */
      IF I < 6 THEN DO CASE I;
         /* CASE 0 -- ARRAY OR CALL */
         DO;
            IF SYTYPE (FIXL (MP)) = PROCTYPE
             ^ SYTYPE (FIXL (MP)) = CHARPROCTYPE THEN CALL STUFF_PARAMETER;
            ELSE
               IF CNT (MP) > 1 THEN
                  CALL ERROR ('MULTIPLE SUBSCRIPTS NOT ALLOWED', 0);
               ELSE
                  DO;
                     CALL FORCEACCUMULATOR (MPP1);
                     INX (MP) = REG(MPP1);
                  END;
         END;
         /* CASE 1 -- BUILTIN FUNCTION LENGTH */
         DO;
            CALL FORCEDESCRIPTOR (MPP1);
            CALL EMITINST(LSH,REG(MPP1),0,    -27,0,0);/* SHIFT OUT ADDRESS */
            TYPE (MP) = ACCUMULATOR;
            REG(MP) = REG(MPP1);
         END;
         /* CASE 2 -- BUILTIN FUNCTION SUBSTR */
         DO;  /* BUILTIN FUNCTION SUBSTR */
            IF CNT(MP) = 2 THEN
               DO;
                  IF TYPE(MPP1) = CONSTANT THEN
                     DO;  /* EMIT A COMPLEX CONSTANT */
                        CALL EMITCONSTANT (SHL(FIXV(MPP1),27)-FIXV(MPP1));
                        CALL EMITINST (SUB,REG(MP),0,ADR,0,1);
                     END;
                  ELSE
                     DO;
                       CALL FORCEACCUMULATOR (MPP1);
                       CALL EMITINST (ADD,REG(MP),0,REG(MPP1),0,0);
                       CALL EMITINST (LSH,REG(MPP1),0,    27,0,0);
                       CALL EMITINST (SUB,REG(MP),0,REG(MPP1),0,0);
                       ACC(REG(MPP1)) = AVAIL;
                     END;
               END;
            ELSE
               DO;  /* THREE ARGUMENTS */
                  IF TYPE(MPP1) = CONSTANT THEN
                     DO;  /* MAKE A CONSTANT LENGTH TO OR IN */
                        CALL EMITCONSTANT (SHL(FIXV(MPP1),27));
                        CALL EMITINST (IOR,REG(MP),0,ADR,0,1);
                     END;
                  ELSE
                     DO;
                        CALL FORCEACCUMULATOR (MPP1);
                        CALL EMITINST (LSH,REG(MPP1),0,    27,0,0);
                        CALL EMITINST(IOR,REG(MP),0,REG(MPP1),0,0);
                         ACC(REG(MPP1)) = AVAIL;
                     END;
               END;
            TYPE (MP) = DESCRIPT;
         END;
         /* CASE 3 -- BUILTIN FUNCTION BYTE */
         DO;  /* BUILTIN FUNCTION BYTE */
            IF CNT(MP) = 1 THEN
               DO;
                  IF TYPE (MPP1) = CHRTYPE THEN
                     DO;
                        FIXV(MP) = BYTE(VAR(MPP1));
                        TYPE (MP) = CONSTANT;
                     END;
                  ELSE
                     DO;
                        CALL FORCEDESCRIPTOR (MPP1);
                        CALL EMITINST (AND,REG(MPP1),0,ADDRMASK,0,1);
                        /* FAKE A COREBYTE */
                        TYPE(MPP1) = VARIABLE;
                        FIXL(MPP1) = COREBYTELOC;
                        INX(MPP1) = REG(MPP1);
                        CNT(MPP1) = 1;
                        CALL FORCEACCUMULATOR (MPP1);
                        TYPE(MP) = TYPE(MPP1);
                        REG(MP) = REG(MPP1);
                     END;
               END;
            ELSE IF CNT (MP) = 2 THEN
               DO;
                  SP = MPP1;  /* SO WE CAN USE ARITHEMIT */
                  CALL ARITHEMIT (ADD,1);
                  /* FAKE A COREBYTE */
                  TYPE(MPP1) = VARIABLE;
                  FIXL(MPP1) = COREBYTELOC;
                        CNT(MPP1) = 1;
                  INX(MPP1) = REG(MP);
                  CALL FORCEACCUMULATOR(MPP1);
                  TYPE(MP) = TYPE(MPP1);
                  REG(MP) = REG(MPP1);
               END;
            ELSE CALL ERROR (TOOMSG ^^ SYT(FIXL(MP)),0);
         END;
         /* CASE 4 -- BUILTIN FUNCTION SHL */
         CALL SHIFT_CODE (0);           /* <- */
         /* CASE 5 -- BUILTIN FUNCTION SHR */
         CALL SHIFT_CODE (1);           /* -> */
      END; /* CASE ON I */
      ELSE IF I = 9 THEN CALL EMIT_INLINE(1);  /*BUILT-IN FUNCTION INLINE */
      ELSE IF I = 18 THEN
         DO;  /* BUILTIN FUNCTION ADDR */
            CALL FORCEADDRESS (MPP1);
            TYPE (MP) = ACCUMULATOR;
         END;
      ELSE DO;    /* SOME SORT OF BUILTIN FUNCTION */
              CALL FORCEACCUMULATOR(MPP1);
              IF CNT(MP) = 1 THEN REG(MP) = REG(MPP1);
               ELSE INX(MP) = REG(MPP1);
           END;
   END;

/*    106   <SUBSCRIPT HEAD> ::= <IDENTIFIER> (                      */
   DO;
      CALL ID_LOOKUP(MP);
      IF FIXL(MP) = -1 THEN CALL UNDECLARED_ID (MP);
   END;

/*    107                      ^ <SUBSCRIPT HEAD> <EXPRESSION> ,     */

   DO; /* BUILTIN FUNCTION OR PROCEDURE CALL */
      CNT (MP) = CNT (MP) + 1;
      IF FIXV (MP) = 0 THEN
         DO; /* NOT A BUILTIN FUNCTION */
            IF SYTYPE(FIXL(MP)) = PROCTYPE
             ^ SYTYPE(FIXL(MP)) = CHARPROCTYPE THEN CALL STUFF_PARAMETER;
            ELSE CALL FORCEACCUMULATOR (MPP1);
         END;
      ELSE IF FIXV(MP) = 2 ^ FIXV (MP) = 3 THEN
         DO; /* SUBSTR OR BYTE */
            IF CNT(MP) = 1 THEN
               DO;
                  CALL FORCEDESCRIPTOR (MPP1);
                  TYPE (MP) = ACCUMULATOR;
                  REG(MP) = REG(MPP1);
               END;
            ELSE IF CNT (MP) = 2 & FIXV (MP) = 2 THEN
               DO; /* JUST SUBSTR, WE'LL NOTE ERROR ON BYTE LATER */
                  IF TYPE(MPP1) \= CONSTANT ^ FIXV(MPP1) \= 0 THEN
                     DO;
                        SP = MPP1;  /* SO WE CAN USE ARITHEMIT */
                       CALL ARITHEMIT (ADD,1);
                        FIXV(MP) = 2; /* IF IT COMMUTES, ARITHMIT CHANGES IT */
                     END;
                  CALL EMITINST(AND,REG(MP),0,ADDRMASK,0,1);/* AND OUT LENGTH */
               END;
            ELSE CALL ERROR (TOOMSG ^^ SYT(FIXL(MP)),0);
         END;
      ELSE IF FIXV(MP) = 4 ^ FIXV (MP) = 5 THEN
         DO; /* SHR OR SHL */
            CALL FORCEACCUMULATOR (MPP1);
            REG(MP) = REG(MPP1);
         END;
      ELSE IF FIXV(MP) = 9 THEN CALL EMIT_INLINE(0); /* INLINE */
      ELSE DO; /* SOME SORT OF BUILTIN FUNCTION */
              IF CNT (MP) = 1 THEN
                 DO;
                    CALL FORCEACCUMULATOR (MPP1); /* PICK UP THE VARIABLE */
                    REG(MP) = REG(MPP1);
                 END;
              ELSE CALL ERROR (TOOMSG ^^ SYT(FIXL(MP)),0);
           END;
   END;

/*    108   <CONSTANT> ::= <STRING>                                  */
   TYPE (MP) = CHRTYPE;
/*    109                ^ <NUMBER>                                  */
   TYPE (MP) = CONSTANT;

END;  /* OF CASE ON PRODUCTION NUMBER */
END SYNTHESIZE;

  /*              SYNTACTIC PARSING FUNCTIONS                              */


 CONFLICT: PROCEDURE (CURRENT_STATE);

         DECLARE I FIXED, CURRENT_STATE FIXED;

         /*   THIS PROC IS TRUE IF THE CURRENT TOKEN IS NOT   */
         /*   A TRANSITION SYMBOL FROM THE CURRENT STATE      */

         /*   (A CONFLICT THEREFORE EXISTS BETWEEN THE        */
         /*   CURRENT STATE AND THE NEXT TOKEN)               */

         I = INDEX1(CURRENT_STATE);   /*   STARTING POINT FOR STATE        */
                                      /*   TRANSITION SYMBOLS              */
         DO I = I TO I+INDEX2(CURRENT_STATE)-1;   /*   COMPARE WITH EACH   */
         IF READ1(I) = TOKEN THEN RETURN (FALSE); /*   FOUND IT            */
         END;
         RETURN (TRUE);   /*   NOT THERE   */

         END CONFLICT;


 RECOVER: PROCEDURE;

         DECLARE ANSWER BIT(1);

         /*   THIS IS A VERY CRUDE ERROR RECOVERY PROCEDURE               */
         /*   IT RETURNS TRUE IF THE PARSE MUST BE RESUMED IN             */
         /*   A NEW STATE (THE ONE IN THE CURRENT POSITION OF THE STATE   */
         /*   STACK)                                                      */
         /*   IT RETURNS FALSE IF THE PARSE IS RESUMED WITH THE SAME      */
         /*   STATE AS WAS INTENDED BEFORE RECOVER WAS CALLED             */

         ANSWER = FALSE;
         /*   IF THIS IS THE SECOND SUCCESSIVE CALL TO RECOVER, DISCARD   */
         /*   ONE SYMBOL (FAILSOFT IS SET TRUE BY SCAN)                   */
         IF \ FAILSOFT & 1 THEN CALL SCAN;
         FAILSOFT = FALSE;
         /*   FIND SOMETHING SOLID IN THE TEXT   */
         DO WHILE (\STOPIT(TOKEN) & 1);
         CALL SCAN;
         END;
         NO_LOOK_AHEAD_DONE = FALSE;
         /*   DELETE PARSE STACK UNTIL THE HARD TOKEN IS   */
         /*   LEGAL AS A TRANSITION SYMBOL                 */
         DO WHILE CONFLICT (STATE_STACK(SP));
         IF SP > 0
              THEN DO;
                   /*   DELETE ONE ITEM FROM THE STACK   */
                   SP = SP - 1;
                   ANSWER = TRUE;   /*   PARSE TO BE RESUMED IN NEW STATE   */
                   END;
              ELSE DO;   /*   STACK IS EMPTY   */
                   /*   TRY TO FIND A LEGAL TOKEN (FOR START STATE)   */
                    CALL SCAN;
                   IF TOKEN = EOFILE
                        THEN DO;
                             /*   MUST STOP COMPILING                */
                             /*   RESUME PARSE IN AN ILLEGAL STATE   */
                             ANSWER = TRUE;
                             STATE_STACK(SP) = 0;
                             RETURN (ANSWER);
                             END;
                   END;
         END;
         /*   FOUND AN ACCEPTABLE TOKEN FROM WHICH TO RESUME THE PARSE   */
         CALL PRINTLINE ('RESUME:' ^^ SUBSTR(POINTER,LENGTH(POINTER)-
            (LINE_LENGTH+CP-TEXT_LIMIT-LB-1)+LENGTH(BCD)),-1);
         RETURN (ANSWER);

         END RECOVER;


 COMPILATION_LOOP:
   PROCEDURE;

         DECLARE OVERFLOW CHARACTER INITIAL (
         'STACK OVERFLOW *** COMPILATION ABORTED ***');
         DECLARE I FIXED, J FIXED, STATE FIXED;
         DECLARE END_OF_FILE CHARACTER INITIAL (
         'END OF FILE FOUND UNEXPECTEDLY *** COMPILATION ABORTED ***');

         /*   THIS PROC PARSES THE INPUT STRING (BY CALLING THE SCANNER)   */
         /*   AND CALLS THE CODE EMISSION PROC (SYNTHESIZE) WHENEVER A     */
         /*   PRODUCTION CAN BE APPLIED                                    */

         /*   INITIALIZE                                                   */
         COMPILING = TRUE;
         STATE = START_STATE;
         SP = -1;
         /*   STOP COMPILING IF FINISHED                                   */
 COMP:   DO WHILE (COMPILING);
         /*   FIND WHICH OF THE FOUR KINDS OF STATES WE ARE DEALING WITH:  */
         /*   READ,APPLY PRODUCTION,LOOKAHEAD, OR PUSH STATE               */
         IF STATE <= MAXR#
              THEN DO;   /*   READ STATE   */
                   SP = SP+1;   /*   ADD AN ELEMENT TO THE STACK   */
                   IF SP = STACKSIZE
                        THEN DO;
                             CALL ERROR (OVERFLOW,2);
                             RETURN;
                             END;
                   STATE_STACK(SP) = STATE;   /*   PUSH PRESENT STATE   */
                   I = INDEX1(STATE);         /*   GET STARTING POINT   */
                   IF NO_LOOK_AHEAD_DONE
                        THEN DO;   /*   READ IF NECESSARY   */
                             CALL SCAN;
                             NO_LOOK_AHEAD_DONE = FALSE;
                             END;
                   /*   COMPARE TOKEN WITH EACH TRANSITION SYMBOL IN    */
                   /*   READ STATE                                      */
                    DO I = I TO I+INDEX2(STATE)-1;
                   IF READ1(I) = TOKEN
                        THEN DO;   /*   FOUND IT   */
                             VAR(SP) = BCD;
                             FIXV(SP) = NUMBER_VALUE;
                             FIXL(SP) = CARD_COUNT;
                             PPSAVE(SP) = PP;
                             STATE = READ2(I);
                             NO_LOOK_AHEAD_DONE = TRUE;
                             GO TO COMP;
                             END;
                   END;
                   /*   FOUND AN ERROR   */
                   CALL ERROR ('ILLEGAL SYMBOL PAIR: ' ^^
                               VOCAB(STATE_NAME(STATE)) ^^ X1 ^^
                               VOCAB(TOKEN),1);
                   CALL STACK_DUMP;    /*  DISPLAY THE STACK   */
                   /*   TRY TO RECOVER   */
                   IF RECOVER
                        THEN DO;
                             STATE = STATE_STACK(SP);   /*   NEW STARTING PT  */
                             IF STATE = 0
                                  THEN DO;   /*   UNEXPECTED EOFILE   */
                                       CALL ERROR (END_OF_FILE,2);
                                       RETURN;
                                       END;
                             END;
                   SP = SP-1;   /*   STACK AT SP CONTAINS JUNK   */
                   END;
              ELSE
         IF STATE > MAXP#
              THEN DO;   /*   APPLY PRODUCTION STATE   */
                   /*   SP POINTS AT RIGHT END OF PRODUCTION   */
                   /*   MP POINTS AT LEST END OF PRODUCTION   */
                   MP = SP-INDEX2(STATE);
                   MPP1 = MP+1;
                   CALL SYNTHESIZE (STATE-MAXP#);   /*   APPLY PRODUCTION   */
                   SP = MP;   /*   RESET STACK POINTER   */
                   I = INDEX1(STATE);
                   /*   COMPARE TOP OF STATE STACK WITH TABLES   */
                   J = STATE_STACK(SP);
                   DO WHILE APPLY1(I) \= 0;
                   IF J = APPLY1(I) THEN GO TO TOP_MATCH;
                   I = I+1;
                   END;
                   /*   HAS THE PROGRAM GOAL BEEN REACHED   */
        TOP_MATCH: IF APPLY2(I) =0
                        THEN DO;   /*   YES IT HAS   */
                             COMPILING = FALSE;
                             RETURN;
                             END;
                   STATE = APPLY2(I);   /*   PICK UP THE NEXT STATE   */
                   END;
              ELSE
         IF STATE <= MAXL#
              THEN DO;   /*   LOOKAHEAD STATE   */
                    I = INDEX1(STATE);   /*   INDEX INTO THE TABLE   */
                   IF NO_LOOK_AHEAD_DONE
                        THEN DO;   /*   GET A TOKEN   */
                             CALL SCAN;
                             NO_LOOK_AHEAD_DONE = FALSE;
                             END;
                   /*   CHECK TOKEN AGAINST LEGAL LOOKAHEAD TRANSITION SYMBOLS*/
                   DO WHILE LOOK1(I) \= 0;
                   IF LOOK1(I) = TOKEN
                        THEN GO TO LOOK_MATCH;   /*   FOUND ONE   */
                   I = I+1;
                   END;
       LOOK_MATCH: STATE = LOOK2(I);
                   END;
              ELSE DO;   /*   PUSH STATE   */
                   SP = SP+1;   /*   PUSH A NON-TERMINAL ONTO THE STACK   */
                   IF SP = STACKSIZE
                        THEN DO;
                             CALL ERROR (OVERFLOW,2);
                             RETURN;
                             END;
                   /*   PUSH A STATE # INTO THE STATE_STACK   */
                   STATE_STACK(SP) = INDEX2(STATE);
                   /*   GET NEXT STATE                        */
                   STATE = INDEX1(STATE);
                   END;
         END;   /*   OF COMPILE LOOP   */

         END COMPILATION_LOOP;

PRINT_TIME:
   PROCEDURE (TEXT, TIME);
   /* PRINT TEXT FOLLOWED BY TIME, WHICH IS IN MILLISECONDS */
      DECLARE TEXT CHARACTER, TIME FIXED;
      K = TIME;
      I = K / 60000;
      J = K MOD 60000 / 1000;
      K = K MOD 1000;
      CALL PRINTLINE (TEXT ^^ I ^^ ':' ^^ J ^^ '.' ^^ K,-1);
   END PRINT_TIME;

   /*   E X E C U T I O N   S T A R T S   H E R E                          */

   DECLARE TIME_START FIXED,
           TIME_INIT FIXED,
           TIME_COMPILE FIXED,
           TIME_FINISH FIXED;

   TIME_START = RUNTIME;           /* GET TIME(CPU) STARTED*/
   CALL INITIALIZE;
   TIME_INIT = RUNTIME;     /* TIME TO INITIALIZE */
   CALL COMPILATION_LOOP;
   TIME_COMPILE = RUNTIME;     /* TIME TO COMPILE THE PROGRAM*/
   CONTROL(BYTE('E')) = FALSE;
   CONTROL(BYTE('B')) = FALSE;
   SUBTITLE = '';
   IF CONTROL(BYTE('S')) THEN CALL SYMBOLDUMP;
   ELSE EJECT_PAGE;
   /* NOW ENTER THE VALUE OF NDESCRIPT                                        */
   CALL EMITLABEL (NDESC,5);            /* GENERATE LABEL */
   IF CONTROL(BYTE('A')) THEN
      OUTPUT(DATAFILE) = '$' ^^ NDESC ^^ ':'; /* LABEL FOR ASSEMBLER */
   CALL EMITDATAWORD (DSP-1);           /* PUT DOWN NUMBER OF DESC'S */
   IF CONTROL(BYTE('A')) THEN
      OUTPUT(DATAFILE) = 'S=.;';           /* START STRING SEGMENT */
   /* ADD THE DESCRIPTORS TO THE DATA SEGMENT                                 */
   DO I = 0 TO DSP-1;
      IF CONTROL(BYTE('A')) THEN
         OUTPUT(DATAFILE)='       BYTE (9)'^^DESCL(I)^^ '(27)' ^^DESCA(I)^^ ';';
      CALL OUTPUT_DATAWORD (SHL(DESCL(I),27) + DESCA(I), DP);
      CALL EMITLABEL (I,3);
      DP = DP + 1;
   END;
   /* FINAL CODE FOR SYSTEM INTERFACE                                         */
   CALL EMITINST (4,0,0,0,0,0);
   CALL FLUSH_DATA_BUFFER;
   CALL FLUSH_LABELS;
   DO WHILE CODE_TAIL \= CODE_HEAD;
      CALL OUTPUT_CODEWORD;
      END;
   CALL OUTPUT_CODEWORD;
   CALL FLUSH_CODE_BUFFER;
   IF CONTROL(BYTE('A')) THEN
      DO;
         OUTPUT (CODEFILE) = '       END $0;';
         /* COPY CODE FILE TO END OF DATA FILE */
         CODESTRING = INPUT(CODEFILE);
         DO WHILE LENGTH(CODESTRING) > 0;
            OUTPUT(DATAFILE) = CODESTRING;
            CODESTRING = INPUT(CODEFILE);
         END;
         OUTPUT (CODEFILE) = ' ';
      END;

   FILE(RELFILE) = SYMB_TYPE + 2;      /* GENERATE EXTERNAL REFS */
   FILE(RELFILE) = "(3)040000000000";
   FILE(RELFILE) = "(3)600000000000" + RADIX50 ('XPLLIB');
   FILE(RELFILE) = LIBRARY;
   FILE(RELFILE) = START_TYPE + 1;
   FILE(RELFILE) = "(3)200000000000";
   FILE(RELFILE) = "(3)400000" + STARTLOC;
   FILE(RELFILE) = END_TYPE + 2;
   FILE(RELFILE) = "(3)240000000000";
   FILE(RELFILE) = "(3)400000" + PP;
   FILE(RELFILE) = DP;

   TIME_FINISH = RUNTIME;   /* TIME TO DO ALL BUT FINAL STATS */
   CALL PRINTLINE (SUBSTR(X70, 0, 40) ^^ 'C O M P I L E R   S T A T I S T I C S',-1);
   CALL PRINTLINE (CARD_COUNT ^^ ' LINES CONTAINING ' ^^ STATEMENT_COUNT ^^
      ' STATEMENTS WERE COMPILED.',0);
   IF ERROR_COUNT = 0 THEN CALL PRINTLINE ('NO ERRORS WERE DETECTED.',-1);
   ELSE IF ERROR_COUNT > 1 THEN
      CALL PRINTLINE (ERROR_COUNT ^^ ' ERRORS (' ^^ SEVERE_ERRORS
      ^^ ' SEVERE) WERE DETECTED.',-1);
   ELSE IF SEVERE_ERRORS = 1 THEN CALL PRINTLINE ('ONE SEVERE ERROR WAS DETECTED.',-1);
      ELSE CALL PRINTLINE ('ONE ERROR WAS DETECTED.',-1);
    IF PREVIOUS_ERROR > 0 THEN
       CALL PRINTLINE ('LAST ERROR WAS ON LINE ' ^^ PREVIOUS_ERROR ,-1);
   CALL PRINTLINE (PP ^^ ' WORDS OF PROGRAM, ' ^^ DP-DSP ^^ ' WORDS OF DATA, AND ' ^^
      DSP ^^ ' WORDS OF DESCRIPTORS.  TOTAL CORE REQUIREMENT ' ^^ PP+DP ^^
      ' WORDS.',-1);

/* NOW COMPUTE TIMES AND PRINT THEM */
   TIME_INIT = TIME_INIT - TIME_START;
   TIME_COMPILE = TIME_COMPILE - TIME_START;
   TIME_FINISH = TIME_FINISH - TIME_START;

   CALL PRINT_TIME ('TOTAL TIME IN COMPILER    = ',TIME_FINISH);
   CALL PRINT_TIME ('INITIALIZATION TIME       = ',TIME_INIT);
   CALL PRINT_TIME ('ACTUAL COMPILATION TIME   = ',TIME_COMPILE - TIME_INIT);
   CALL PRINT_TIME ('POST-COMPILATION CLEAN-UP = ',TIME_FINISH-TIME_COMPILE);

   IF CONTROL(BYTE('D')) THEN CALL DUMPIT;
EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF EOF