ASSEMBLER:
DO;

 DECLARE /*OPERANDS PROCESSED BY CASE ON OPERATOR*/
   LB1(1) BYTE, HB1 BYTE,
   VAL1(1) ADDRESS AT (.LB1),
   (LB2,HB2) BYTE,
   VAL2(1) ADDRESS AT (.LB2);
   /*VAL1 AND LB1 ARE EQUIVALENT,
     VAL2 AND LB2 ARE EQUIVALENT,*/

 DECLARE (STRING$TMP, /* FOR REVERSING STRINGS */
   FORMAL$FLAG,  /* TO HANDLE FORMAL PARAM USED AS LABELS */
   REV$FLAG /* TO MARK INSTRUCTIONS REQUIRING REV STRINGS */
            ) BYTE;

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

 DECLARE /*FLAGS FOR CASE ON OPERATOR*/ INFO BYTE;

 DECLARE BP BYTE, MAXBP LITERALLY '8',
   (BLKTYP,ASMSUP)(MAXBP) BYTE;

 DECLARE NP BYTE,MAXNP LITERALLY '5',
   (MACXPN,MACSUB) BYTE,
   (MACBOD,MACPTR,MACPRM,SYMTOP,SYMBOT)(MAXNP) ADDRESS,
   MACPT ADDRESS AT (.MACPTR(0)),
   MACRO BASED MACPT BYTE, LINKP ADDRESS, LINK BASED LINKP ADDRESS;

 DECLARE (MACDEF,PRMNO)BYTE,
   MACNAM ADDRESS,
   (MACADR BASED MACNAM) (1) ADDRESS,
   MACEND ADDRESS, ENDMAC BASED MACEND BYTE,
   DUNMAC ADDRESS, DUMMY BASED DUNMAC BYTE;

 DECLARE FREMEM ADDRESS, MEM BASED FREMEM BYTE, SYMAX ADDRESS;

 DECLARE PASS BYTE; /* THE PASS COUNTER:
                        PASS 1 SYMBOL RESOLUTION
                        PASS 2 LISTING OUTPUT
                        PASS 3 OBJECT CODE OUTPUT
                        PASS 4 COMBINES PASSES 2 AND 3 */

 DECLARE /*BLOCK NUMBERS FOR IDENTIFIER SCOPING*/
   RESERVED LITERALLY '1',
   GLOBAL LITERALLY '2',
   LOCAL LITERALLY '0';

 DECLARE /*THE CODE BUFFER*/
   CODSIZ LITERALLY '17', CODMAX LITERALLY '16', /*CODSIZ -1 */
   (CODTOP,CODLEN,CODCHK,CODEND) BYTE,
   CODE (CODSIZ) BYTE, CODLOC ADDRESS;

 DECLARE /*THE SYMBOL TABLE POINTERS*/
   (SYM,LOC) ADDRESS,
   (LOCVAL BASED LOC) ADDRESS,
   SYMSTR BASED SYM BYTE, (SYMTAB BASED LOC) (1) BYTE;

 DECLARE /*'LOOKUP' POINTERS*/
   (UPPER,LOWER) ADDRESS, (I,J) BYTE,
   (DST BASED UPPER, SRC BASED LOWER) ADDRESS;

 DECLARE /*OPERATOR STACK*/
   OSP BYTE, OPRL LITERALLY '7', OPR(OPRL) BYTE;

 DECLARE UND LITERALLY '0', /* AN UNDEFINED IDENTIFIER */
         FRM LITERALLY '1', /* A MACRO FORMAL PARAMETER */
         IDN LITERALLY '2', /* A DEFINED IDENTIFIER */
         MUL LITERALLY '3', /* A MULTIPLY IDENTIFIER */
         SET LITERALLY '4', /* A REDEFINABLE IDENTIFIER */
         STR LITERALLY '5', /* A STRING */
         COD LITERALLY '6', /* A (MACHINE CODE SYMBOL) STRING */
         ABS LITERALLY '7', /* AN ABSOLUTE VALUE */
         MAC LITERALLY '32'; /* A MACRO NAME */

 DECLARE /* SOME CHARACTER TYPES*/
   NUMERIC LITERALLY '8',ALPHANUMERIC LITERALLY '>7';

 DECLARE (TOKEN,RTOKEN,TYPE,CHAR,PREV$CHAR,RADIX,
   SIGN,PRINTV,COLUMN) BYTE;

 DECLARE (LC,PRINTN) ADDRESS;

 DECLARE CR LITERALLY '15Q',LF LITERALLY '12Q',TAB LITERALLY '11Q',
   ENDS LITERALLY '1',COMMA LITERALLY '6',LPAR LITERALLY '2',
   RPAR LITERALLY '3';

 DECLARE IBP BYTE;/*IBP IS THE INPUT BUFFER INDEX:IT IS USED
   IN THE ASSEMBLER ONLY TO RESCAN THE PREVIOUS TEXT CHARACTER, HOWEVER
   IBP IS CONSISTANTLY DECREMENTED IN THE ASSEMBLER TO PERMIT THE
   ADDITION OF LINE BUFFERING,*/

 DECLARE ERCHAR BYTE; /* THE ERROR FLAG FOR THE CURRENT SOURCE
   LINE (USUALLY CONTAINS A BLANK) */

 DECLARE /*THE OPERAND STACK*/
   SP BYTE, SPMAX LITERALLY '8',
   (VAL,ST)(SPMAX) ADDRESS, (TYP,LEN)(SPMAX) BYTE,
   VL ADDRESS AT (.VAL(0)),
   (SYMBOL BASED VL) (1) BYTE,
   STKMAX LITERALLY '51', STKTOP ADDRESS;
     /*STACK IS DECLARED NEAR INITIALIZE */

   /*VAL(0)CONTAINS THE ADDRESS OF THE CURRENT SYMBOL'S
     VALUE(OR PRINT NAME,IF-IT IS AN IDENTIFIER),DESCRIBED BY
     ST(0),TYP(0)AND LEN(0), VAL(SP) CONTAINS THE
     ADDRESS OF THE PREVIOUS SYMBOL, VALUES ARE ADDED TO THE
     STACK BY INCREMENTING SP THEN MOVING (VAL,ST,TYP,LEN)
     (0) TO (VAL,ST,TYP,LEN)(SP),VALUES ARE REMOVED BY
     MOVING (VAL,ST,TYP,LEN)(SP)TO (VAL,ST,TYP,LEN)(0)
     THEN DECREMENTING SP,*/

 /* -------------------------------------------------- */

 DECLARE KEYBOARD LITERALLY 'KBY AND 7FH';

 KBY:
   PROCEDURE BYTE EXTERNAL;

   END KBY;

 /* -------------------------------------------------- */

 READER:
   PROCEDURE BYTE EXTERNAL;

   END READER;

 DECLARE TEXT LITERALLY 'READER AND 7FH';

 /* -------------------------------------------------- */

 PRINT:
   PROCEDURE (CHAR) EXTERNAL;
     DECLARE CHAR BYTE;

   END PRINT;

 /* -------------------------------------------------- */

 PUNCH:
   PROCEDURE(CHAR) EXTERNAL;
     DECLARE CHAR BYTE;

   END PUNCH;

 /* -------------------------------------------------- */

 LO:
   PROCEDURE (CHAR) EXTERNAL;
     DECLARE CHAR BYTE;

   END LO;

 /* -------------------------------------------------- */

 IOCHK:
   PROCEDURE BYTE EXTERNAL;

   END IOCHK;

 /* -------------------------------------------------- */

 MEMTOP:
   PROCEDURE ADDRESS EXTERNAL;

   END MEMTOP;

 /* -------------------------------------------------- */

 LIST:
   PROCEDURE (CHAR);
     DECLARE (CHAR,I,J) BYTE;

     I = (CHAR = TAB AND (7- (COLUMN AND 7)));
     IF CHAR = TAB THEN CHAR =' ';
     DO J=0 TO I;
       IF CHAR = CR THEN COLUMN = 0;
       IF COLUMN <72 THEN
       DO;
         COLUMN = COLUMN + (1 AND CHAR >=' ');
         CALL LO (CHAR);
       END;
      END;
     END LIST;

 /* -------------------------------------------------- */

 ASSEMBLE:
   PROCEDURE;

   ERROR:
     PROCEDURE (ERCODE);
       DECLARE ERCODE BYTE;

       IF NOT ROR(ASMSUP(0),-1) AND ERCHAR = ' '
       THEN ERCHAR = ERCODE;
     END ERROR;

 /* -------------------------------------------------- */

   QUARTEL:
     PROCEDURE (NAME,ITEM) BYTE;
       DECLARE NAME ADDRESS,(VECTOR BASED NAME) (1) BYTE,
         (ITEM,I) BYTE;

       I = VECTOR(SHR(ITEM,1));
       IF ITEM THEN I = ROR(I,4);
       RETURN I AND 0FH;
     END QUARTEL;

 /* -------------------------------------------------- */

   /* RETURN HEX CHAR */

   HEX:
     PROCEDURE (VALUE) BYTE;
       DECLARE (VALUE) BYTE;

       IF(VALUE := (VALUE AND 0FH) + '0') > '9'
          THEN VALUE = VALUE + 7;
       RETURN VALUE;
     END HEX;

 /* -------------------------------------------------- */

   /* PUNCH BYTE VALUE AS TWO HEX CHARACTERS */

   PUNCH$HEX:
     PROCEDURE (VALUE);
       DECLARE VALUE BYTE;

       CALL PUNCH (HEX (ROR(VALUE,4)));
       CALL PUNCH (HEX (VALUE));
     END PUNCH$HEX;

 /* -------------------------------------------------- */

   /*LIST BYTE VALUE AS TWO HEX CHARACTERS*/

   LIST$HEX:
     PROCEDURE (VALUE);
       DECLARE VALUE BYTE;

       CALL LIST (HEX(ROR(VALUE,4)));
       CALL LIST (HEX (VALUE));
     END LIST$HEX;

 /* -------------------------------------------------- */

   /*PUNCH A BINARY RECORD (0 => DATA RECORD,1=>END RECORD)*/

   PUNCH$RECORD:
     PROCEDURE (TYPE);
     DECLARE (TYPE,I) BYTE;

     CALL PUNCH (':');
     CALL PUNCH$HEX (CODLEN);
     CALL PUNCH$HEX (HIGH(CODLOC));
     CALL PUNCH$HEX (LOW (CODLOC));
     CALL PUNCH$HEX (TYPE);
     DO I =1 TO CODLEN;
       CALL PUNCH$HEX (CODE(I));
     END;
     CODCHK=CODCHK-HIGH (CODLOC)-LOW (CODLOC)-TYPE-CODLEN;
     CALL PUNCH$HEX (CODCHK);
     CALL PUNCH (CR);
     CALL PUNCH (LF);
     CODCHK,CODLEN = 0;
     CODTOP = CODMAX;
   END PUNCH$RECORD;

 /* -------------------------------------------------- */

   /*INSTR-VERIFY AND OPERATE ON MACHINE INSTRUCTION
   THE SINGLE ARGUMENT SPECIFIES ACTIONS AS FOLLOWS:
     BITS 1 AND 0 QUALIFY THE REGISTERS REQUIRED:
       00 => NO REGISTER
       01 => ANY EVEN REGISTER
       10 => ANY REGISTER
       11 => EITHER REGISTER B OR REGISTER D
     BIT 2 = 1 CAUSES THE REGISTER FIELD TO BE SHIFTED LEFT 3 BITS
     BIT 3 = 1 CAUSES THE ARGUMENT TO THE INSTRUCTION TO
       BE CHECKED FOR A VALUE OF -256 TO 255
     BITS 7 THROUGH 4 SPECIFY THE SUCCESSOR STATE,IF NON-ZERO,
       RELATIVE TO THE FIRST CODE STATE NUMBER */

 INSTR:
   PROCEDURE (FIELDS);
     DECLARE FIELDS BYTE;

     IF (FIELDS AND 3) <> 0 THEN
     DO;
       IF HB2 <> 0 OR LB2 > 7 OR (FIELDS AND LB2) OR ((FIELDS AND 3) = 3
       AND LB2 > 2) THEN
       DO;
         LB2 = 0;
         CALL ERROR ('R');
       END;
       IF ROR (FIELDS,2) THEN LB2 = ROL(LB2,3);
       LB1(0) = LB1(0) OR LB2;
     END;
     /*TEST VALUE BETWEEN -256 AND 255*/
     IF SHR(FIELDS,3) THEN IF HB2 + 1 > 1 THEN CALL ERROR ('V');
     /*34 IS THE STATE NUMBER OF THE FIRST MACHINE
       INSTRUCTION STATE (<LOAD INDEX HEAD>)*/
     IF(RTOKEN:=SHR(FIELDS,4)+34)=34 THEN
     DO;
       IF HB1 > 0 THEN CALL ERROR ('V');
       TYPE = COD;
     END;
   END INSTR;

 /* -------------------------------------------------- */

    MOVE$ENTRY:
      PROCEDURE;

        DO I = 0 TO 4;
          /* I.E., FOR MACBOD, MACPTR, SYMTOP, SYMBOT */
          DST = SRC;
          UPPER = UPPER + ROL (MAXNP,1);
          LOWER = LOWER + ROL (MAXNP,1);
       END;
     END MOVE$ENTRY;

 /* -------------------------------------------------- */

   /*EXIT BLOCK IS CALLED BY ENDM, ENDIF, AND END.
     IT IS ALSO CALLED BY ENTER$BLOCK IF STACK OVERFLOW
     OCCURS. NESTING ERRORS ( FORCED BY ENTER$BLOCK ON
     STACK OVERFLOW ) ARE RESOLVED BY ADJUSTMENT
     OF THE STACK BACK TO THE 'MAIN' PROGRAM. */

   EXIT$BLOCK:
     PROCEDURE (TYPE);
       DECLARE TYPE BYTE;

       IF TYPE <> BLKTYP(0) THEN
       DO;
         CALL ERROR ('N' + (5 AND TYPE = 255));
           /* 'S' IF TYPE IS 'ERROR' (FROM ENTER BLOCK) */
         IF BP > 1 THEN BP = 2;
         IF NP > 1 THEN NP = 2;
       END;

       IF NP > 1 AND BLKTYP(0) > 0 /* NOT A CONDITIONAL BLOCK */
         OR TYPE = 2 /* MAIN PROGRAM BLOCK */ THEN
       DO;
         FREMEM = MACPRM(0);
         LOWER = NP + NP + (UPPER := .MACBOD);
         CALL MOVE$ENTRY;
         /* THE ABOVE ASSIGNMENT AND CAL IS EQUIVALENT TO

         MACBOD(0) = MACBOD(NP);
         MACPRM(0) = MACPRM(NP);
         MACPTR(0) = MACPTR(NP);
         SYMTOP(0) = SYMTOP(NP);
         SYMBOT(0) = SYMBOT(NP); */

         MACXPN = (NP := NP - 1) > 1;
         MACDEF = FALSE;
       END;

       IF BP > 1 THEN
       DO;
         ASMSUP(0) = ASMSUP(BP);
         BLKTYP(0) = BLKTYP(BP);
         BP = BP - 1;
       END;

     END EXIT$BLOCK;

 /* -------------------------------------------------- */

   /*ENTER BLOCK IS CALLED ON ENTRY OF THE
     ASSEMBLER, AND BY MACRO, MACRO CALL, AND IF. */

   ENTER$BLOCK:
     PROCEDURE (TYPE);
     DECLARE TYPE BYTE;

     IF CODEND THEN RETURN; /* PREVENT NEW BLOCKS AFTER END */
     IF (BP := BP + 1) >= MAXBP THEN CALL EXIT$BLOCK (255); /* ERROR */
     ELSE
     DO;
       IF TYPE <> 0 /* CONDITIONAL BLOCK */ THEN
       DO;
         IF (NP := NP + 1) >= MAXNP THEN CALL EXIT$BLOCK (255);
         ELSE;
         DO;
         UPPER = NP + NP + (LOWER := .MACBOD);
         CALL MOVE$ENTRY;
         /* THE ABOVE ASSIGNMENT AND CALL IS EQUIVALENT TO

         MACBOD(NP) = MACBOD(0);
         MACPRM(NP) = MACPRM(0);
         MACPTR(NP) = MACPTR(0);
         SYMBOT(NP) = SYMBOT(0);
         SYMTOP(NP) = SYMTOP(0); */

         IF (MACPRM(0) := FREMEM) <= SYMAX THEN
           CALL ERROR ('T');
         ELSE
         DO;
           IF PASS = 1 THEN SYMAX = LINKP + (LINK := 2);
           IF LINKP > SYMAX THEN CALL ERROR ('T');
           ELSE
           DO;
           SYMBOT(0) = LINKP + 2;
           SYMTOP(0) = LINKP + LINK;
           IF TYPE <> 3 /* MACRO DEF */ THEN LINKP = SYMTOP(0);
         END;
      END;
    END;
  END;
    ASMSUP(BP) = ASMSUP(0);
    BLKTYP(BP) = BLKTYP(0);
    BLKTYP(0) = TYPE;
  END;

END ENTER$BLOCK;

 /* -------------------------------------------------- */

   /*GNC RETURNS THE NEXT CHARACTER OF THE TEXT IF IBP=1,
     AND THE PREVIOUS TEXT CHARACTER IF IBP=0,*/

   GNC:
     PROCEDURE BYTE;

       IF IBP <> 0 THEN
       DO;
         IF MACXPN THEN
         DO;
 GET$MACRO:
           MACPTR(0) = MACPTR(0) + 1;
           IF (PREV$CHAR := MACRO) = 26 /*DNDM EXPONTOKEN*/
             THEN GOTO NO$ECHO$EXIT;
           IF PREV$CHAR > 7FH THEN
           DO;
             IF MACSUB THEN
             DO;
               /*END OF PARAMETER-RESUME SCAN OF MACRO BODY*/
               MACSUB = FALSE;
               MACPTR(0) = MACBOD(0);
             END;
             ELSE
             DO;
               /*SUBSTITUTE ACTUAL PARAMETER FOR FORMAL*/
               MACBOD(0) = MACPTR(0);
               MACPTR(0) = MACPRM(0);
               MACSUB = TRUE;
               DO WHILE (PREV$CHAR := PREV$CHAR - 1) >= 80H;
                 MACPTR(0) = MACPTR(0) - (MACRO AND 7FH);
               END;
             END;
             GOTO GET$MACRO;
           END;
         END;
         ELSE
         DO WHILE (PREV$CHAR := TEXT) = 0
           OR PREV$CHAR = LF OR PREV$CHAR = 7FH;
         END;
         IF NOT PASS THEN CALL LIST (PREV$CHAR);
         IF MACDEF AND PASS = 1 THEN
         DO;
           MACRO = PREV$CHAR;
           MACDEF = (MACPTR(0) := MACPTR(0) + 1) < FREMEM;
        END;
        END;
 NO$ECHO$EXIT:
        IBP = 1;
        RETURN CHAR := PREV$CHAR;
      END GNC;

 /* -------------------------------------------------- */

   /*CTYPE RETURNS THE NEXT INPUT CHARACTER IN 'CHAR',
     AND A VALUE INDICATING THE CHARACTER CLASS:

         0=>THE CHARACTER IS ILLEGAL OUTSIDE STRINGS OR COMMENTS
         1=>HORIZONTAL TAB OR BLANK
         2=>;
         3=>:
         4=>CARRIAGE RETURN
         5=>AN OPERATOR,IE.()+,-/*
         6=>$
         7=>'
         8=>DECIMAL NUMERAL
         9=>ALPHABETIC OR QUESTION MARK OR COMMERCIAL AT*/

   CTYPE:
     PROCEDURE BYTE;

       /*'CLASS CONTAINS A HEXADECIMAL CLASS NUMBER
         FOR EACH OF THE ASCII CHARACTERS BELOW 'QUESTION MARK'
         IN THE COLLATION SEQUENCE.*/

       DECLARE CLASS (*) BYTE DATA (

         00H,00H,00H,00H,10H,00H,40H,00H,
         00H,00H,00H,00H,00H,00H,00H,00H,
         01H,00H,06H,70H,55H,55H,55H,50H,
         88H,88H,88H,88H,88H,23H,00H,00H );

       DECLARE I BYTE;

       IF GNC>'Z'THEN RETURN 0;
       IF CHAR >'>'THEN RETURN 9;
       RETURN QUARTEL(.CLASS,CHAR);
     END CTYPE;

 /* -------------------------------------------------- */

 /* MOVE DATA TO TOP OF MEMORY */

   MOVE:
     PROCEDURE (BOTTOM,TOP) ADDRESS;
       DECLARE (BOTTOM,TOP) ADDRESS,SRC BASED TOP BYTE,
                DST BASED FREMEM BYTE;

       DO WHILE BOTTOM <= TOP;
         IF FREMEM <= SYMAX THEN CALL ERROR ('T');
         ELSE
         DO;
           DST = SRC;
           FREMEM = FREMEM - 1;
         END;
         TOP = TOP - 1;
       END;
       RETURN FREMEM;
   END MOVE;

 /* -------------------------------------------------- */

   /*STACK CREATES A ZERO LENGH ENTRY IN THE OPERAND STACK
     OF THE TYPE SPECIFIED IN CALL.*/

   STACK:
     PROCEDURE (TYPE);
       DECLARE TYPE BYTE;

       IF (SP := SP + 1) >= SPMAX THEN
       DO;
         SP = 2;
         CALL ERROR ('S');
       END;
       VAL(SP) = VAL(0);
       ST(SP) = ST(0);
       TYP(SP) = TYP(0);
       LEN(SP) = LEN(0);
       VAL(0) = VAL(0)+LEN(0);
       ST(0) = 0;
       TYP(0) = TYPE;
       LEN(0) = 0;
       RETURN;
     END STACK;

 /* -------------------------------------------------- */

   /*PUSH APPENDS THE BYTE VALUE PASSED TO THE TOP OPERAND
     STACK ENTRY'S VALUE,AND INCREMENTS THE SYMBOL LENGTH.*/

   PUSH:
     PROCEDURE (DATUM);
       DECLARE DATUM BYTE;
       DECLARE STADD ADDRESS AT (.VAL(0));
       DECLARE (ST BASED STADD) (1) BYTE;

       IF VAL(0) + LEN(0) < STKTOP THEN
       DO;
         ST(LEN(0)) = DATUM;
         LEN(0) = LEN(0) + 1;
       END;
       ELSE CALL ERROR ('T');
       RETURN;
     END PUSH;

 /* -------------------------------------------------- */

   /*DELETE REMOVES THE TOP ELEMENT OF THE OPERAND STACK,AND
     DEALLOCATES STORAGE FOR ITS VALUE.*/

   DELETE:
     PROCEDURE;

       VAL(0) = VAL(SP);
       ST(0) = ST(SP);
       TYP(0) = TYP(SP);
       LEN(0) = LEN(SP);
       SP=SP-1;
     END DELETE;

 /* -------------------------------------------------- */

   /*STACKAN COPIES THE INPUT TEXT INTO THE TOP OPERAND STACK
     ENTRY'S VALUE UNTIL A NON-ALPHANUMERIC CHARACTER IS
     ENCOUNTERED.*/

   STACKAN:
     PROCEDURE (TYPE);
       DECLARE TYPE BYTE;

       CALL STACK (TYPE);
       IBP = IBP - 1;
       DO WHILE CTYPE ALPHANUMERIC;

       /*CONVERT FROM LOWER TO UPPER CASE*/

         IF CHAR > 040H THEN CHAR = CHAR AND 0DFH;
         CALL PUSH (CHAR);
       END;
       IBP = IBP - 1;
     END STACKAN;

 /* -------------------------------------------------- */

 /* RETURN PRECEDENCE OF TOKEN.*/

   PRECEDENCE:
     PROCEDURE (TOKEN) BYTE;
       DECLARE TOKEN BYTE,I BYTE,PRC (*) BYTE DATA (
         00H,00H,67H,61H,76H,56H,34H,73H,
         77H,11H,11H,11H,11H,00H,11H,11H,
         11H,11H,11H,11H,11H,11H,11H);

       RETURN QUARTEL(.PRC,TOKEN);
     END PRECEDENCE;

 /* -------------------------------------------------- */

 /* LOOK UP THE IDENTIFIERS AT STACK TOP AND RETURN ITS
    TYPE,IF THE IDENTIFIER DOES NOT EXIST,RETURN
    'UNDEFINED.ST(SP)IS SET TO THE SYMBOL TABLE LOCATION
    WHERE THE IDENTIFIER IS,OR SHOULD BE INSERTED,ONLY THE
    IDENTIFIERS IN THE BLOCK SPECIFIED ARE TESTED.*/

   LOOKUP:
     PROCEDURE (BLOCK) BYTE;
       DECLARE STADD ADDRESS AT (.ST(0));
       DECLARE (BLOCK,FLAG) BYTE, (STTYP BASED STADD) (1) BYTE;

       LOWER = SYMBOT(BLOCK);
       UPPER,LOC = SYMTOP(BLOCK);
       DO WHILE
         LOC <> (SYM := LOWER + SHR(UPPER - LOWER AND 0FFF0H,1));
         LOC = SYM;
         SYM = VAL(0);
         DO WHILE (FLAG := SYMTAB(0) - SYMSTR) = 0;
           LOC = LOC + 1;
           IF (SYM := SYM + 1) = VAL(0) + LEN(0) THEN
           DO;
             IF LEN(0) = 5 OR SYMTAB(0) = ' ' THEN
             DO;
               ST(0) = LOC - LEN(0);
               TYP(0) = STTYP(5);
     IF (TYP(0)=42 OR TYP(0)=34 OR TYP(0)=19 OR TYP(0)=20 OR TYP(0)=24 OR
                   TYP(0)=29 OR TYP(0)=30 OR TYP(0)=34 OR TYP(0)=42)
               THEN REV$FLAG =TRUE;
               RETURN (TYP(0));
             END;
             ELSE GOTO CONTINUE$SEARCH;
           END;
         END;
 CONTINUE$SEARCH:
         LOC = LOC - SYM + VAL(0);
         IF ROL(FLAG,1) THEN LOWER = LOC;
         ELSE UPPER = LOC;
       END;
       ST(0) = UPPER;
       RETURN UND;
     END LOOKUP;

 /* -------------------------------------------------- */

   /*ENTER THE IDENTIFIER AT STACK TOP IN THE SYMBOL TABLE
     BLOCK SPECIFIED,USING THE VALUE SPECIFIED.*/

   ENTER:
     PROCEDURE (VALUE,TYPE,BLOCK);
       DECLARE VALUE ADDRESS,(TYPE,BLOCK) BYTE;
       DECLARE STAD ADDRESS AT (.ST(0));
       DECLARE (STVAL BASED STAD) (1) ADDRESS, (STSYM BASED STAD) (1) BYTE, I BYTE;

       IF SP <> 1 THEN CALL ERROR('F');
       ELSE
       DO;
         IF TYP(0) = UND THEN
         DO; /*ENTER THE PRINT NAME */
           IF (UPPER := (LOWER := SYMAX) + 8) >= FREMEM
             THEN
           DO;
             CALL ERROR('T');
             GOTO DELETE$PRINT$NAME;
           END;
           ELSE
           DO;
             SYMAX = UPPER;
             IF BLKTYP(0) <> 3 /* MACDEF */ THEN LINKP = LINKP + 8;
             SYMTOP(BLOCK) = SYMTOP(BLOCK) + 8;
             LOC = SYMBOT(BLOCK) - 2; /*IE.THE BLOCK'S LENGTH*/
             LOCVAL = LOCVAL + 8;
             /*NOW UPDATE THE SYMBOL TABLE POINTERS FOR ANY OTHER
               BLOCKS ABOVE THE SPECIFIED BLOCK.*/
             DO WHILE (BLOCK := BLOCK + 1 AND BLOCK <= NP ) <> RESERVED;
               SYMBOT(BLOCK) = SYMBOT(BLOCK) + 8;
               SYMTOP(BLOCK) = SYMTOP(BLOCK) + 8;
             END;
             /*MOVE ALL TABLE ENTRIES UP TO MAKE SPACE FOR NEW ENTRY*/
             DO WHILE LOWER >= ST(0);
               DST = SRC;
               UPPER = UPPER - 2;
               LOWER = LOWER - 2;
             END;
             /*INSERT THE PRINT NAME(BLANK PADDED),
               SYMBOL TYPE AND VALUE.*/
             DO I = 0 TO 4;
               BLOCK = ' ';
              IF I < LEN(0) THEN BLOCK = SYMBOL(I);
               STSYM(I) = BLOCK;
             END;
           TYP(0) = TYPE;
           END;
         END;
         ELSE
         IF (TYP(0) <> SET OR TYP(0) <> TYPE) AND PASS = 1 THEN TYP(0) =MUL;
         ELSE IF TYP(0) <> SET THEN
           IF STVAL(3) <> VALUE THEN
             CALL ERROR ('M' + (TYP(0) <> MUL AND 3));
                /* M IF MULTIPLY DEFINED, OTHERWISE P */
         IF (STSYM(5) := TYP(0)) = TYPE THEN STVAL(3) = VALUE;
DELETE$PRINT$NAME:
         CALL DELETE;
       END;
     END ENTER;

 /* -------------------------------------------------- */

 /*VALUE RETURNS THE VALUE OF THE OPERAND AT STACK TOP
   VAL1 IS ALTERED*/

   VALUE:
     PROCEDURE ADDRESS;

       VAL1(0) = 0;
       IF SP < 1 THEN CALL ERROR ('F');
       ELSE
       DO;
         IF TYP(0) = UND AND NP > 1 THEN TYP(0) = LOOKUP (GLOBAL);
         IF TYP(0) = UND THEN CALL ERROR ('U');
         ELSE
         DO;
           IF TYP(0) <= SET THEN
           DO;
             VAL(0) = ST(0) + 6;
             LEN(0) = 2;
             END;
           ELSE IF LEN(0) > 2 THEN CALL ERROR ('V');
           LB1(0) = SYMBOL(0);
           IF LEN(0) > 1 THEN HB1 = SYMBOL(1);
           IF TYP(0) = STR AND REV$FLAG AND LEN(0) = 2 THEN
           DO; /* FOR 2 BYTE STRINGS THAT REQUIRE REVERSING */
             STRING$TMP = LB1(0);
             LB1(0) = HB1;
             HB1 = STRING$TMP;
           END;
         END;
         CALL DELETE;
       END;
       RETURN VAL1(0);
     END VALUE;

 /* -------------------------------------------------- */

   DECLARE   /*THE OPERAND STACK ONLY AFTER THE PROCEDURES*/
     STK (STKMAX) BYTE;

     DECLARE CINFO (*) BYTE DATA (

       00000000B, 10000000B, 00000000B, 00000000B,
       00001111B, 00001111B, 00000000B, 00001111B,
       00001101B, 00001111B, 00001101B, 00001101B,
       00001111B, 00001111B, 00001111B, 00001111B,
       00001111B, 00001111B, 01000000B, 00000001B,
       01001101B, 10000000B, 10000000B, 10000000B,
       00000001B, 10000001B, 10000000B, 01000000B,
       01000000B, 00000001B, 00000001B, 01000000B,
       01000000B, 01000000B, 01000111B, 00000111B,
       00000111B, 00000111B, 00010111B, 01000111B,
       00000111B, 01000111B, 00110111B, 00000101B );

   /*INITIALIZE FOR PASS*/

   ERCHAR = ' ';
   PREV$CHAR = CR;
   CODLEN,CODCHK,CODEND,IBP,SP,BP,NP,LEN(0),TYP(0),OSP,OPR(1) = 0;
   CODTOP = CODMAX;
   MACDEF,MACXPN,MACSUB = FALSE;
   CALL ENTER$BLOCK (2 /*MAIN*/);
     /* SO THAT RESERVED WORDS ARE IN BLOCK 0 */
   LC,CODLOC = 0;
   STKTOP = (VAL(0) := .STK ) + STKMAX;
   TOKEN = 1;

   OPDCHECK: /*OPERANDS BRANCH HERE BEFORE DROPPING
               THROUGH TO SCAN, */

     IF TOKEN=0 THEN CALL ERROR ('E');
     TOKEN=0;

   SCAN:     /*THE INPUT FOR THE NEXT SYMBOL'S INITIAL CHAR
               THEN GO TO THE APPROPRIATE SYMBOL PROCESSOR.*/

     DO CASE CTYPE;

       /* ILLEGAL CHARACTERS */

       IF NOT (CHAR=26 /*ENDM EXPN TOKEN*/ AND MACXPN) THEN
       DO;
         CALL ERROR ('I');
         GO TO SCAN;
       END;

       /* HORIZONTAL TAB OR BLANK */

       GO TO SCAN;

       /* COMMENT*/

       DO;
         DO WHILE CTYPE <> 4; /*CARRIAGE RETURN*/
         END;
         CHAR=ENDS;
       END;

       /*COLON*/

       DO;
         TOKEN = ENDS; /*ONLY TO INDICATE AN OPERATOR WAS SCANNED*/
         I = LOCAL;
         IF GNC <> ':' THEN IBP = IBP - 1;
         ELSE IF NP > 1 THEN TYP(0) = LOOKUP(I := GLOBAL);
         IF ASMSUP(0) THEN
           DO;
           IF NOT (FORMAL$FLAG) THEN CALL DELETE;
           END;
         ELSE CALL ENTER (LC,IDN,I);
         GO TO SCAN;
       END;

       /*CARRIAGE RETURN*/

       CHAR=ENDS;

       /*OPERATOR I.E.,()+,-/*
         NOTE THAT THE TOKENS ARE A FUNCTION OF THE CHARACTER VALUE*/

       DO;
         IF(CHAR='+' OR CHAR='-')
           AND TOKEN<>0 AND TOKEN <> RPAR THEN
           CHAR=CHAR+3; /*UNARY*/
         CHAR=CHAR-'('+LPAR;
       END;

       /* $= ASSIGN THE CURRENT LOCATION COUNTER TO VALUE */

       DO;
         CALL STACK(ABS);
         CALL PUSH (LOW(LC));
         CALL PUSH (HIGH(LC));
         GO TO OPDCHECK;
       END;

       /* '=COLLECT STRING*/

       DO;
         CALL STACK(STR);
         DO WHILE GNC<>CR;
           IF CHAR=''''THEN
           DO;
             IF GNC<>''''THEN GO TO ENDSTRING;
           END;
           CALL PUSH(CHAR);
         END;
         CALL ERROR ('B'); /*STRING DIDN'T BALENCE.*/
 ENDSTRING:
         IBP=IBP-1;
         GO TO OPDCHECK;
       END;

       /* CONVERT NUMERIC STRING TO VALUE */

       DO;
         CALL STACKAN(ABS);
         RADIX = SYMBOL (LEN(0) := LEN(0) - 1); /*LAST CHARACTER IN NUMBER*/
         IF RADIX = 'H' THEN RADIX = 16;
         IF RADIX = 'O' THEN RADIX = 8;
         IF RADIX = 'Q' THEN RADIX = 8;
         IF RADIX = 'B' THEN RADIX = 2;
         IF RADIX = 'D' THEN RADIX = 10;
         IF RADIX > 16 /* I.E., AN ALPHANUMERIC CHARACTER */
            THEN RADIX = 10;
         ELSE LEN(0) = LEN(0) - 1;
         VAL1(0) = 0;
         DO I = 0 TO LEN(0);
           IF (CHAR := SYMBOL(I) - '0') > 9 THEN CHAR = CHAR - 7;
           IF CHAR >= RADIX THEN
           DO;
             CHAR = 0;
             CALL ERROR ('I');
           END;
           VAL1(0) = VAL1(0)*RADIX + CHAR;
         END;
         LEN(0) = 0;
         CALL PUSH(LOW(VAL1(0)));
         CALL PUSH(HIGH(VAL1(0)));
         GOTO OPDCHECK;
       END;

       /*COLLECT AN IDENTIFIER AND CHECK FOR RESERVED WORD*/

       DO;
         VAL2(0) = MACPTR(0) - 1; /*MAY REPLACE A FORMAL PARAMETER*/
         CALL STACKAN (UND);
         IF LEN(0) > 5 THEN LEN(0) = 5; /*TRUNCATE IF NECESSARY*/
         IF LOOKUP (RESERVED) = UND THEN IF LOOKUP (LOCAL) = FRM THEN
         DO;
           /* REPLACE A MACRO FORMAL PARAMETER WITH ITS PARAMETER NUM*/
           MACPTR(0) = (LOC := VAL2(0)) + 2;
           SYMTAB(0) = VALUE OR 80H; /*PARAMETER NUMBER*/
           SYMTAB(1) = CHAR; /*MOVE TERMINATOR DOWN TO PARAMETER NO.*/
           FORMAL$FLAG = TRUE;
         END;
         IF TYP(0) = 23 /*ENDM*/ THEN MACEND = VAL2(0);
         /* NOW CHECK FOR NESTED MACRO CALLS*/
         IF TYP(0) = UND AND NP > 1 THEN
           IF LOOKUP(GLOBAL) <> MAC THEN TYP(0) = LOOKUP(LOCAL);
         IF (CHAR := TYP(0)) >= 31 THEN TYP(0) = IDN; /*MACHINE INSTRS*/
         IF TYP(0) > 10 THEN CALL DELETE; /* DIRECTIVES ARITH OPS*/
         IF CHAR > SET THEN GOTO STACKOPR; /*ANY OPERATOR*/
         GOTO OPDCHECK;
       END;

     END; /*OF CASE ON SYMBOL'S INITIAL CHARACTER*/

 /* -------------------------------------------------- */

       /*OPERATORS FALL THROUGH THE SCAN INITIAL CASE STATEMENT HERE*/

   STACKOPR:

     IF ASMSUP(0) AND CINFO(CHAR) < 80H THEN GOTO SCAN;
       /* IGNORE TOKENS OTHER THAN IF,END,ENDM,
          ENDM EXPN,AND CR DURING CONDITIONAL ASSEMBLY
          AND MACRO DEFINITION */
     IF PRECEDENCE (TOKEN := CHAR) >
       PRECEDENCE (RTOKEN := OPR(OSP)) OR TOKEN = LPAR THEN
     DO;
       OPR(OSP := OSP + 1) = TOKEN;
       GOTO SCAN;
     END;
     IF RTOKEN = 0 THEN RTOKEN = TOKEN;
     ELSE OSP = OSP - 1;
     IF ( INFO := CINFO(RTOKEN) ) THEN VAL2(0) = VALUE;
       /*VAL1,VAL2 SET TO TOP OF STACK */
     IF (INFO := ROR(INFO,1)) THEN VAL1(0) = VALUE;
       /*VAL1 SET TO TOP OF STACK */
     TYPE = ABS;
     DO CASE RTOKEN;

 /* -------------------------------------------------- */

      /* CASE0 - SYMBOL=BEGINNING OF STATEMENT */

      ;  /*CAN'T GET HERE*/

 /* -------------------------------------------------- */

       /*CASE1-SYMBOL = END OF STATEMENT*/

 END$STATEMENT:

       DO;
         SYM = VAL(0) + LEN(0);
         IF ASMSUP(0) THEN SYM = .STK; /*DELETE ALL VALUES FOR THIS STMT*/
         DO WHILE SP > 0;
           IF TYP(0) <> COD THEN CALL ERROR ('Q');
           CALL DELETE;
         END;

         /* PRODUCE LISTING IF PASS=2 OR PASS=4 */

         LOC = .STK;
         I = TRUE;
         IF NOT PASS THEN
         DO WHILE I;
           CALL LIST (CR);
           CALL LIST (0);
           CALL LIST (ERCHAR);
           CALL LIST (' ');
           IF (PRINTV := PRINTV OR LOC <> SYM) THEN
           DO;
             CALL LIST$HEX (HIGH (PRINTN));
             CALL LIST$HEX (LOW  (PRINTN));
           END;
           PRINTV = SHL(NOT PRINTV AND TRUE,2);
           DO J = 0 TO PRINTV;
             /*IE.ONE BLANK IF ADDRESS FIELD WAS PRINTED,
              OTHERWISE, FIVE BLANKS */
             CALL LIST (' ');
           END;
           DO J=1 TO 4;
             IF LOC < SYM THEN CALL LIST$HEX (SYMTAB(0));
             ELSE
             DO;
               CALL LIST (' ');
               CALL LIST (' ');
             END;
             I = (LOC := LOC + 1) < SYM;
           END;
           CALL LIST (' ');
           CALL LIST (LF);
           IF (IOCHK AND 0C0H) <> 0 THEN
           DO;
           /*IE.LIST DEVICE OTHER THAN TTY */
           CALL LIST (CR);
           CALL LIST (0);
           CALL LIST (TAB);
           CALL LIST (TAB);
         END;
         PRINTN = PRINTN + 4;
       END;

       /* PRODUCE OBJECT CODE IF PASS=3 OR PASS=4*/

       IF PASS > 2 THEN
       DO;
         LOC = .STK;
         IF LC <> CODLOC + CODLEN OR CODEND THEN
         DO;
           IF CODLEN <> 0 THEN CALL PUNCH$RECORD(0);
           CODLOC = LC;
         END;
         DO WHILE LOC < SYM;
           IF CODLEN = CODTOP THEN
           DO;
             CALL PUNCH$RECORD(0);
             CODLOC = CODLOC + CODMAX;
           END;
           CODCHK = CODCHK - (CODE(CODLEN := CODLEN + 1) := SYMTAB(0));
           LOC = LOC + 1;
         END;
         IF CODEND THEN CALL PUNCH$RECORD(1);
       END;
       PRINTN,LC = LC + SYM - .STK;
       PRINTV, FORMAL$FLAG, REV$FLAG = FALSE;
       ERCHAR = ' ';
       OSP = 0;
       ASMSUP(0) = ASMSUP(0) > 0;
         /* ASMSUP = 0 => FALSE,
                     1 => TRUE AFTER CURRENT LINE
                   255 => TRUE */
       IF CODEND THEN RETURN;
       GOTO SCAN;
     END;

 /* -------------------------------------------------- */

     /* CASE 2 -SYMBOL =( */

     GOTO CHECK$BALANCE;

 /* -------------------------------------------------- */

     /* CASE 3-SYMBOL=) */

 CHECK$BALANCE:
       DO;
         IF NOT (RTOKEN = LPAR AND TOKEN = RPAR) THEN CALL ERROR ('B');
         IF TYP(0) = COD THEN LEN(0) = 1; /* PARENTHESIIZED INSTR ARE
                     COERCED TO THE LEFT BYTE */
         IF TOKEN = RPAR THEN GOTO SCAN;
       END;

 /* -------------------------------------------------- */

       /* CASE 4-SYMBOL=* */

       VAL1(0) = VAL1(0)*VAL2(0);

 /* -------------------------------------------------- */

       /* CASE 5- + */

       VAL1(0) = VAL1(0)+VAL2(0);

 /* -------------------------------------------------- */

       /* CASE 6-SYMBOL=) */

       CALL ERROR ('F');

 /* -------------------------------------------------- */

       /* CASE 7-SYMBOL=- */

       VAL1(0) = VAL1(0)-VAL2(0);

 /* -------------------------------------------------- */

       /* CASE 8-SYMBOL=UNARY+ */

       ;

 /* -------------------------------------------------- */

       /* CASE 9- SYMBOL=/ */

         VAL1(0) = VAL1(0)/VAL2(0);

 /* -------------------------------------------------- */

       /*CASE 10 -SYMBOL=<UNARY-> */

       NEGATE:
       VAL1(0) = -VAL1(0);

 /* -------------------------------------------------- */

       /*CASE 11 -SYMBOL =NOT */

       VAL1(0) = NOT VAL1(0);

 /* -------------------------------------------------- */

       /* CASE 12-SYMBOL=AND */

       VAL1(0) = VAL1(0) AND VAL2(0);

 /* -------------------------------------------------- */

       /* CASE 13-SYMBOL=OR  */

       VAL1(0) = VAL1(0) OR VAL2(0);

 /* -------------------------------------------------- */

       /* CASE 14-SYMBOL=XOR */

       VAL1(0) = VAL1(0) XOR VAL2(0);

 /* -------------------------------------------------- */

       /* CASE 15-SYMBOL=MOD */

        VAL1(0) = VAL1(0) MOD VAL2(0);

 /* -------------------------------------------------- */

       /* CASE 16 -SYMBOL=SHL */

       IF LB2 <> 0 THEN VAL1(0) = SHL(VAL1(0),LB2);

 /* -------------------------------------------------- */

       /* CASE 17 -SYMBOL=SHR */

       IF LB2 <> 0 THEN VAL1(0) = SHR(VAL1(0),LB2);

 /* -------------------------------------------------- */

       /* CASE 18 -SYMBOL=DB */

       DO;
         IF TYP(0) <> STR AND TYP(0) <> COD THEN
         DO;
           VAL1(0) = VALUE;
           IF HB1 - 1 < 254 THEN CALL ERROR ('V');
           INFO = 00100010B;
         END;
         TYP(0),TYPE = COD;
       END;

 /* -------------------------------------------------- */

       /* CASE 19-SYMBOL=DS */

       DO;
         PRINTV = TRUE;
         LC = LC + VAL2(0);
         GOTO STACKOPR;
       END;

 /* -------------------------------------------------- */

       /* CASE 20 -SYMBOL=DW */

       TYPE = COD;

 /* -------------------------------------------------- */

       /* CASE 21 -SYMBOL=END */

       DO;
        LC, VAL1(0) = 0;
        IF SP > 0 THEN LC = VALUE;
         PRINTV, CODEND = TRUE;
         ASMSUP(0) = FALSE; /* ENABLE ERROR CODE FOR PRINTING 'N' ERROR */
         MACPRM(0) = FREMEM; /* ALLOCTAE MEMORY FOR MACROS */
         CALL EXIT$BLOCK (2); /* MAIN */
        END;

 /* -------------------------------------------------- */

       /* CASE 22 -SYMBOL=ENDIF */

       CALL EXIT$BLOCK (0 /*CONDITIONAL*/);

 /* -------------------------------------------------- */

       /* CASE 23 -SYMBOL=ENDM */

END$MACRO$DEFINITION:

       IF NOT (BLKTYP(0) = 0 AND ASMSUP(0)) THEN
       DO;
           IF PASS = 1 AND MACDEF THEN
           DO;
             ENDMAC = 26 /*ENDM EXPN TOKEN*/;
               /* MARK END OF MACRO BODY*/
             MACPRM(0), MACADR(0) = MOVE(SYMAX, MACEND);
           END;
           CALL EXIT$BLOCK (3); /*MACRO DEF */
       END;

 /* -------------------------------------------------- */

      /* CASE 24 -SYMBOL=EQU */

      DO;
        CALL ENTER (VAL1(0),IDN,LOCAL);
        PRINTV = TRUE;
      END;

 /* -------------------------------------------------- */

       /* CASE 25 -SYMBOL=IF */

       DO;
         CALL ENTER$BLOCK (0); /*CONDITIONAL*/
         ASMSUP(0) = BP > 1 AND (ASMSUP(0) OR VAL1(0) = 0 AND TRUE);
       END;

 /* -------------------------------------------------- */

       /* CASE 26 -SYMBOL=ENDM EXPN*/

END$MACRO$EXPANSION:

       DO;
         CALL EXIT$BLOCK (1/*MACRO*/);
         GOTO END$STATEMENT;
       END;

 /* -------------------------------------------------- */

       /* CASE 27 -SYMBOL=MACRO DEFINITION HEAD*/

 MACRO$DEFINITION:

       DO;
         MACNAM = ST(0) + 6;
         IF PASS=1 THEN CALL ENTER (DUNMAC, MAC, LOCAL);
         ELSE
         DO;
           IF MACADR(0) = DUNMAC THEN CALL ERROR ('T');
           IF TYP(0) = MUL THEN CALL ERROR('M'); /*MUL MACRO*/
           CALL DELETE;
         END;
         CALL ENTER$BLOCK (3); /*MACRO DEF*/
             /* ALLOCATE TEMPORARY BLOCK FOR FORMALS.*/

         CHAR = 28; /*MDF*/ /*STACK MACRO DEFINITION*/
         PRMNO = 0;
       END;

 /* -------------------------------------------------- */

       /* CASE 28-SYMBOL=MACRO DEFINITION*/

       DO;
         IF SP <> 0 THEN
         DO;
           IF PASS = 1 THEN CALL ENTER(PRMNO := PRMNO + 1, FRM, LOCAL);
           ELSE CALL DELETE;
         END;
         IF TOKEN = ENDS THEN
         DO;
           ASMSUP(0) = TRUE;
           MACPTR(0) = SYMAX;
           MACDEF = (ERCHAR = ' ');
         END;
       END;

 /* -------------------------------------------------- */

       /* CASE 29 -SYMBOL=ORG*/

       DO;
         PRINTV = TRUE;
         LC = VAL1(0);
       END;

 /* -------------------------------------------------- */

       /* CASE 30 -SYMBOL=SET*/

       DO;
         I = LOCAL;
         IF TYP(0) = UND AND NP > 1 THEN
         DO;
           IF LOOKUP(I := GLOBAL) <> SET AND TYP(0) <> UND THEN
             CALL ERROR ('M');
           IF TYP(0) <> SET THEN TYP(0) = LOOKUP (I := LOCAL);
         END;
         CALL ENTER (VAL1(0),SET,I);
         PRINTV = TRUE;
       END;

 /* -------------------------------------------------- */

       /* CASE 31- SYMBOL=TITLE*/

       /* TREAT TITLE AS A COMMENT*/

       DO WHILE SP > 0;
         CALL DELETE;
       END;

 /* -------------------------------------------------- */

       /* CASE 32 -SYMBOL=MACRO CALL HEAD*/

       DO;
         IF TOKEN = 27 /*MDH*/ THEN GOTO MACRO$DEFINITION;
         MACNAM = FREMEM; /*SAVE NEXT BLOCK'S MCPRM*/
         RTOKEN = 33 /*MCL*/;
         GOTO MACRO$CALL;
       END;

 /* -------------------------------------------------- */

       /* CASE 33 -SYMBOL=MACRO CALL*/

 MACRO$CALL:

       DO;
         IF SP < 2 THEN CALL STACK (STR);
         /* INSERT NULL STRING FOR NULL PARM */
         IF TYP(0) <> STR THEN
         DO;
           LOC = VALUE; /*ALSO SETS VAL1 TO VALUE*/
           CALL STACK(STR);
           CALL PUSH ('0');
           CALL PUSH (HEX (ROR(HB1,4)));
           CALL PUSH (HEX(HB1));
           CALL PUSH (HEX (ROR(LB1(0),4)));
           CALL PUSH (HEX(LB1(0)));
           CALL PUSH ('H');
         END;
         CALL PUSH ((I := LEN(0)) + 1 OR 80H);
         VAL2(0) = MOVE(VAL(0),VAL(0) + I);
         CALL DELETE;
         IF TOKEN = ENDS THEN
         DO;
           IF SP <> 1 THEN CALL ERROR ('F');
           ELSE
           DO;
           DECLARE PRMEND BYTE DATA (80H) ,PRMEND$LAST BYTE DATA (81H);
           FREMEM = MOVE (.PRMEND,.PRMEND$LAST);
             CALL ENTER$BLOCK (1); /*MACRO*/
             MACPRM(0) = MACNAM;
             MACPTR(0) = VALUE;
             MACXPN = TRUE;
             IF ERCHAR = 'F' THEN GO TO END$MACRO$EXPANSION;
               /* GIVE UP ON FORMAT ERROR */
           END;
         END;
       END;

 /* -------------------------------------------------- */

       /* CASE 34 -SYMBOL=<LOAD INDEX HEAD>*/

       CALL INSTR (10000101B);

 /* -------------------------------------------------- */

       /* CASE 35 -SYMBOL=<INDEX REFERENCE INSTRUCTION>*/

       CALL INSTR (00000101B);

 /* -------------------------------------------------- */

       /* CASE 36 -SYMBOL=<LOAD INDEXED INSTRUCTION>*/

       CALL INSTR (00000111B);

 /* -------------------------------------------------- */

       /* CASE 37 -SYMBOL=<REGISTER INSTRUCTION>*/

       CALL INSTR (00000010B);

 /* -------------------------------------------------- */

       /* CASE 38 -SYMBOL=<IMMEDIATE INSTRUCTION>*/

       CALL INSTR (00001000B);

 /* -------------------------------------------------- */

       /* CASE 39 -SYMBOL=<IMMEDIATE HEAD>*/

       CALL INSTR (01000110B);

 /* -------------------------------------------------- */

       /* CASE 40 -SYMBOL=<REGISTER REFERENCE INSTRUCTION>*/

       CALL INSTR (00000110B);

 /* -------------------------------------------------- */

       /* CASE 41 -SYMBOL=<MOVE REGISTER HEAD>*/

       CALL INSTR (00110110B);

 /* -------------------------------------------------- */

       /* CASE 42-SYMBOL=<BRANCH INSTRUCTION>*/

       CALL INSTR (00000000B);

 /* -------------------------------------------------- */

       /* CASE 43 -SYMBOL=<ZERO OPERAND INSTRUCTION>*/

       CALL INSTR (00000000B);

 /* -------------------------------------------------- */

     END;  /* OF CASE ON RTOKEN */

 /* -------------------------------------------------- */

	    IF PRINTV THEN PRINTN = VAL1(0);
     IF (INFO AND 00011110B) <> 0 THEN CALL STACK (TYPE);
     DO I = 0 TO 3;
       IF(INFO := ROR (INFO,1)) THEN CALL PUSH (LB1 (I));
     END;
     IF ROR (INFO,1) THEN
     DO;
       IF TOKEN = COMMA THEN CHAR = RTOKEN;
     END;
     GOTO STACKOPR;

   END ASSEMBLE;

 /* -------------------------------------------------- */

 DECLARE /*THE SYMBOL TABLE */

     SYMFIX LITERALLY '858', SYMBOL$TABLE (SYMFIX) BYTE INITIAL (

       'A    ', 03 /* MUL */,  007H, 0,
       'ACI  ', 38 /* IMM */,  0CEH, 0,
       'ADC  ', 37 /* REG */,  088H, 0,
       'ADD  ', 37 /* REG */,  080H, 0,
       'ADI  ', 38 /* IMM */,  0C6H, 0,
       'ANA  ', 37 /* REG */,  0A0H, 0,
       'AND  ', 12 /* OPR */,  000H, 0,
       'ANI  ', 38 /* IMM */,  0E6H, 0,
       'B    ', 03 /* MUL */,  000H, 0,
       'C    ', 03 /* MUL */,  001H, 0,
       'CALL ', 42 /* BRI */,  0CDH, 0,
       'CC   ', 42 /* BRI */,  0DCH, 0,
       'CM   ', 42 /* BRI */,  0FCH, 0,
       'CMA  ', 43 /* ZOP */,  02FH, 0,
       'CMC  ', 43 /* ZOP */,  03FH, 0,
       'CMP  ', 37 /* REG */,  0B8H, 0,
       'CNC  ', 42 /* BRI */,  0D4H, 0,
       'CNZ  ', 42 /* BRI */,  0C4H, 0,
       'CP   ', 42 /* BRI */,  0F4H, 0,
       'CPE  ', 42 /* BRI */,  0ECH, 0,
       'CPI  ', 38 /* IMM */,  0FEH, 0,
       'CPO  ', 42 /* BRI */,  0E4H, 0,
       'CZ   ', 42 /* BRI */,  0CCH, 0,
       'D    ', 03 /* MUL */,  002H, 0,
       'DAA  ', 43 /* ZOP */,  027H, 0,
       'DAD  ', 35 /* XRF */,  009H, 0,
       'DB   ', 18 /* POP */,  000H, 0,
       'DCR  ', 40 /* RRP */,  005H, 0,
       'DCX  ', 35 /* XRF */,  00BH, 0,
       'DI   ', 43 /* ZOP */,  0F3H, 0,
       'DS   ', 19 /* POP */,  000H, 0,
       'DW   ', 20 /* POP */,  000H, 0,
       'E    ', 03 /* MUL */,  003H, 0,
       'EI   ', 43 /* ZOP */,  0FBH, 0,
       'END  ', 21 /* POP */,  000H, 0,
       'ENDIF', 22 /* POP */,  000H, 0,
       'ENDM ', 23 /* POP */,  000H, 0,
       'EQU  ', 24 /* POP */,  000H, 0,
       'H    ', 03 /* MUL */,  004H, 0,
       'HLT  ', 43 /* ZOP */,  076H, 0,
       'IF   ', 25 /* POP */,  000H, 0,
       'IN   ', 38 /* IMM */,  0DBH, 0,
       'INR  ', 40 /* RRF */,  004H, 0,
       'INX  ', 35 /* XRF */,  003H, 0,
       'JC   ', 42 /* BRI */,  0DAH, 0,
       'JM   ', 42 /* BRI */ , 0FAH, 0,
       'JMP  ', 42 /* BRI */,  0C3H, 0,
       'JNC  ', 42 /* BRI */ , 0D2H, 0,
       'JNZ  ', 42 /* BRI */,  0C2H, 0,
       'JP   ', 42 /* BRI */,  0F2H, 0,
       'JPE  ', 42 /* BRI */,  0EAH, 0,
       'JPO  ', 42 /* BRI */,  0E2H, 0,
       'JZ   ', 42 /* BRI */,  0CAH, 0,
       'L    ', 03 /* MUL */ , 005H, 0,
       'LDA  ', 42 /* BRI */,  03AH, 0,
       'LDAX ', 36 /* LDX */,  00AH, 0,
       'LHLD ', 42 /* BRI */,  02AH, 0,
       'LXI  ', 34 /* LXH */ , 001H, 0,
       'M    ', 03 /* MUL */,  006H, 0,
       'MACRO', 27 /* MDF */,  000H, 0,
       'MOD  ', 15 /* OPR */,  000H, 0,
       'MOV  ', 41 /* MRH */ , 040H, 0,
       'MVI  ', 39 /* MIH */,  006H, 0,
       'NOP  ', 43 /* ZOP */,  000H, 0,
       'NOT  ', 11 /* OPR */,  000H, 0,
       'OR   ', 13 /* OPR */,  000H, 0,
       'ORA  ', 37 /* REG */ , 0B0H, 0,
       'ORG  ', 29 /* POP */,  000H, 0,
       'ORI  ', 38 /* IMM */,  0F6H, 0,
       'OUT  ', 38 /* IMM */,  0D3H, 0,
       'PCHL ', 43 /* ZOP */ , 0E9H, 0,
       'POP  ', 35 /* XRF */,  0C1H, 0,
       'PSW  ', 03 /* MUL */,  006H, 0,
       'PUSH ', 35 /* XRF */,  0C5H, 0,
       'RAL  ', 43 /* ZOP */,  017H, 0,
       'RAR  ', 43 /* ZOP */,  01FH, 0,
       'RC   ', 43 /* ZOP */,  0D8H, 0,
       'RET  ', 43 /* ZOP */,  0C9H, 0,
       'RLC  ', 43 /* ZOP */,  007H, 0,
       'RM   ', 43 /* ZOP */,  0F8H, 0,
       'RNC  ', 43 /* ZOP */,  0D0H, 0,
       'RNZ  ', 43 /* ZOP */,  0C0H, 0,
       'RP   ', 43 /* ZOP */,  0F0H, 0,
       'RPE  ', 43 /* ZOP */,  0E8H, 0,
       'RPO  ', 43 /* ZOP */,  0E0H, 0,
       'RRC  ', 43 /* ZOP */,  00FH, 0,
       'RST  ', 40 /* RRF */,  0C7H, 0,
       'RZ   ', 43 /* ZOP */,  0C8H, 0,
       'SBB  ', 37 /* REG */,  098H, 0,
       'SBI  ', 38 /* IMM */,  0DEH, 0,
       'SET  ', 30 /* POP */,  000H, 0,
       'SHL  ', 16 /* OPR */,  000H, 0,
       'SHLD ', 42 /* BRI */,  022H, 0,
       'SHR  ', 17 /* OPR */,  000H, 0,
       'SP   ', 03 /* MUL */,  006H, 0,
       'SPHL ', 43 /* ZOP */,  0F9H, 0,
       'STA  ', 42 /* BRI */,  032H, 0,
       'STAX ', 36 /* LDX */,  002H, 0,
       'STC  ', 43 /* ZOP */,  037H, 0,
       'SUB  ', 37 /* REG */,  090H, 0,
       'SUI  ', 38 /* IMM */,  0D6H, 0,
       'TITLE', 31 /* POP */,  000H, 0,
       'XCHG ', 43 /* ZOP */,  0EBH, 0,
       'XOR  ', 14 /* OPR */,  000H, 0,
       'XRA  ', 37 /* REG */,  0A8H, 0,
       'XRI  ', 38 /* IMM */,  0EEH, 0,
       'XTHL ', 43 /* ZOP */,  0E3H, 0 );

 DECLARE GLOBAL$IDENTIFIERS ADDRESS INITIAL (0);

   /* THIS WILL BE SET NON-ZERO WHEN THE FIRST SYMBOL IS ENTERED,
      INVALIDATING THE START-UP MESSAGE CONTAINED IN USYM */

 DECLARE USYM (72H) BYTE INITIAL (CR,CR,LF,LF,
   '    8080 MACRO ASSEMBLER,VERSION 4.1',CR,LF,LF,0);
   /*USYM VECTOR SIZE IS ADJUSTED TO ALIGN VARIABLES
     THE MESSAGE WILL ONLY BE WRITTEN ON START-UP.THE
     SPACE IS THEN USED FOR THE USER SYMBOLS.*/

 /* -------------------------------------------------- */

      /* PROGRAM START */
 I = 0;
 IF GLOBAL$IDENTIFIERS = 0 THEN
 DO WHILE (J := USYM (I := I + 1)) <> 0;
   CALL PRINT (J);
 END;

 DO WHILE TRUE;
   CALL PRINT (CR);
   CALL PRINT (LF);
   CALL PRINT (LF);
   CALL PRINT ('P');
   CALL PRINT ('=');
   CALL PRINT (PASS := KEYBOARD);
   IF (PASS := PASS - '0') > 0 AND PASS < 5 THEN
   DO;
     MACDEF, FORMAL$FLAG, REV$FLAG, ASMSUP(0) = FALSE;
     PRINTN, PRINTV = 0;
     SYMBOT(0) = .SYMBOL$TABLE;
     SYMTOP(0), LINKP = .GLOBAL$IDENTIFIERS;
     IF PASS = 1 THEN
     DO;
       FREMEM = (DUNMAC := MEMTOP) - 1;
       DUMMY = 26; /* DUMMY MACRO CALLED FOR MACRO DEF'S IN ERROR */
       DUNMAC = FREMEM;
       SYMAX = SYMTOP(0);
     END;
     CALL PRINT (CR);
     CALL PRINT (LF);
     CALL PRINT (LF);

     CALL ASSEMBLE;

   END;
 END;
END ASSEMBLER;
