ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/MISC/PLM80.ARK/PLM82.FOR

Text File | 1989-04-05 | 190KB | 6,050 lines

C***********************************************************************
C
C         8 0 8 0   P L / M   C O M P I L E R ,   P A S S - 2
C                                 PLM82
C                              VERSION 2.0
C                             JANUARY, 1975
C
C                          COPYRIGHT (C) 1975
C                          INTEL CORPORATION
C                          3065 BOWERS AVENUE
C                          SANTA CLARA, CALIFORNIA 95051
C
C  MODIFYED BY JEFF OGDEN (UM), DECEMBER 1977.
C
C***********************************************************************
C
C
C         P A S S - 2     E R R O R    M E S S A G E S
C
C  ERROR                     MESSAGE
C  NUMBER
C  ------  --- -------------------------------------------------------
C
C   101     REFERENCE TO STORAGE LOCATIONS OUTSIDE THE VIRTUAL MEMORY
C           OF PASS-2.  RE-COMPILE PASS-2 WITH LARGER 'MEMORY' ARRAY.
C
C   102         "
C
C   103     VIRTUAL MEMORY OVERFLOW.  PROGRAM IS TOO LARGE TO COMPILE
C           WITH PRESENT SIZE OF 'MEMORY.'  EITHER SHORTEN PROGRAM OR
C           RECOMPILE PASS-2 WITH A LARGER VIRTUAL MEMORY.
C
C   104     (SAME AS 103).
C
C
C   105     $TOGGLE USED IMPROPERLY IN PASS-2.  ATTEMPT TO COMPLEMENT
C           A TOGGLE WHICH HAS A VALUE OTHER THAN 0 OR 1.
C
C   106     REGISTER ALLOCATION TABLE UNDERFLOW.  MAY BE DUE TO A PRE-
C
C   107     REGISTER ALLOCATION ERROR.  NO REGISTERS AVAILABLE.  MAY
C           BE CAUSED BY A PREVIOUS ERROR, OR PASS-2 COMPILER ERROR.
C
C   108     PASS-2 SYMBOL TABLE OVERFLOW.  REDUCE NUMBER OF
C           SYMBOLS, OR RE-COMPILE PASS-2 WITH LARGER SYMBOL TABLE.
C
C   109     SYMBOL TABLE OVERFLOW (SEE ERROR 108).
C
C   110     MEMORY ALLOCATION ERROR.  TOO MUCH STORAGE SPECIFIED IN
C           THE SOURCE PROGRAM (16K MAX).  REDUCE SOURCE PROGRAM
C           MEMORY REQUIREMENTS.
C
C   111     INLINE DATA FORMAT ERROR.  MAY BE DUE TO IMPROPER
C           RECORD SIZE IN SYMBOL TABLE FILE PASSED TO PASS-2.
C
C   112     (SAME AS ERROR 107).
C
C   113     REGISTER ALLOCATION STACK OVERFLOW.  EITHER SIMPLIFY THE
C           PROGRAM OR INCREASE THE SIZE OF THE ALLOCATION STACKS.
C
C   114     PASS-2 COMPILER ERROR IN 'LITADD' -- MAY BE DUE TO A
C           PREVIOUS ERROR.
C
C   115     (SAME AS 114).
C
C   116     (SAME AS 114).
C
C   117     LINE WIDTH SET TOO NARROW FOR CODE DUMP (USE $WIDTH=N)
C
C   118     (SAME AS 107).
C
C   119     (SAME AS 110).
C
C   120     (SAME AS 110, BUT MAY BE A PASS-2 COMPILER ERROR).
C
C   121     (SAME AS 108).
C
C   122     PROGRAM REQUIRES TOO MUCH PROGRAM AND VARIABLE STORAGE.
C           (PROGRAM AND VARIABLES EXCEED 16K).
C
C   123     INITIALIZED STORAGE OVERLAPS PREVIOUSLY INITIALIZED STORAGE.
C
C   124     INITIALIZATION TABLE FORMAT ERROR.  (SEE ERROR 111).
C
C   125     INLINE DATA ERROR.  MAY HAVE BEEN CAUSED BY PREVIOUS ERROR.
C
C   126     BUILT-IN FUNCTION IMPROPERLY CALLED.
C
C   127     INVALID INTERMEDIATE LANGUAGE FORMAT. (SEE ERROR 111).
C
C   128     (SAME AS ERROR 113).
C
C   129     INVALID USE OF BUILT-IN FUNCTION IN AN ASSIGNMENT.
C
C   130     PASS-2 COMPILER ERROR.  INVALID VARIABLE PRECISION (NOT
C           SINGLE BYTE OR DOUBLE BYTE).  MAY BE DUE TO PREVIOUS ERROR.
C
C   131     LABEL RESOLUTION ERROR IN PASS-2 (MAY BE COMPILER ERROR).
C
C   132     (SAME AS 108).
C
C   133     (SAME AS 113).
C
C   134     INVALID PROGRAM TRANSFER (ONLY COMPUTED JUMPS ARE ALLOWED
C           WITH A 'GO TO').
C
C   135     (SAME AS 134).
C
C   136     ERROR IN BUILT-IN FUNCTION CALL.
C
C   137     (NOT USED)
C
C   138     (SAME AS 107).
C
C   139     ERROR IN CHANGING VARIABLE TO ADDRESS REFERENCE. MAY
C           BE A PASS-2 COMPILER ERROR, OR MAY BE CAUSED BY PRE-
C           VOUS ERROR.
C
C   140     (SAME AS 107).
C
C   141     INVALID ORIGIN.  CODE HAS ALREADY BEEN GENERATED IN THE
C           SPECIFIED LOCATIONS.
C
C   142     A SYMBOL TABLE DUMP HAS BEEN SPECIFIED (USING THE $MEMORY
C           TOGGLE IN PASS-1), BUT NO FILE HAS BEEN SPECIFIED TO RE-
C           CEIVE THE BNPF TAPE (USE THE $BNPF=N CONTROL).
C
C   143     INVALID FORMAT FOR THE SIMULATOR SYMBOL TABLE DUMP (SEE
C           ERROR 111).
C
C   144     STACK NOT EMPTY AT END OF COMPILATION.  POSSIBLY CAUSED
C           BY PREVIOUS COMPILATION ERROR.
C
C   145     PROCEDURES NESTED TOO DEEPLY (HL OPTIMIZATION)
C           SIMPLIFY NESTING, OR RE-COMPILE WITH LARGER PSTACK
C
C   146     PROCEDURE OPTIMIZATION STACK UNDERFLOW.  MAY BE A
C           RETURN IN OUTER BLOCK.
C
C   147     PASS-2 COMPILER ERROR IN LOADV. REGISTER
C           STACK ORDER IS INVALID.  MAY BE DUE TO PREVIOUS ERROR.
C
C   148     PASS-2 COMPILER ERROR.  ATTEMPT TO UNSTACK TOO
C           MANY VALUES.  MAY BE DUE TO PREVIOUS ERROR.
C
C   149     PASS-2 COMPILER ERROR. ATTEMPT TO CONVERT INVALID
C           VALUE TO ADDRESS TYPE.  MAY BE DUE TO PREVIOUS ERROR.
C
C   150     (SAME AS 147)
C
C   151     PASS-2 COMPILER ERROR. UNBALANCED  EXECUTION STACK
C           AT BLOCK END.  MAY BE DUE TO A PREVIOUS ERROR.
C
C    152    INVALID STACK ORDER IN APPLY.  MAY BE DUE TO PREVIOUS
C           ERROR.
C
C
C              I M P L E M E N T A T I O N    N O T E S
C              - - - - - - - - - - - - - -    - - - - -
C    THE PL/M COMPILER IS INTENDED TO BE WRITTEN IN ANSI STANDARD
C    FORTRAN - IV, AND THUS IT SHOULD BE POSSIBLE TO COMPILE AND
C    EXECUTE THIS PROGRAM ON ANY MACHINE WHICH SUPPORTS THIS FORTRAN
C    STANDARD.  BOTH PASS-1 AND PASS-2, HOWEVER, ASSUME THE HOST
C    MACHINE WORD SIZE IS AT LEAST 31 BITS, EXCLUDING THE SIGN BIT
C    (I.E., 32 BITS IF THE SIGN IS INCLUDED).
C
C    THE IMPLEMENTOR MAY FIND IT NECESSARY TO CHANGE THE SOURCE PROGRAM
C    IN ORDER TO ACCOUNT FOR SYSTEM DEPENDENCIES.  THESE CHANGES ARE
C    AS FOLLOWS
C
C    1)   THE FORTRAN LOGICAL UNIT NUMBERS FOR VARIOUS DEVICES
C         MAY HAVE TO BE CHANGED IN THE 'GNC' AND 'WRITEL' SUBROU-
C         TINES (SEE THE FILE DEFINITIONS BELOW).
C
C     2)   THE HOST MACHINE MAY NOT HAVE THE PL/M 52 CHARACTER SET
C           0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ$=./()+-'*,<>:;
C         (THE LAST 15 SPECIAL CHARACTERS ARE
C         DOLLAR,  EQUAL,  PERIOD,  SLASH, LEFT PAREN,
C         RIGHT PAREN, PLUS,   MINUS,  QUOTE, ASTERISK,
C         COMMA, LESS-THAN, GREATER-THAN, COLON, SEMI-COLON)
C         IN THIS CASE, IT IS NECESSARY TO CHANGE THE 'OTRAN' VECTOR IN
C         BLOCK DATA TO A CHARACTER SET WHICH THE HOST MACHINE SUPPORTS
C
C     3)  ALTHOUGH THE DISTRIBUTION VERSION OF PASS-2 ASSUMES A
C        MINIMUM OF 31 BITS PER WORD ON THE HOST MACHINE, BETTER
C        STORAGE UTILIZATION IS OBTAINED BY ALTERING THE 'WDSIZE'
C        PARAMETER IN BLOCK DATA (SECOND TO LAST LINE OF THIS PROGRAM).
C        THE WDSIZE IS CURRENTLY SET TO 31 BITS (FOR THE S/360), AND
C        THUS WILL EXECUTE ON ALL MACHINES WITH A LARGER WORD SIZE.  THE
C        VALUE OF WDSIZE MAY BE SET TO THE NUMBER OF USABLE BITS IN
C        A FORTRAN INTEGER, EXCLUDING THE SIGN BIT (E.G., ON A
C        CDC 6X00, SET WDSIZE TO 44, AND ON A UNIVAC 1108, SET WDSIZE
C        TO 35).  IN GENERAL, LARGER VALUES OF WDSIZE ALLOW LARGER 8080
C        PROGRAMS TO BE COMPILED WITHOUT CHANGING THE SIZE OF THE
C        'MEM' VECTOR.
C
C     4)  THE HOST FORTRAN SYSTEM MAY HAVE A LIMITATION ON THE NUMBER
C         OF CONTIGUOUS COMMENT RECORDS (E.G. S/360 LEVEL G). IF SO,
C         INTERSPERSE THE DECLARATION STATEMENTS INTEGER I1000, INTEGER
C         I1001, ETC., AS NECESSARY TO BREAK UP THE LENGTH OF COMMENTS.
C         THE SYMBOLS I1XXX ARE RESERVED FOR THIS PURPOSE.
C
C    THERE ARE A NUMBER OF COMPILER PARAMETERS WHICH MAY HAVE TO
C    BE CHANGED FOR YOUR INSTALLATION.  THESE PARAMETERS ARE DEFINED
C    BELOW (SEE 'SCANNER COMMANDS'), AND THE CORRESPONDING DEFAULT
C    VALUES ARE SET FOLLOWING THEIR DEFINITION.  FOR EXAMPLE, THE
C                  $RIGHTMARGIN = I
C    PARAMETER DETERMINES THE RIGHT MARGIN OF THE INPUT SOURCE LINE.
C    THE PARAMETER IS SET EXTERNALLY BY A SINGLE LINE STARTING WITH
C    '$R' IN COLUMNS ONE AND TWO (THE REMAINING CHARACTERS UP TO
C    THE '=' ARE IGNORED).  THE INTERNAL COMPILER REPRESENTATION
C    OF THE CHARACTER 'R' IS 29 (SEE CHARACTER CODES BELOW), AND THUS
C    THE VALUE OF THE $RIGHTMARGIN PARAMETER CORRESPONDS TO ELEMENT 29
C    OF THE 'CONTRL' VECTOR.
C
C    1)  IF OPERATING IN  AN INTERACTIVE MODE, IT IS OFTEN
C        DESIRABLE TO MINIMIZE OUTPUT FROM PASS-2.  THUS, THE FOLLOWING
C        PARAMETERS ARE USUALLY SET AS DEFAULTS
C               $TERMINAL   =  1
C               $INPUT      =  1
C               $OUTPUT     =  1
C               $GENERATE   =  0
C               $FINISH     =  0
C
C        ALL OTHER PARAMETERS ARE THEN SELECTED FROM THE CONSOLE
C
C    2)  IF OPERATING IN BATCH MODE, A NUMBER OF DEFAULT TOGGLES ARE
C        OFTEN SET WHICH PROVIDE USEFUL INFORMATION WHEN DEBUGGING
C        THE FINAL PROGRAM
C               $TERMINAL   =  0
C               $INPUT      =  2
C               $OUTPUT     =  2
C               $GENERATE   =  1 (LINE NUMBER VS. CODE LOCATIONS)
C               $FINISH     =  1 (DECODE PROGRAM INTO MNEMONICS AT END)
C
C    3)  IF OPERATING WITH AN INTELLEC 8/80, IT MAY BE USEFUL TO SET
C        THE CODE GENERATION HEADER AT 16, PAST THE MONITOR'S VARIABLES.
C               $HEADER     = 16
C
C    RECALL, OF COURSE, THAT THE PROGRAMMER CAN ALWAYS OVERRIDE THESE
C    DEFAULT TOGGLES -- THEY ARE ONLY A CONVENIENCE TO THE PROGRAMMER.
C
C    5)  THE CHARACTERISTICS OF THE INTERMEDIATE LANGUAGE FILES
C        PRODUCED BY PASS-1 ARE MONITORED BY THE $J, $R, $U, AND
C        $Z PARAMETERS.  THESE PARAMETERS CORRESPOND TO THE SOURCE
C        AND WIDTH OF THE INTERMEDIATE CODE FILE ($J AND $R), AND
C        SOURCE AND WIDTH OF THE INTERMEDIATE SYMBOL TABLE ($U
C        AND $R).  SOME FORTRAN SYSTEMS DELETE THE LEADING CHARACTER
C        OF THE FILES PRODUCED BY OTHER FORTRAN PROGRAMS.  THE $Z
C        PARAMETER MAY BE USED TO READ EXTRA BLANKS AT THE BEGINNING OF
C        THE INTERMEDIATE FILES IF THIS BECOMES A PROBLEM ON THE HOST
C        SYSTEM.
C
C         UNDER NORMAL CIRCUMSTANCES, THESE PARAMETERS WILL NOT
C        HAVE TO BE CHANGED.  IN ANY CASE, EXPERIMENT WITH VARIOUS
C        VALUES OF THE $ PARAMETERS BY SETTING THEM EXTERNALLY BE-
C        FORE ACTUALLY CHANGING THE DEFAULTS.
C
C    THE IMPLEMENTOR MAY ALSO WISH TO INCREASE OR DECREASE THE SIZE
C    OF PASS-1 OR PASS-2 TABLES.  THE TABLES IN PASS-2 THAT MAY BE
C    CHANGED IN SIZE ARE 'MEM' AND 'SYMBOL' WHICH CORRESPOND TO
C    THE AREAS WHICH HOLD THE COMPILED PROGRAM AND PROGRAM SYMBOL
C    ATTRIBUTES, RESPECTIVELY.  IT IS IMPOSSIBLE TO PROVIDE AN
C    EXACT FORMULA WHICH RELATES THE NUMBER OF SYMBOLS HELD BY
C    THE SYMBOL TABLE SINCE THE VARIOUS TYPES OF SYMBOLS REQUIRE
C    DIFFERING AMOUNTS OF STORAGE IN THE TABLE.
C
C    1)  IN THE CASE OF THE MEM VECTOR, THE LENGTH IS DETERMINED
C        BY THE WDSIZE PARAMETER AND THE LARGEST PROGRAM WHICH YOU
C        WISH TO COMPILE.  THE NUMBER OF 8080 (8-BIT) WORDS WHICH ARE
C        PACKED INTO EACH MEM ELEMENT IS
C
C                      P = WDSIZE/8
C
C        AND THUS THE LARGEST PROGRAM WHICH CAN BE COMPILED IS
C
C                      T = P * N
C
C        WHERE N IS THE DECLARED SIZE OF THE MEM VECTOR.  TO CHANGE
C        THE SIZE OF MEM, ALTER ALL OCCURRENCES OF
C
C                         MEM(2500)
C
C        IN EACH SUBROUTINE TO MEM(N), WHERE N REPRESENTS THE NEW
C        INTEGER CONSTANT SIZE.  IN ADDITION, THE 'DATA' STATEMENT
C        IN BLOCK DATA (LAST PROGRAM SEGMENT) MUST BE CHANGED FOR THE
C        MACRO PARAMETERS BASED UPON THE CONSTANT VALUE N TO
C
C          DATA WDSIZE /31/, TWO8 /256/, MAXMEM /N/
C
C    2)  IF THE IMPLEMENTOR WISHES TO INCREASE OR DECREASE THE SIZE
C        OF THE SYMBOL TABLE, THEN ALL OCCURRENCES OF
C
C                          SYMBOL(3000)
C
C        MUST BE CHANGED TO SYMBOL(M), WHERE M IS THE DESIRED INTEGER
C        CONSTANT SIZE.  THE 'DATA' STATEMENTS FOR SYMBOL TABLE PARA-
C        METERS MUST ALSO BE ALTERED AS SHOWN BELOW.
C
C             DATA SYMAX /M/, SYTOP /0/, SYINFO /M/
C
C    GOOD  LUCK (AGAIN) ...
C
C     F  I  L  E     D  E  F  I  N  I  T  I  O  N  S
C            INPUT                        OUTPUT
C
C     FILE   FORTRAN  MTS       DEFAULT   FORTRAN  MTS      DEFAULT
C     NUM    I/O UNIT I/O UNIT  FDNAME    I/O UNIT I/O UNIT FDNAME
C
C      1       1      GUSER     *MSOURCE*   11     SERCOM   *MSINK*
C      2       2      SCARDS    *SOURCE*    12     SPRINT   *SINK*
C      3       3      3                     13     13
C      4       4      4         -PLM16##    14     14
C      5       5      5                     15     15
C      6       6      6                     16     16
C      7       7      7         -PLM17##    17     SPUNCH   -LOAD
C
C
C   ALL INPUT RECORDS ARE 80 CHARACTERS OR LESS.  ALL
C   OUTPUT RECORDS ARE 120 CHARACTERS OR LESS.
C   THE FORTRAN UNIT NUMBERS CAN BE CHANGED IN THE
C   SUBROUTINES GNC AND WRITEL (THESE ARE THE ONLY OC-
C   CURRENCES OF REFERENCES TO THESE UNITS).
C
C
C
C    0 1 2 3 4 5 6 7 8 9
C    0 0 0 0 0 0 0 0 1 1
C    2 3 4 5 6 7 8 9 0 1
C
C
C    $ = . / ( ) + - ' * , < > : ;
C    3 3 4 4 4 4 4 4 4 4 4 4 5 5 5
C    8 9 0 1 2 3 4 5 6 7 8 9 0 1 2
C
C    A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
C    1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3
C    2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7
C
C
C  SEQNO               SUB/FUNC NAME
C  16280000      SUBROUTINE INITAL
C  16560000      INTEGER FUNCTION GET(IP)
C  16740000      SUBROUTINE PUT(IP,X)
C  16960000      INTEGER FUNCTION ALLOC(I)
C  17150000      FUNCTION ICON(I)
C  17340000      INTEGER FUNCTION GNC(Q)
C  18690000      FUNCTION IMIN(I,J)
C  18760000      SUBROUTINE FORM(CC,CHARS,START,FINISH,LENGTH)
C  19040000      SUBROUTINE WRITEL(NSPACE)
C  19580000      SUBROUTINE CONOUT(CC,K,N,BASE)
C  19900000      SUBROUTINE PAD(CC,CHR,I)
C  20010000      SUBROUTINE ERROR(I,LEVEL)
C  20310000      INTEGER FUNCTION SHR(I,J)
C  20350000      INTEGER FUNCTION SHL(I,J)
C  20390000      INTEGER FUNCTION RIGHT(I,J)
C  20430000      SUBROUTINE DELETE(N)
C  20680000      SUBROUTINE APPLY(OP,OP2,COM,CYFLAG)
C  23380000      SUBROUTINE GENREG(NP,IA,IB)
C  24400000      SUBROUTINE LOADSY
C  26100000      SUBROUTINE LOADV(IS,TYPV)
C  28330000      SUBROUTINE SETADR(VAL)
C  28790000      SUBROUTINE USTACK
C  28900000      INTEGER FUNCTION CHAIN(SY,LOC)
C  29070000      SUBROUTINE GENSTO(KEEP)
C  30880000      SUBROUTINE LITADD(S)
C  32120000      SUBROUTINE DUMP(L,U,FA,FE)
C  33080000      INTEGER FUNCTION DECODE(CC,I,W)
C  34540000      SUBROUTINE EMIT(OPR,OPA,OPB)
C  36950000      SUBROUTINE PUNCOD(LB,UB,MODE)
C  38010000      SUBROUTINE CVCOND(S)
C  38730000      SUBROUTINE SAVER
C  40000000      SUBROUTINE RELOC
C  41970000      SUBROUTINE LOADIN
C  42770000      SUBROUTINE EMITBF(L)
C  43510000      SUBROUTINE INLDAT
C  44780000      SUBROUTINE UNARY(IVAL)
C  45950000      SUBROUTINE EXCH
C  46690000      SUBROUTINE STACK(N)
C  46790000      SUBROUTINE READCD
C  52230000      SUBROUTINE OPERAT(VAL)
C  66220000      SUBROUTINE SYDUMP
C
C     GLOBAL VARIABLES
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER TITLE(10),VERS
      COMMON/TITLES/TITLE,VERS
      INTEGER TERR(22)
      LOGICAL ERRFLG
      COMMON/TERRR/TERR,ERRFLG
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
      INTEGER WDSIZE,WFACT,TWO8,FACT(5)
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
      INTEGER MSSG(77)
      COMMON/MESSG/MSSG
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
C
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER GNC
C     INITIALIZE MEMORY
      CALL INITAL
C     THE FOLLOWING SCANNER COMMANDS ARE DEFINED
C     ANALYSIS         (12)
C     BPNF             (13)
C     COUNT = I        (14)
C     DELETE = I       (15)
C     EOF              (16)
C     FINISH           (17)  DUMP CODE AT FINISH
C     GENERATE         (18)
C     HEADER           (19)
C     INPUT = I        (20)
C     JFILE (CODE)= I  (21)
C     LEFTMARGIN = I   (23)
C     MAP              (24)
C     NUMERIC (EMIT)   (25)
C     OUTPUT = I       (26)
C     PRINT (T OR F)   (27)
C     QUICKDUMP = N    (28)  HEXADECIMAL DUMP
C     RIGHTMARG = I    (29)
C     SYMBOLS          (30)
C     TERMINAL         (31) (0=BATCH, 1=TERM, 2=INTERLIST)
C     USYMBOL = I      (32)
C     VARIABLES        (33)
C     WIDTH = I        (34)
C     YPAD = N         (36)  BLANK PAD ON OUTPUT
C     ZMARGIN = I      (37)  SETS LEFT MARGIN FOR I.L.
C     * = N            (47)  0 - COMPILER HANDLES STACK POINTER
C                            1 - PROGRAMMER HANDLES  STACK POINTER
C                            N > 1 (MOD 65536) N IS BASE VALUE OF SP
C
C     CONTRL(1) HOLDS THE ERROR COUNT
      DO 2 I=1,64
2     CONTRL(I) = -1
      CONTRL(1) = 0
      CONTRL(12) = 0
      CONTRL(13) = 7
      CONTRL(14) = 0
      CONTRL(15) = 120
      CONTRL(16) = 0
      CONTRL(17) = 1
      CONTRL(18) = 1
      CONTRL(19) = 0
      CONTRL(20) = 1
      CONTRL(21) = 4
      CONTRL(23) = 1
      CONTRL(24) = 1
      CONTRL(25) = 0
      CONTRL(26) = 2
      CONTRL(27) = 0
      CONTRL(28) = 1
      CONTRL(29) = 73
      CONTRL(30) = 0
      CONTRL(31) = 1
      CONTRL(32) = 7
      CONTRL(33) = 0
      CONTRL(34) = 120
      CONTRL(36) = 1
      CONTRL(37) = 2
      CONTRL(47) = 0
C
          DO 8 I=1,256
          ITRAN(I) = 1
8         CONTINUE
C
          DO 5 I=53,64
          OTRAN(I) = OTRAN(1)
5         CONTINUE
C
          DO 10 I=1,52
          J = OTRAN(I)
          J = ICON(J)
10        ITRAN(J) = I
      CALL CONOUT(0,4,8080,10)
      CALL PAD(1,1,1)
      CALL FORM(1,TITLE,1,10,10)
      CALL CONOUT(1,1,VERS/10,10)
      CALL PAD(1,40,1)
      CALL CONOUT(1,1,MOD(VERS,10),10)
      CALL WRITEL(1)
      I = GNC(0)
C     CHANGE MARGINS FOR READING INTERMEDIATE LANGUAGE
      CONTRL(23) = CONTRL(37)
      CALL WRITEL(0)
      CODLOC = CONTRL(19)
      CALL LOADSY
      CALL READCD
      IF (ERRFLG) GO TO 10100
C     MAKE SURE COMPILER STACK IS EMPTY
      IF (SP.NE.0) CALL ERROR(144,1)
C     MAKE SURE EXECUTION STACK IS EMPTY
      IF (CURDEP(1).NE.0) CALL ERROR(150,1)
      CALL RELOC
C     MAY WANT A SYMBOL TABLE FOR THE SIMULATOR
          CALL WRITEL(0)
          CALL SYDUMP
      IF (CONTRL(17).EQ.0) GO TO 90
C         DUMP THE PREAMBLE
          I = OFFSET
          OFFSET = 0
          IF (PREAMB.GT.0) CALL DUMP(0,PREAMB-1,16,1)
          OFFSET = I
C
C     DUMP THE SYMBOL TABLE BY SEGMENTS UNTIL CODLOC-1
      I = OFFSET + PREAMB
15    JP = 99999
      JL = 0
C     LOCATE NEXT INLINE DATA AT OR ABOVE I
      JN = 0
      NP = INTBAS+1
      IF (NP.GT.SYTOP) GO TO 22
          DO 20 N=NP,SYTOP
          L = SYMBOL(N)
          M = SYMBOL(L-1)
          IF (M.LT.0) GO TO 20
          IF (MOD(M,16).NE.VARB) GO TO 20
          J = IABS(SYMBOL(L))
          J = MOD(J,65536)
          IF (J.GT.JP) GO TO 20
          IF (J.LT.I) GO TO 20
C         CANDIDATE AT J
          K = MOD(M/16,16)
          IF (K.GT.2) K = 1
          K = K * (M/256)
          IF (K.EQ.0) GO TO 20
C         FOUND ONE AT J WITH LENGTH K BYTES
          JP = J
          JN = N
          JL = K
20        CONTINUE
22    CONTINUE
C     JP IS BASE ADDRESS OF NEXT DATA STMT, JL IS LENGTH IN BYTES
C
      IF (I.GE.JP) GO TO 30
C     CODE IS PRINTED BELOW
      L = JP-1
      IF (L.GT.(CODLOC-1)) L = CODLOC-1
      CALL DUMP(I,L,16,1)
30    IF (JP.GE.CODLOC) GO TO 40
C     THEN THE DATA SEGMENTS
      IF (CONTRL(30).EQ.0) GO TO 35
      CALL PAD(0,30,1)
      CALL CONOUT(1,5,JN,10)
35    CALL DUMP(JP,JP+JL-1,16,16)
40    I = JP + JL
      IF (I.LT.CODLOC) GO TO 15
90    I = CODLOC
      CALL LOADIN
      IF (CODLOC.EQ.I) GO TO 100
C     DUMP THE INITIALIZED VARIABLES
      IF (CONTRL(17).NE.0) CALL DUMP(I,CODLOC-1,16,16)
100   IF (CONTRL(13).EQ.0) GO TO 9999
C
C     PUNCH DECK
          CALL WRITEL(0)
          I = CONTRL(26)
          CONTRL(26) = CONTRL(13)
          K = OFFSET
          OFFSET = 0
          IF (PREAMB.GT.0) CALL PUNCOD(0,PREAMB-1,1)
          OFFSET = K
          J = 2
          IF (PREAMB.EQ.0) J = 3
          CALL PUNCOD(OFFSET+PREAMB,CODLOC-1,J)
          CALL PAD(0,1,1)
C         WRITE A $
          CALL PAD(1,38,1)
          CALL WRITEL(0)
          CONTRL(26) = I
C
9999  CONTINUE
C     WRITE ERROR COUNT
      J = CONTRL(26)
      K = J
10000 CONTINUE
      CALL WRITEL(0)
      CONTRL(26) = J
      I = CONTRL(1)
      IF (I.EQ.0) CALL FORM(0,MSSG,6,7,77)
      IF (I.NE.0) CALL CONOUT(2,-5,I,10)
      CALL PAD(1,1,1)
      CALL FORM(1,MSSG,8,20,77)
      IF (I.NE.1) CALL PAD(1,30,1)
      CALL PAD(0,1,1)
      CALL WRITEL(0)
C     CHECK FOR TERMINAL CONTROL OF A BATCH JOB
      IF ((J.EQ.1).OR.(CONTRL(31).EQ.0)) GO TO 10100
C     ARRIVE HERE IF TERMINAL TOGGLE GT 0, AND OUTPUT NOT CONSOLE
      J = 1
      GO TO 10000
10100 CONTINUE
      STOP
      END
      SUBROUTINE INITAL
      INTEGER WDSIZE,WFACT,TWO8,FACT(5)
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      INTEGER I,J,K
      WFACT = WDSIZE/8
      MAXVM = MAXMEM*WFACT - 1
      MEMTOP = MAXVM+1
      MEMBOT =  -1
C
          DO 5 I=1,5
          FACT(I) = 0
5         CONTINUE
C
C
      FACT(WFACT) = 1
      J= WFACT-1
          DO 10 I=1,J
          K = WFACT - I
          FACT(K) = FACT(K+1) * TWO8
10        CONTINUE
C
          DO 15 I=1,MAXMEM
          MEM(I) = 0
15        CONTINUE
      RETURN
      END
      INTEGER FUNCTION GET(IP)
      INTEGER I,IP
      INTEGER WDSIZE,WFACT,TWO8,FACT(5)
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      INTEGER J,K
      I = IP - OFFSET
      J = I/WFACT+1
      IF (J .GT. MAXMEM) GO TO 9999
      J = MEM(J)
      K = MOD(I,WFACT)+1
      GET = MOD(J/FACT(K),TWO8)
      RETURN
9999  GET = 0
      CALL ERROR(101,5)
      RETURN
      END
      SUBROUTINE PUT(IP,X)
      INTEGER I,IP,X
      INTEGER WDSIZE,WFACT,TWO8,FACT(5)
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      I = IP - OFFSET
      J = I/WFACT+1
      IF (J .GT. MAXMEM) GO TO 9999
      M = MEM(J)
      K = MOD(I,WFACT)+1
      MH = 0
      IF (K .EQ. 1) GO TO 10
      IFACT = FACT(K-1)
      MH = (M/IFACT)*IFACT
10    IFACT = FACT(K)
      M = MOD(M,IFACT)
      MEM(J) = MH +X*IFACT+M
      RETURN
9999  CALL ERROR(102,5)
      RETURN
      END
      INTEGER FUNCTION ALLOC(I)
      INTEGER I
      INTEGER WDSIZE,WFACT,TWO8,FACT(5)
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      IF (I .LT. 0) GO TO 10
C     ALLOCATION IS FROM BOTTOM
      ALLOC = MEMBOT + OFFSET + 1
      MEMBOT = MEMBOT + I
      IF (MEMBOT .GT. MEMTOP) CALL ERROR(103,5)
      RETURN
C
C     ALLOCATION IS FROM TOP
10    MEMTOP=MEMTOP + I
      IF (MEMTOP .LE. MEMBOT) CALL ERROR(104,5)
      ALLOC = MEMTOP + OFFSET
      RETURN
      END
      FUNCTION ICON(I)
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
C     ICON IS CALLED WITH AN INTEGER VARIABLE I WHICH CONTAINS A
C     CHARACTER READ WITH AN A1 FORMAT.  ICON MUST REDUCE THIS CHARACTER
C     TO A VALUE SOMEWHERE BETWEEN 1 AND 256.  NORMALLY, THIS WOULD BE
C     ACCOMPLISHED BY SHIFTING THE CHARACTER TO THE RIGHTMOST BIT POSI-
C     TIONS OF THE WORD AND MASKING THE RIGHT 8 BITS.  IT IS DONE RATHER
C     INEFFICIENTLY HERE, HOWEVER, TO GAIN SOME MACHINE INDEPENDENCE.
        DO 100 K=1,52
        J = K
        IF (I .EQ. OTRAN(K)) GO TO 200
100   CONTINUE
        J = 1
200   ICON = J
      RETURN
      END
      INTEGER FUNCTION GNC(Q)
C     GET NEXT CHARACTER FROM THE INPUT STREAM (OR 0 IF
C     NO CHARACTER IS FOUND)
C
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER Q
      IF (IBP .LE. CONTRL(29)) GO TO 200
C     READ ANOTHER RECORD FROM COMMAND STREAM
      IF (CONTRL(31) .EQ. 0) GO TO 1
      IF (CONTRL(20).NE.1) GO TO 1
C     INPUT IS FROM TERMINAL, SO GET RID OF LAST LINE
          CALL PAD(0,1,1)
          CALL WRITEL(0)
1     IFILE = CONTRL(20)
      IF (CONTRL(16) .EQ. 1) GO TO 999
10    READ(IFILE,1000) IBUFF
100       DO 110 I=1,80
          J = IBUFF(I)
          J = ICON(J)
          IBUFF(I) = ITRAN(J)
110       CONTINUE
C
      LP = CONTRL(23)
      IF (IBUFF(LP).EQ.38) GO TO 300
115   IBP = LP
      IF (CONTRL(27).EQ.0) GO TO 200
      IF (CONTRL(23) .EQ. 1) GO TO 120
      CALL FORM(1,IBUFF,1,CONTRL(23)-1,80)
      CALL PAD(1,1,3)
120   CALL FORM(1,IBUFF,CONTRL(23),CONTRL(29),80)
      IF(CONTRL(29) .EQ. 80) GO TO 130
      CALL PAD(1,1,3)
      CALL FORM(1,IBUFF,CONTRL(29)+1,80,80)
130   CONTINUE
200   GNC = IBUFF(IBP)
      IBP = IBP + 1
      RETURN
300   CONTINUE
      IF(IBUFF(2) .EQ. 1) GO TO 115
C     SCANNER PARAMETERS FOLLOW
      LP = LP + 1
305   J = IBUFF(LP)
      IF (J.EQ.38) GO TO 400
      LP = LP + 1
C
          DO 310 I=LP,80
          II = I
          IF (IBUFF(I) .EQ. 39) GO TO 330
          IF (IBUFF(I).EQ.38) GO TO 315
310       CONTINUE
C
315   K = CONTRL(J)
      IF (K .GT. 1) GO TO 320
      CONTRL (J) = 1-K
      GO TO 325
320   CALL ERROR(105,1)
325   IF (II.EQ.80) GO TO 1
      LP = II + 1
      GO TO 305
330   K = 0
      II = II+1
C
          DO 340 I=II,80
          L = IBUFF(I)
          IF (L .LE. 1) GO TO 340
          IF (L .GT. 11) GO TO 350
          K = K*10+(L-2)
340       CONTINUE
C
350   CONTRL(J) = K
C     MAY BE MORE $ IN INPUT LINE
360   II = LP + 1
          DO 370 I=II,80
          LP = I
          IF (IBUFF(I).EQ.38) GO TO 380
370       CONTINUE
C     NO MORE $ FOUND
      GO TO 1
380   LP = LP + 1
      GO TO 305
400   CONTINUE
C     DISPLAY $ PARAMETERS
      L = 2
      K = 64
      LP = LP + 1
      J = IBUFF(LP)
      IF (J.EQ.1) GO TO 410
      L = J
      K = J
410   CONTINUE
          DO 420 I=L,K
          J = CONTRL(I)
          IF (J.LT.0) GO TO 420
          CALL PAD(0,38,1)
          CALL PAD(1,I,1)
          CALL PAD(1,39,1)
          CALL CONOUT(2,-10,J,10)
420       CONTINUE
          IF (CONTRL(31).NE.0) CALL PAD(0,1,1)
      CALL WRITEL(0)
      GO TO 360
999   GNC = 0
      RETURN
1000  FORMAT(80A1)
      END
      FUNCTION IMIN(I,J)
      IF (I .LT. J) GO TO 10
      IMIN = J
      GO TO 20
10    IMIN = I
20    RETURN
      END
      SUBROUTINE FORM(CC,CHARS,START,FINISH,LENGTH)
C     CC = 0 DUMP BUFFER, GO TO NEXT LINE
C     CC = 1 APPEND TO CURRENT BUFFER
C     CC = 2 DELETE LEADING BLANKS AND APPEND
      INTEGER CHARS(LENGTH)
      INTEGER CC,START,FINISH
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      J = START
      I = CC + 1
      GO TO (100,200,300),I
100   CALL WRITEL(0)
200   IF (J .GT. FINISH) GO TO 999
      OBP = OBP + 1
      OBUFF(OBP) = CHARS(J)
      J = J + 1
      IF (OBP .GE. CONTRL(34)) GO TO 100
      GO TO 200
300   IF (J .GT. FINISH) GO TO 999
      IF (CHARS(J) .NE. 1) GO TO 200
      J = J + 1
      GO TO 300
999   RETURN
      END
      SUBROUTINE WRITEL(NSPAC)
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
        INTEGER CONTRL(64),OFILE
        COMMON /CNTRL/CONTRL
      NSPACE=NSPAC
C
      NP = CONTRL(36) - 1
      IF (OBP.LE.NP) GO TO 998
      NBLANK = 1
C
          DO 5 I=1,OBP
          J = OBUFF(I)
          IF (J .NE. 1) NBLANK = I
5         OBUFF(I) = OTRAN(J)
C
      OBP = IMIN(CONTRL(15),NBLANK)
      OFILE = CONTRL(26) + 10
9     CONTINUE
10      WRITE(OFILE,1000) (OBUFF(I), I=1,OBP)
11    IF(NSPACE.LE.0) GO TO 998
C
      DO 12 I=1 , OBP
12    OBUFF(I)=OTRAN(1)
      NSPACE=NSPACE-1
      GO TO 9
998   IF (NP.LE.0) GO TO 997
          DO 999 I=1,NP
999       OBUFF(I) = 1
997   OBP = NP
      RETURN
1000    FORMAT (1H ,121A1)
1001    FORMAT(1H )
        END
      SUBROUTINE CONOUT(CC,K,N,BASE)
      INTEGER CC,K,N,BASE,T(20)
      LOGICAL ZSUP
      NP = N
      ZSUP = K .LT. 0
      KP = IMIN (IABS(K),19)
C
          DO 10 I=1,KP
10        T(I) = 1
C
      IP = KP + 1
C
          DO 20 I=1,KP
          LTEMP=IP-I
          T(LTEMP)=MOD(NP,BASE)+2
          NP = NP/BASE
          IF(ZSUP .AND. (NP .EQ. 0)) GO TO 30
20        CONTINUE
C
30    IF(BASE .EQ. 8) GO TO 40
      IF(BASE .EQ. 2) GO TO 45
      IF(BASE .NE. 16) GO TO 50
      KP = KP+1
      T(KP) = 19
      GO TO 50
40    KP = KP+1
      T(KP) = 28
      GO TO 50
45     KP = KP+1
      T(KP) = 13
50    CALL FORM(CC,T,1,KP,20)
      RETURN
      END
      SUBROUTINE PAD(CC,CHR,I)
      INTEGER CC,CHR,I
      INTEGER T(20)
      J = IMIN(I,20)
C
          DO 10 K=1,J
10        T(K) = CHR
C
      CALL FORM(CC,T,1,J,20)
      RETURN
      END
      SUBROUTINE ERROR(I,LEVEL)
C     PRINT ERROR MESSAGE - LEVEL IS SEVERITY CODE (TERMINATE AT 5)
      INTEGER TERR(22)
      LOGICAL ERRFLG
      COMMON/TERRR/TERR,ERRFLG
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
      INTEGER MSSG(77)
      COMMON/MESSG/MSSG
      CONTRL(1) = CONTRL(1) + 1
      CALL PAD(0,42,1)
      CALL CONOUT(1,5,CONTRL(14),10)
      CALL PAD(1,43,1)
      CALL PAD(1,1,2)
      CALL FORM(1,MSSG,16,20,77)
      CALL PAD(1,1,1)
      CALL CONOUT(2,-4,I,10)
      CALL WRITEL(0)
C     CHECK FOR SEVERE ERROR - LEVEL GREATER THAN 4
      IF (LEVEL.LE.4) GO TO 999
C         TERMINATE COMPILATION
          CALL FORM(0,TERR,1,22,22)
          CALL WRITEL(0)
          ERRFLG = .TRUE.
999   RETURN
      END
      INTEGER FUNCTION SHR(I,J)
      SHR = I/(2**J)
      RETURN
      END
      INTEGER FUNCTION SHL(I,J)
      SHL = I*(2**J)
      RETURN
      END
      INTEGER FUNCTION RIGHT(I,J)
      RIGHT = MOD(I,2**J)
      RETURN
      END
      SUBROUTINE DELETE(N)
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
C     DELETE THE TOP N ELEMENTS FROM THE STACK
      DO 200 I=1,N
      IF(SP.GT.0) GO TO 50
          CALL ERROR(106,1)
          GO TO 9999
50    I1 = RASN(SP)
      I1 = MOD(I1,256)
      I2 = MOD(I1,16)
      I1 = I1/16
      JP = REGS(1)
      IF (I1.EQ.0) GO TO 100
          IF (JP.EQ.I1) REGS(1) = 0
          LOCK(I1) = 0
          REGS(I1) = 0
100   IF(I2.EQ.0) GO TO 200
          IF (JP.EQ.I2) REGS(1) = 0
          LOCK(I2) = 0
          REGS(I2) = 0
200   SP = SP - 1
9999  RETURN
      END
      SUBROUTINE APPLY(OP,OP2,COM,CYFLAG)
      INTEGER OP,COM,CYFLAG,OP2
C     APPLY OP TO TOP ELEMENTS OF STACK
C     USE OP2 FOR HIGH ORDER BYTES IF DOUBLE BYTE OPERATION
C     COM = 1 IF COMMUTATIVE OPERATOR, 0 OTHERWISE
C     CYFLAG = 1 IF THE CARRY IS INVOLVED IN THE OPERATION
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
C
C     MAY WANT TO CLEAR THE CARRY FOR THIS OPERATION
C
C     CHECK FOR ONE OF THE OPERANDS IN THE STACK (ONLY ONE CAN BE THERE)
C
      I = SP-1
      IP = 0
          DO 90 J=I,SP
          IF ((ST(J).NE.0).OR.(RASN(J).NE.0).OR.(LITV(J).GE.0)) GO TO 90
C
C         OPERAND IS STACKED
          CALL GENREG(-2,IA,IB)
          REGS(IA) = J
          IF (IP.NE.0) CALL ERROR(152,1)
          IP = IB
          IF (PREC(J).GT.1) GO TO 80
C
C     SINGLE PRECISION RESULT
      IB = 0
      GO TO 85
C
C
C         DOUBLE BYTE OPERAND
80        REGS(IB) = J
C
85        RASN(J) = IB*16+IA
          CALL EMIT(POP,IP,0)
          CALL USTACK
90        CONTINUE
C
C     MAKE A QUICK CHECK FOR POSSIBLE ACCUMULATOR MATCH
C     WITH THE SECOND OPERAND
      IA = RASN(SP)
      IF (IA.GT.255) CALL CVCOND(SP)
      IB = RASN(SP-1)
      IF (IB.GT.255) CALL CVCOND(SP-1)
      L = REGS(1)
      IF ((IA*IB*L*COM).EQ.0) GO TO 100
C     COMMUTATIVE OPERATOR, ONE MAY BE IN THE ACCUMULATOR
      IF (L.NE.MOD(IA,16)) GO TO 100
C     SECOND OPERAND IN GPR'S, L.O. BYTE IN ACCUMULATOR
      CALL EXCH
C
100   IA = 0
      IB = 0
C     IS OP1 IN GPR'S
C
      L = RASN(SP-1)
      IF (L.EQ.0) GO TO 140
C     REG ASSIGNED, LOCK REGS CONTAINING VAR
      I = MOD(L,16)
      IF (I.EQ.0) GO TO 9990
      IA = I
      LOCK(I) = 1
      I = L/16
      IF (I.EQ.0) GO TO 110
          IB = I
          LOCK(I) = 1
C
C     MAY HAVE TO GENERATE ONE FREE REG
110   IF (PREC(SP-1).GE.PREC(SP)) GO TO 120
      IB = IA - 1
C
C     FORCE LOW-ORDER BYTE INTO ACCUMULATOR
120   CONTINUE
C     CHECK FOR PENDING REGISTER STORE
      JP = REGS(1)
      IF (JP.EQ.IA) GO TO 200
      IF (JP.NE.0) CALL EMIT(LD,JP,RA)
      REGS(1) = IA
      CALL EMIT(LD,RA,IA)
      GO TO 200
C
C     IS OP2 IN GPR'S
140   L = RASN(SP)
      IF (L.EQ.0) GO TO 200
C     YES - CAN WE EXCHANGE AND TRY AGAIN
C     AFTER INSURING THAT A LITERAL HAS NO REGS ASSIGNED
      LITV(SP) = -1
      IF (COM.EQ.0) GO TO 200
150   CALL EXCH
      GO TO 100
C
C     OP2 NOT IN GPR'S OR OP IS NOT COMMUTATIVE
C     CHECK FOR LITERAL VALUE - IS OP2 LITERAL
200   K = LITV(SP)
      IF (K.LT.0) GO TO 280
C
      IF ((PREC(SP).GT.1).OR.(PREC(SP-1).GT.1)) GO TO 300
C     MAKE SPECIAL CHECK FOR POSSIBLE INCREMENT OR DECREMENT
      IF (K.NE.1) GO TO 300
C         MUST BE ADD OR SUBTRACT WITHOUT CARRY
          IF ((OP.NE.AD).AND.(OP.NE.SU)) GO TO 300
C         FIRST OPERAND MUST BE SINGLE BYTE VARIABLE
          IF (PREC(SP-1).NE.1) GO TO 300
          IF (IA.GT.1) GO TO 230
C         OP1 MUST BE IN MEMORY, SO LOAD INTO GPR
              CALL LOADV(SP-1,0)
              L = RASN(SP-1)
              IA = MOD(L,16)
              IF (IA.EQ.0) GO TO 9990
C             ...MAY CHANGE TO INR MEMORY IF STD TO OP1 FOLLOWS...
              LASTIR = CODLOC
230       JP = IA
          IF (REGS(RA).EQ.IA) JP = RA
          IF (OP .EQ. AD) CALL EMIT (IN, JP, 0)
          IF (OP .EQ. SU) CALL EMIT (DC, JP, 0)
          GO TO 2000
C
C     OP1 NOT A LITERAL,  CHECK FOR LITERAL OP2
280   IF(LITV(SP-1).LT.0) GO TO 300
      IF(COM.EQ.1) GO TO 150
C
C     GENERATE REGISTERS TO HOLD RESULTS IN LOADV
C     (LOADV WILL LOAD THE LOW ORDER BYTE INTO THE ACC)
300   CALL LOADV(SP-1,1)
      L = RASN(SP-1)
      IA = MOD(L,16)
      IF (IA.EQ.0) GO TO 9990
      LOCK(IA) = 1
      IB = L/16
C
C     IS THIS A SINGLE BYTE / DOUBLE BYTE OPERATION
      IF ((IB.GT.0).OR.(PREC(SP).EQ.1)) GO TO 400
C     GET A SPARE REGISTER
          IB = IA - 1
          IF (IB.EQ.0) GO TO 9990
          LOCK(IB) = 1
C
C     NOW READY TO PERFORM OPERATION
C     L.O. BYTE IS IN AC, H.O. BYTE IS IN IB.
C     RESULT GOES TO IA (L.O.) AND IB (H.O.)
C
C     IS OP2 IN GPR'S
400   LP = RASN(SP)
      K = -1
      IF (LP.LE.0) GO TO 500
C
C         PERFORM ACC-REG OPERATION
          CALL EMIT(OP,MOD(LP,16),0)
          GO TO 700
C
C     IS OP2 A LITERAL
500   K = LITV(SP)
      IF (K.LT.0) GO TO 600
C
C         USE CMA IF OP IS XR AND OP2 IS LIT 255
          IF (OP.NE.XR.OR.MOD(K,256).NE.255) GO TO 550
              CALL EMIT(CMA,0,0)
              GO TO 700
550       CONTINUE
C
C         PERFORM ACC-IMMEDIATE OPERATION
          CALL EMIT(OP,-MOD(K,256),0)
          GO TO 700
C
C     OP2 IS IN MEMORY - SETUP ADDRESS
600   CONTINUE
      CALL LOADV(SP,2)
C     PERFORM OPERATION WITH LOW ORDER BYTE
      CALL EMIT(OP,ME,0)
C
C     NOW PROCESS HIGH ORDER BYTE
700   CONTINUE
C     SET UP A PENDING REGISTER STORE
C     IF THIS IS NOT A COMPARE
      IF (OP.NE.CP) REGS(1) = IA
      IF(PREC(SP).EQ.2) GO TO 3000
C     SECOND OPERAND IS SINGLE BYTE
      IF (PREC(SP-1).LT.2) GO TO 2000
C
C     MAY NOT NEED TO PERFORM OPERATIONS FOR CERTAIN OPERATORS, BUT ...
C     PERFORM OPERATION WITH H.O. BYTE OF OP1
C     OP1 MUST BE IN THE GPR'S - PERFORM DUMMY OPERATION WITH ZERO
      JP = REGS(1)
      IF (JP.EQ.0) GO TO 800
      IF (JP.EQ.IB) GO TO 850
          CALL EMIT(LD,JP,RA)
          REGS(1)= 0
800   CALL EMIT(LD,RA,IB)
850   CALL EMIT(OP2,0,0)
C
C     MOVE ACCUMULATOR TO GPR
1000  CONTINUE
C     SET UP PENDING REGISTER STORE
      REGS(1) = IB
C
C     FIX STACK POINTERS AND VALUES
2000  CONTINUE
C     SAVE THE PENDING ACCUMULATOR - REGISTER STORE
      JP = REGS(1)
      CALL DELETE(2)
      REGS(1) = JP
          SP = SP+1
          PREC(SP)=1
          RASN(SP) = IB*16 + IA
          LOCK(IA) = 0
          ST(SP) = 0
          LITV(SP) = -1
          REGS(IA) = SP
          REGV(IA) = -1
      IF (IB.LE.0) GO TO 9999
          PREC(SP)=2
          REGS(IB)=SP
          LOCK(IB)=0
          REGV(IB)=-1
      GO TO 9999
C
C     PREC OF OP2 = 2
3000  CONTINUE
C     IS H.O. BYTE OF OP2 IN MEMORY
      IF ((K.GE.0).OR.(LP.GT.0)) GO TO 3100
C     POINT TO H.O. BYTE WITH H AND L
      CALL EMIT(IN,RL,0)
      REGV(7) = REGV(7) + 1
C
C     DO WE NEED TO PAD WITH H.O. ZERO FOR OP1
3100  IF (PREC(SP-1).GT.1) GO TO 3200
C     IS STORE PENDING
      JP = REGS(1)
      IF (JP.EQ.0) GO TO 3150
      IF (JP.EQ.IB) GO TO 3250
          CALL EMIT(LD,JP,RA)
          REGS(1) = 0
3150  IF (CYFLAG.EQ.0) CALL EMIT(XR,RA,0)
      IF (CYFLAG.EQ.1) CALL EMIT(LD,RA,0)
      GO TO 3250
C
C     IS H.O. BYTE OF OP2 IN GPR
3200  CONTINUE
C     IS STORE PENDING
      JP = REGS(1)
      IF (JP.EQ.0) GO TO 3220
      IF (JP.EQ.IB) GO TO 3250
          CALL EMIT(LD,JP,RA)
          REGS(1) = 0
3220  CALL EMIT(LD,RA,IB)
3250  IF (LP.EQ.0) GO TO 3300
C
C     OP2 IN GPR'S - PERFORM ACC-REGISTER OPERATION
      CALL EMIT(OP2,LP/16,0)
      GO TO 1000
C
C     OP2 IS NOT IN GPR'S - IS IT A LITERAL
3300  CONTINUE
      IF (K.LT.0) GO TO 3400
C     YES - PERFORM ACC-IMMEDIATE OPERATION
C     USE CMA IF OP1 IS XR AND OP2 IS 65535
      IF (OP2.NE.XR.OR.K.NE.65535) GO TO 3350
          CALL EMIT(CMA,0,0)
          GO TO 1000
3350  CONTINUE
      CALL EMIT(OP2,-(K/256),0)
      GO TO 1000
C
C     PERFORM ACC-MEMORY OPERATION
3400  CALL EMIT(OP2,ME,0)
      GO TO 1000
C
9990  CALL ERROR(107,5)
9999  RETURN
      END
      SUBROUTINE GENREG(NP,IA,IB)
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
C     GENERATE N FREE REGISTERS FOR SUBSEQUENT OPERATION
      N = IABS(NP)
C     N IS NUMBER OF REGISTERS, NP NEGATIVE IF NO PUSHING ALLOWED
10    IB = 0
      IA = 0
      IDUMP = 0
C
C     LOOK FOR FREE RC OR RE AND ALLOCATE IN PAIRS (RC/RB,RE/RD)
100   K = RC
      IF (REGS(K).EQ.0) GO TO 200
      K = RE
      IF (REGS(K).NE.0) GO TO 9990
200   IA = K
      IF (N.GT.1) IB = IA - 1
      GO TO 9999
C
9990  CONTINUE
      IF (IDUMP.GT.0) GO TO 9991
      IF (NP.LT.0) GO TO 5000
      IP = 0
C     GENERATE TEMPORARIES IN THE STACK AND RE-TRY
C         SEARCH FOR LOWEST REGISTER PAIR ASSIGNMENT IN STACK
          IF (SP.LE.0) GO TO 5000
          DO 4000 I=1,SP
          K = RASN(I)
          IF (K.EQ.0) GO TO 3950
          IF (K.GT.255) GO TO 4000
          J = MOD(K,16)
          IF (LOCK(J).NE.0) GO TO 4000
          JP = K/16
          IF (JP.EQ.0) GO TO 3900
C         OTHERWISE CHECK HO REGISTER
          IF ((LOCK(JP).NE.0).OR.(JP.NE.(J-1))) GO TO 4000
3900          IF (IP.EQ.0) IP = I
              GO TO 4000
3950          IF ((ST(I).EQ.0).AND.(LITV(I).LT.0)) IP=0
4000      CONTINUE
      IF (IP.EQ.0) GO TO 5000
C     FOUND ENTRY TO PUSH AT IP
      J = RASN(IP)
      JP = J/16
      J = MOD(J,16)
      REGS(J) = 0
      IF (JP.GT.0) REGS(JP) = 0
C     CHECK PENDING REGISTER STORE
      K = REGS(1)
      IF (K.EQ.0) GO TO 4500
      IF (K.EQ.J) GO TO 4200
      IF (K.NE.JP) GO TO 4500
C     STORE INTO HO REGISTER
          CALL EMIT(LD,JP,RA)
          GO TO 4400
C     PENDING STORE TO LO BYTE
4200  CONTINUE
      CALL EMIT(LD,J,RA)
4400  REGS(RA) = 0
C
C     FREE THE REGISTER FOR ALLOCATION
C
4500  CALL STACK(1)
      CALL EMIT(PUSH,J-1,0)
C
C     MARK ELEMENT AS STACKED (ST=0, RASN=0)
          RASN(IP) = 0
          ST(IP) = 0
          LITV(IP) = -1
C         AND THEN TRY AGAIN
      GO TO 100
C
C     TRY FOR MEMORY STORE
5000  CONTINUE
      IDUMP = 1
      CALL SAVER
      GO TO 100
9991  IA = 0
9999  RETURN
      END
      SUBROUTINE LOADSY
      INTEGER INTPRO(8)
      COMMON /INTER/INTPRO
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER ATTRIB
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER GNC,RIGHT,SHL,SHR,SIGN
C     SAVE THE CURRENT INPUT FILE NUMBER
      M = CONTRL(20)
      CONTRL(20) = CONTRL(32)
5     I = GNC(0)
      IF(I.EQ.1) GO TO 5
C     LOOK FOR INITIAL '/'
      IF (I.NE.41) GO TO 8000
C     LOAD THE INTERRUPT VECTOR
C
10    I = GNC(0)
      IF (I.EQ.41) GO TO 50
      IF ((I.LT.2).OR.(I.GT.9)) GO TO 8000
      I = I - 1
C     GET THE PROCEDURE NAME CORRESPONDING TO INTERRUPT I-1
      J = 0
      L = 1
20    K = GNC(0)
      IF (K.EQ.41) GO TO 30
      K = K - 2
      IF ((K.LT.0).OR.(K.GT.31)) GO TO 8000
      J = J + K*L
      L = L * 32
      GO TO 20
C
30    INTPRO(I) = J
      IF (CONTRL(30).LT.2) GO TO 10
      CALL PAD(0,1,1)
      CALL PAD(1,20,1)
      CALL CONOUT(1,1,I-1,10)
      CALL PAD(1,39,1)
      CALL PAD(1,30,1)
      CALL CONOUT(1,5,J,10)
      CALL WRITEL(0)
      GO TO 10
C
C     INTERRUPT PROCEDURES ARE HANDLED.
50    I = GNC(0)
      IF (I.EQ.1) GO TO 50
C
      IF (I.NE. 41) GO TO 8000
C
C     PROCESS NEXT SYMBOL TABLE ENTRY
100   I = GNC(0)
      IF (I.EQ.41) GO TO 1000
C
      SYTOP = SYTOP + 1
      IF (SYTOP .LT. SYINFO) GO TO 200
          CALL ERROR(108,5)
          SYINFO = SYMAX
200   IF (CONTRL(30).LT.2) GO TO 250
C
C     WRITE SYMBOL NUMBER AND SYMBOL TABLE ADDRESS
      CALL PAD(0,1,1)
      CALL PAD(1,30,1)
      CALL CONOUT(1,5,SYTOP,10)
250   SYMBOL(SYTOP) = SYINFO
      SYINFO = SYINFO - 1
      ATTRIB = SYINFO
C
300   SIGN = 0
      IF (I.EQ. 1) SIGN = 1
      IF (I.EQ. 45) SIGN = -1
      IF (SIGN.EQ.0) GO TO 8000
C
      L = 1
      K = 0
400   I = GNC(0)
      IF ((I.GE.2).AND.(I.LE.33)) GO TO 600
C
C     END OF NUMBER
      IF (SYINFO .GT. SYTOP) GO TO 500
          CALL ERROR(109,5)
          SYINFO = SYMAX
500   IF (CONTRL(30).LT.2) GO TO 550
C
C     WRITE SYMBOL TABLE ADDRESS AND ENTRY
      CALL PAD(0,1,4)
      CALL CONOUT(1,5,SYINFO,10)
      CALL PAD(1,1,1)
      KP = 1
      IF (SIGN.EQ.-1) KP = 45
      CALL PAD(1,KP,1)
      CALL CONOUT(1,8,K,16)
550   SYMBOL(SYINFO) = SIGN * K
      SYINFO = SYINFO - 1
C     LOOK FOR '/'
      IF (I.NE.41) GO TO 300
C     CHECK FOR SPECIAL CASE AT END OF AN ENTRY
      ATTRIB = IABS(SYMBOL(ATTRIB))
      I = MOD(ATTRIB,16)
      IF ((I.EQ.PROC).OR.(I.EQ.VARB)) GO TO 545
      IF (I.NE.LABEL) GO TO 100
C     CHECK FOR SINGLE REFERENCE TO THE LABEL
      J = ATTRIB/256
      IF (J.NE.1) GO TO 100
C     ALLOCATE A CELL AND SET TO ZERO
C     ARRIVE HERE WITH PROC, VARB, OR SINGLE REF LABEL
545   SYMBOL(SYINFO) = 0
      SYINFO = SYINFO - 1
      IF (I.NE.PROC) GO TO 100
C     RESERVE ADDITIONAL CELL FOR STACK DEPTH COUNT
      I = 0
      GO TO 545
C
C
C     GET NEXT DIGIT
600   K = (I-2)*L + K
      L = L  * 32
      GO TO 400
1000  CONTINUE
C     ASSIGN RELATIVE MEMORY ADDRESSES TO VARIABLES IN SYMBOL TABLE
      I = SYTOP
C     65536 = 65280 + 256
      LMEM = 65280
1100  IF (I.LE.0) GO TO 9999
C     PROCESS NEXT SYMBOL
      MP = SYMBOL(I)
      L = -1
      K = SYMBOL (MP-1)
C     K CONTAINS ATTRIBUTES OF VARIABLE
      IF (K.LT.0) GO TO 1300
      IF (RIGHT(K,4).NE. 1) GO TO 1300
C     OTHERWISE TYPE IS VARB
          K = SHR(K,4)
          L = RIGHT(K,4)
          K = SHR(K,4)
C         L IS ELEMENT SIZE, K IS NUMBER OF ELEMENTS
          IF (L.LE.2) GO TO 1150
C         PROBABLY AN INLINE DATA VARIABLE
          L = -1
          GO TO 1300
1150  IF ((MOD(LMEM,2).EQ.1).AND.(L.EQ.2)) LMEM = LMEM - 1
C     MEM IS AT THE PROPER BOUNDARY NOW
      LMEM = LMEM - L*K
      IF (LMEM.GE.0) GO TO 1200
          CALL ERROR(110,1)
          LMEM = 65280
1200  L = LMEM
      IF (CONTRL(30).EQ.0) GO TO 1300
      IF(I.LE.4.OR.I.EQ.6) GO TO 1300
C     WRITE OUT ADDRESS ASSIGNMENT
          CALL PAD(0,1,1)
          CALL PAD(1,30,1)
          CALL CONOUT(1,5,I,10)
          CALL PAD(1,39,1)
          CALL CONOUT(1,5,L,10)
1300  SYMBOL(MP) = L
      I = I - 1
      GO TO 1100
C
8000  CALL ERROR(111,1)
9999  CONTINUE
C     NOW ASSIGN THE LAST ADDRESS TO THE VARIABLE 'MEMORY'
C     ** NOTE THAT 'MEMORY' MUST BE AT LOCATION 5 IN THE SYMBOL TABLE **
      I = SYMBOL(5)
      SYMBOL(I) = 65280
      IF (CONTRL(30).NE.0) CALL WRITEL(0)
      CONTRL(20) = M
      RETURN
      END
      SUBROUTINE LOADV(IS,TYPV)
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER S,TYP,TYPV
C     LOAD VALUE TO REGISTER IF NOT A LITERAL
C     TYP = 1 IF CALL FROM 'APPLY' IN WHICH CASE THE L.O. BYTE IS
C     LOADED INTO THE ACCUMULATOR INSTEAD OF A GPR.
C     IF TYP = 2, THE ADDRESS IS LOADED, BUT THE VARIABLE IS NOT.
C     IF TYP = 3, A DOUBLE BYTE (ADDRESS) FETCH IS FORCED.
C     IF TYP = 4 THEN DO A QUICK LOAD INTO H AND L
C     IF TYP = 5, A DOUBLE BYTE QUICK LOAD INTO H AND L IS FORCED
      INTEGER CONTRL(64)
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
      COMMON /CNTRL/CONTRL
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER VARB,INTR,PROC,LABEL,LITER
      INTEGER CHAIN
      I = 0
      S = IS
      TYP = TYPV
      IF (TYP.EQ.2) GO TO 100
C
      IF (RASN(S).GT.255) CALL CVCOND(S)
      IF (TYP.EQ.4.OR.TYP.EQ.5) GO TO 3000
      IF (RASN(S).GT.0) GO TO 9999
C     CHECK FOR PREVIOUSLY STACKED VALUE
      IF ((ST(S).NE.0).OR.(LITV(S).GE.0)) GO TO 40
      CALL GENREG(2,K,I)
C     CHECK TO ENSURE THE STACK IS IN GOOD SHAPE
      I = S + 1
10    IF (I.GT.SP) GO TO 30
      IF((ST(I).NE.0).OR.(RASN(I).NE.0).OR.(LITV(I).GE.0)) GO TO 20
C         FOUND ANOTHER STACKED VALUE
          CALL ERROR(147,1)
20    I = I + 1
      GO TO 10
30    CONTINUE
C     AVAILABLE CPU REGISTER IS BASED AT K
      CALL EMIT(POP,K-1,0)
      REGS(K) = S
      IF (PREC(SP).LT.2) GO TO 35
      REGS(K-1) = S
      K = (K-1)*16 + K
35    RASN(S) = K
C     DECREMENT THE STACK COUNT FOR THIS LEVEL
      CALL USTACK
      GO TO 9999
C
40    CONTINUE
C     NO REGISTERS ASSIGNED.  ALLOCATE REGISTERS AND LOAD VALUE.
      I = PREC(S)
      IF (TYP.NE.3) GO TO 50
C         FORCE A DOUBLE BYTE LOAD
          I = 2
          TYP = 0
50    CALL GENREG(I,IA,IB)
C     IA IS LOW ORDER BYTE, IB IS HIGH ORDER BYTE.
      IF (IA.LE.0) GO TO 9990
C     OTHERWISE REGISTERS HAVE BEEN FOUND.
100   CONTINUE
C     CHECK FOR LITERAL VALUE (IN ARITH EXP)
      L = LITV(S)
      IF ((L.GE.0).AND.(L.LE.65535)) GO TO 2000
C     OTHERWISE FETCH FROM MEMORY
      SP = SP + 1
      J = ST(S)
      CALL SETADR(J)
      CALL LITADD(SP)
C     ADDRESS OF VARIABLE IS IN H AND L
      JP = TYP+1
      GO TO (200,300,1000), JP
C     CALL FROM GENSTO (TYP = 0)
200   CALL EMIT(LD,IA,ME)
      GO TO 400
C     CALL FROM APPLY TO LOAD VALUE OF VARIABLE
300   JP = REGS(1)
C     CHECK FOR PENDING REGISTER STORE
      IF (JP.EQ.0) GO TO 350
C     HAVE TO STORE ACC INTO REGISTER BEFORE RELOADING
      CALL EMIT(LD,JP,RA)
      REGS(1) = 0
350   CALL EMIT(LD,RA,ME)
C
C     CHECK FOR DOUBLE BYTE VARIABLE
400   IF (I.LE.1) GO TO 1000
C     LOAD HIGH ORDER BYTE
      CALL EMIT(IN,RL,0)
      REGV(7) = REGV(7) + 1
      CALL EMIT(LD,IB,ME)
C     VALUE IS NOW LOADED
1000  CALL DELETE(1)
      IF (TYP .EQ. 2) GO TO 9999
      RASN(S) = IB*16+IA
      IF (IB.NE.0) REGS(IB) = S
      REGS(IA) = S
      IF (IB.NE.0) REGV(IB) = -1
      REGV(IA) = - 1
      GO TO 9999
C
C     LOAD A CONSTANT INTO REGISTERS (NON-COM OPERATOR)
2000  CONTINUE
      LP = MOD(L,256)
      REGS(IA) = S
      REGV(IA) = LP
      IF (TYP.EQ.1) GO TO 2100
C     TYP = 0, LOAD DIRECTLY INTO REGISTERS
C     MAY BE POSSIBLE TO LXI
      IF (IB.NE.(IA-1)) GO TO 2010
          CALL EMIT(LXI,IB,L)
          GO TO 2210
2010      CALL EMIT(LD,IA,-LP)
          GO TO 2200
C
C     TYP = 1, LOAD INTO ACCUMULATOR
2100  CONTINUE
C     CHECK FOR PENDING REGISTER STORE
      JP = REGS(1)
      IF (JP.EQ.0) GO TO 2150
C     STORE ACC INTO REGISTER BEFORE CONTINUING
          CALL EMIT(LD,JP,RA)
          REGS(1) = 0
2150      IF (LP.EQ.0) CALL EMIT(XR,RA,0)
          IF (LP.NE.0) CALL EMIT(LD,RA,-LP)
C
2200  IF (IB.EQ.0) GO TO 2300
          CALL EMIT(LD,IB,-L/256)
2210  REGS(IB) = S
          REGV(IB) = -L
C
2300  RASN(S) = IB*16+IA
      GO TO 9999
C     QUICK LOAD TO H AND L
3000  CONTINUE
      M = LITV(S)
      I = RASN(S)
      K = ST(S)
      IF (I.NE.0) GO TO 3100
      IF (K.NE.0) GO TO 3200
      IF (M.GE.0) GO TO 3400
C
C     VALUE STACKED, SO...
          CALL USTACK
          CALL EMIT(POP,RH,0)
          IF (PREC(S).LT.2) CALL EMIT(LD,RH,0)
          GO TO 3160
C
C     REGISTERS ARE ASSIGNED
3100  J = REGS(1)
      L = MOD(I,16)
      I = I/16
      IF ((J.NE.0).AND.(J.EQ.I)) I = RA
      IF ((J.NE.0).AND.(J.EQ.L)) L = RA
      IF ((L.NE.RE).OR.(I.NE.RD)) GO TO 3150
          CALL EMIT(XCHG,0,0)
          GO TO 3160
C     NOT IN D AND E, SO USE TWO BYTE MOVE
3150  CALL EMIT(LD,RL,L)
C     NOTE THAT THE FOLLOWING MAY BE A LHI 0
      CALL EMIT(LD,RH,I)
3160      REGV(RH) = -1
          REGV(RL) = -1
          GO TO 3300
C
C     VARIABLE , LITERAL  OR ADDRESS REFERENCE
3200  IF (K.GT.0) GO TO 3250
C         ADR REF - SET H AND L WITH LITADD
          CALL LITADD(SP)
          GO TO 3300
C
C     SIMPLE VARIABLE OR LITERAL REF, MAY USE LHLD
C         MAY WANT TO CHECK FOR POSSIBLE INX OR DCX, BUT NOW...
3250      IF (M.GE.0) GO TO 3400
          M = REGV(RH)
          L = REGV(RL)
          IF ((M.EQ.-3).AND.(-L.EQ.K)) GO TO 3260
          IF ((M.EQ.-4).AND.(-L.EQ.K)) GO TO 3255
              J = CHAIN(K,CODLOC+1)
              CALL EMIT(LHLD,J,0)
              GO TO 3260
C
3255      CALL EMIT(DCX,RH,0)
3260      REGV(RH) = -1
          REGV(RL) = -1
          IF (PREC(S).GT.1.OR.TYP.EQ.5) GO TO 3270
C         THIS IS A SINGLE BYTE VALUE
              CALL EMIT(LD,RH,0)
              GO TO 3300
C
3270      REGV(RH) = -3
          REGV(RL) = -K
C
3300  IF (RASN(S).EQ.0) RASN(S) = RH*16+RL
      GO TO 9999
C
C     LITERAL VALUE TO H L
3400  CALL EMIT(LXI,RH,M)
      REGV(RH) = M/256
      REGV(RL) = MOD(M,256)
      GO TO 9999
C
9990  CALL ERROR(112,5)
9999  RETURN
      END
      SUBROUTINE SETADR(VAL)
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
C     SET TOP OF STACK TO ADDRESS REFERENCE
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      ALTER = 1
C
      IF (SP .GT. MAXSP) GO TO 9999
C         MARK AS ADDRESS REFERENCE
          ST(SP) = -VAL
          I = SYMBOL(VAL)
          J = IABS(SYMBOL(I-1))
          PREC(SP) = RIGHT(SHR(J,4),4)
          I = SYMBOL(I)
C         *J=SHL(1,16)*
          J = 65536
          IF (I.GE.0) GO TO 4100
          J = 0
          I = - I
4100      I = RIGHT(I,16)
          LITV(SP) = J + I
      RASN(SP) = 0
      RETURN
9999  CALL ERROR(113,5)
      SP = 1
      RETURN
      END
      SUBROUTINE USTACK
C     DECREMENT CURDEP AND CHECK FOR UNDERFLOW
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
      I = CURDEP(PRSP+1)
      IF (I.GT.0) GO TO 100
          CALL ERROR(148,1)
          RETURN
100   CURDEP(PRSP+1) = I - 1
      RETURN
      END
      INTEGER FUNCTION CHAIN(SY,LOC)
      INTEGER SY,LOC
C     CHAIN IN DOUBLE-BYTE REFS TO SYMBOL SY, IF NECESSARY
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      I = SYMBOL(SY)
      J = SYMBOL(I)
      IF (J.GE.0) GO TO 100
C         ABSOLUTE ADDRESS ALREADY ASSIGNED
          CHAIN = MOD(-J,65536)
          GO TO 999
C     BACKSTUFF REQUIRED
100       I = I - 2
          CHAIN = SYMBOL(I)
          SYMBOL(I) = LOC
999   RETURN
      END
      SUBROUTINE GENSTO(KEEP)
C     KEEP = 0 IF STD, KEEP = 1 IF STO (VALUE RETAINED)
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      INTEGER CHAIN
      INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
C     GENERATE A STORE INTO THE ADDRESS AT STACK TOP
C     LOAD VALUE IF NOT LITERAL
      L = LITV(SP-1)
      IF (L.GE.0) GO TO 100
      IQ = 0
      CALL LOADV(SP-1,IQ)
100   I1 = RASN(SP-1)
      I2 = MOD(I1,16)
      I1 = I1/16
C     CHECK FOR PENDING REGISTER STORE
      JP = REGS(1)
      IF (JP.EQ.0) GO TO 150
      IF (JP.EQ.I1) I1 = 1
      IF (JP.EQ.I2) I2 = 1
150   CONTINUE
C     ** NOTE THAT THIS ASSUMES 'STACKPTR' IS AT 6 IN SYM TAB
      IF (-ST(SP).EQ.6) GO TO 700
      IF (LITV(SP).LT.0) GO TO 1000
C     OTHERWISE THIS IS A LITERAL ADDRESS
C         IF POSSIBLE, GENERATE A SHLD
      IF (I1.NE.RD.OR.I2.NE.RE.OR.LASTEX.NE.CODLOC-1
     1    .OR.PREC(SP).NE.2) GO TO 155
          CALL EMIT(XCHG,0,0)
          I = IABS(ST(SP))
          J = CHAIN(I,CODLOC+1)
          CALL EMIT(SHLD,J,0)
          REGV(RH) = -3
          REGV(RL) = -I
          IF (KEEP.NE.0) CALL EMIT(XCHG,0,0)
          GO TO 600
155   CONTINUE
      CALL LITADD(SP)
160   CONTINUE
C     WE MAY CHANGE MOV R,M INR R MOV M,R TO INR M.
C     IF SO, AND THIS IS A NON-DESTRUCTIVE STORE, THE REGISTER
C     ASSIGNMENT MUST BE RELEASED.
      IQ = LASTIR
C     GENERATE LOW ORDER BYTE STORE
      IF (I2.EQ.0) GO TO 200
          CALL EMIT(LD,ME,I2)
          GO TO 300
C     IMMEDIATE STORE
200       CALL EMIT(LD,ME,-(MOD(IABS(L),256)))
300   CONTINUE
C
C     NOW STORE HIGH ORDER BYTE (IF ANY)
      IF (PREC(SP).EQ.1) GO TO 600
C     A DOUBLE BYTE STORE
      I = 0
C     STORE SECOND BYTE
      CALL EMIT(INCX,RH,0)
C     REGV(RH) = -3 THEN LHLD HAS OCCURRED ON SYMBOL -REGV(RL)
C     REGV(RH) = -4 THEN LHLD AND INCX H HAS OCCURRED
      J = REGV(RH)
      IF (J.LT.0) GO TO 310
      REGV(7) = REGV(7) + 1
      GO TO 320
310   REGV(RH) = -4
      IF (J.EQ.-3) GO TO 320
C         RH AND RL HAVE UNKNOWN VALUES
          REGV(RH) = -1
          REGV(RL) = -1
320   CONTINUE
      IF (PREC(SP-1).LT.2) GO TO 400
      IF (I1.NE.0) GO TO 500
C     SECOND BYTE IS LITERAL
      I = L/256
C     ENTER HERE IF LITERAL
400   CONTINUE
      CALL EMIT(LD,ME,-IABS(I))
      GO TO 600
C     LD MEMORY FROM REGISTER
500   CALL EMIT(LD,ME,I1)
600   CONTINUE
C
C     NOW RELEASE REGISTER CONTAINING ADDRESS
C     RELEASE REGISTER ASSIGNMENT FOR VALUE
C     IF MOV R,M INR R MOV M,R WAS CHANGED TO INR M.
      IF (IQ.NE.CODLOC) GO TO 650
          I = -ST(SP)
          CALL DELETE(2)
          SP = SP + 1
          ST(SP) = I
          RASN(SP) = 0
          PREC(SP) = 1
          LITV(SP) = -1
          GO TO 9999
650   CONTINUE
      CALL DELETE(1)
      GO TO 9999
C
C     STORE INTO STACKPTR
700   CONTINUE
      IF (I2.EQ.0) GO TO 750
          CALL EMIT(LD,RL,I2)
          REGV(RL) = -1
          CALL EMIT(LD,RH,I1)
          REGV(RH) = -1
          CALL EMIT (SPHL,0,0)
          GO TO 600
750   CONTINUE
C     LOAD SP IMMEDIATE
          CALL EMIT(LXI,RSP,L)
          GO TO 600
C
C     WE HAVE TO LOAD THE ADDRESS BEFORE THE STORE
1000  CONTINUE
      I = RASN(SP)
      IF (I.GT.0) GO TO 1100
C     REGISTERS NOT ALLOCATED - CHECK FOR STACKED VALUE
      IF (ST(SP).NE.0) GO TO 1010
C     ADDRESS IS STACKED SO POP TO H AND L
          CALL EMIT(POP,RH,0)
          CALL USTACK
          GO TO 1110
1010  CONTINUE
C     CHECK FOR REF TO SIMPLE BASED VARIABLE
      I = ST(SP)
      IF (I.LE.INTBAS) GO TO 1020
C
C     MAY BE ABLE TO SIMPLIFY (OR ELIMINATE) THE LHLD
      K = REGV(RH)
      LP = REGV(RL)
      IF((K.EQ.-3).AND.(-LP.EQ.I)) GO TO 160
      IF((K.EQ.-4).AND.(-LP.EQ.I)) GO TO 1012
          J = CHAIN(I,CODLOC+1)
          CALL EMIT(LHLD,J,0)
          REGV(RH) = -3
          REGV(RL) = -I
      GO TO 160
1012  CALL EMIT(DCX,RH,0)
      REGV(RH) = -3
      GO TO 160
1020  CONTINUE
          IF (I2.NE.0)  LOCK(I2) = 1
          IF (I1.NE.0) LOCK(I1) = 1
C         FORCE A DOUBLE BYTE FETCH INTO GPRS
          CALL LOADV(SP,3)
          I = RASN(SP)
C
1100  JP = REGS(1)
      J = MOD(I,16)
      I = I/16
      IF ((I2.EQ.0).OR.(I.NE.(J-1))) GO TO 1105
C     IF PREVOUS SYLLABLE IS XCHG THEN DO ANOTHER - PEEP WILL FIX IT
      IF ((I.EQ.RD).AND.(LASTEX.EQ.(CODLOC-1))) GO TO 1107
C         USE STAX - SET UP ACCUMULATOR
C
          IF (I2.EQ.1) GO TO 2215
          IF (JP.NE.0) CALL EMIT(LD,JP,RA)
          IF (I1.EQ.1) I1 = JP
          CALL EMIT(LD,RA,I2)
          REGS(RA) = 0
2215  CALL EMIT(STAX,I,0)
C     *****
C     IF BYTE DEST WE ARE DONE
      IF (PREC(SP) .LT. 2) GO TO 1104
C     *****
      CALL EMIT(INCX,I,0)
      IF (I1 .NE. 0) GO TO 1102
C     *****
C     STORE HIGH ORDER ZERO
      IF((I2 .NE. 1) .OR. (KEEP .NE. 0)) GO TO 1101
      CALL EMIT(LD, MOD(RASN(SP-1), 16), RA)
1101  REGS(RA) = 0
      CALL EMIT (XR, RA, 0)
      CALL EMIT (STAX, I, 0)
      GO TO 1104
C     *****
C     STORE HIGH ORDER BYTE
1102  IF((I2 .NE. 1) .OR. (KEEP .EQ. 0)) GO TO 1103
      CALL EMIT (LD, MOD(RASN(SP-1), 16), RA)
      REGS(RA) = 0
1103  CONTINUE
      CALL EMIT (LD, RA, I1)
      CALL EMIT (STAX, I, 0)
C     *****
1104  CALL DELETE (1)
      GO TO 9999
C     *****
C     ADDRESS IN GPRS BUT CANNOT USE STAX
1105  CONTINUE
      IF (J.EQ.JP) J = 1
      IF (I.EQ.JP) I=1
      IF ((I.EQ.RD).AND.(J.EQ.RE)) GO TO 1107
      CALL EMIT(LD,RL,J)
      CALL EMIT(LD,RH,I)
      GO TO 1110
1107  CALL EMIT(XCHG,0,0)
C     XCHG MAY BE REMOVED BY PEEPHOLE OPTIMIZATION
1110  CONTINUE
      IF (I1.NE.0)  LOCK(I1) = 0
      IF (I2.NE.0) LOCK(I2) = 0
      REGV(6) = -1
      REGV(7) = -1
      GO TO 160
C
9999  RETURN
      END
      SUBROUTINE LITADD(S)
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER S
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
C     LOAD H AND L WITH THE ADDRESS OF THE VARIABLE AT S IN
C     THE STACK
      IH = LITV(S)
      IL = MOD(IH,256)
      IH = IH/256
      IR = RH
      L = IH
      IF (IH.GE.0) GO TO 10
          CALL ERROR(114,1)
          GO TO 99999
10    CONTINUE
C
C     DEASSIGN REGISTERS
      I = RASN(S)
      IF (I.EQ.103) GO TO 99999
C     6*16+7 = 103
      JP = REGS(1)
          DO 50 J=1,2
          K = MOD(I,16)
          I = I/16
          IF (K.EQ.0) GO TO 50
          IF (K.EQ.JP) REGS(1) = 0
          REGS(K) = 0
          LOCK(K) = 0
          REGV(K) = -1
50        CONTINUE
C
      RASN(S) = 0
C
      DO 1000 I=6,7
      J = REGS(I)
      IF (J.EQ.0) GO TO 100
          K = RASN(J)
          KP = MOD(K,16)
          K = K/16
          IF (K.EQ.I) K = 0
          IF (KP.EQ.I) KP = 0
          RASN(J) = K*16+KP
C
100   LP = REGV(I)
      IF (LP.EQ.L) GO TO 700
      IF (LP.NE.(L+1)) GO TO 200
          CALL EMIT(DC,IR,0)
          GO TO 700
200   IF(LP.NE.(L-1)) GO TO 300
      IF(L.EQ.0) GO TO 300
          CALL EMIT(IN,IR,0)
          GO TO 700
300   IF (I.NE.6) GO TO 350
C     NO INC/DEC POSSIBLE, SEE IF L DOES NOT MATCH
      IF (IL.EQ.REGV(7)) GO TO 350
      REGV(7) = IL
      IF (L.GT.255) GO TO 310
C     OTHERWISE THIS IS A REAL ADDRESS
          CALL EMIT(LXI,RH,IL+IH*256)
          GO TO 700
310   CONTINUE
C     THE LXI MUST BE BACKSTUFFED LATER
      IT = ST(S)
      IF (IT.GE.0) GO TO 410
      IT=-IT
      IT=SYMBOL(IT)
      J = SYMBOL(IT-2)
C     PLACE REFERENCE INTO CHAIN
          CALL EMIT(LXI,RH,J)
          SYMBOL(IT-2) = CODLOC-2
          GO TO 700
350   IF (L.GT.255) GO TO 400
          CALL EMIT(LD,IR,-L)
          GO TO 700
C     THE ADDRESS MUST BE BACKSTUFFED LATER
400   IT = ST(S)
      IF (IT.LT.0) GO TO 500
410       CALL ERROR(115,1)
          GO TO 99999
500   IT = IABS(IT)
      IT = SYMBOL(IT)
      J = SYMBOL(IT)
      IF (J.GT.0) GO TO 600
          CALL ERROR(116,1)
          GO TO 99999
C     PLACE LINK INTO CODE
600   K = SHR(J,16)
      SYMBOL(IT) = SHL(CODLOC+1,16)+RIGHT(J,16)
      KP = MOD(K,256)
      K = K/256
      CALL EMIT(0,K,0)
      CALL EMIT(0,KP,0)
C     DONE LOADING ADDRESS ELEMENT
700   CONTINUE
C     FIX VALUES IN STACK AND REG
      IF (I.EQ.7) RASN(S) = 103
C     103 = 6*16+7
      REGS(I) = S
      REGV(I) = L
      L = IL
      IR = RL
1000  CONTINUE
C
99999 RETURN
      END
      SUBROUTINE DUMP(L,U,FA,FE)
      INTEGER L,U,FA,FE,A,B,W,FR,WR,RR
      INTEGER GET,DECODE,OPCNT
      LOGICAL SAME
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER DEBASE
      COMMON /BASE/DEBASE
      INTEGER ACCLEN,ACCUM(32),TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE,ASCII(48)
      COMMON /SCANC/ACCLEN,ACCUM,TYPE,STYPE,EOFLAG,
     1    IDENT,NUMB,SPECL,STR,CONT,VALUE,ASCII
      LP = L
      W = CONTRL(34)
      A = 5
      B = 3
      IF (FA .EQ. 8) A = 6
      IF(FE.NE.1) GO TO 10
C         SYMBOLIC DUMP
          B = 6
          FR = DEBASE
          IF (FR.EQ.2) FR = 16
          WR = 2
          IF(FR.EQ.10) WR = 3
          RR = 6-WR
          IF (FR.NE.10) RR = RR-1
C         FR IS FORMAT OF NUMBERS AFTER OP CODES
C         WR IS THE WIDTH OF THE NUMBER FIELD
C         RR IS THE NUMBER OF BLANKS AFTER THE NUMBER FIELD
          GO TO 20
10    IF (FE .EQ. 2) B = 9
      IF (FE .EQ. 8) B = 4
20    W = (W - A) / (B + 1)
C     W IS NUMBER OF ENTRIES ON EACH LINE
      IF (W .EQ. 0) GO TO 8025
      IF (FA .NE. 10) A = A - 1
      IF (FE .NE. 10) B = B - 1
C     A IS THE WIDTH OF THE ADDRESS FIELD
C     B IS THE WIDTH OF EACH ENTRY
C
          DO 100 I=1,29
100       ACCUM(I) = 256
          NSAME = 0
          OPCNT = 0
C
110   SAME = .TRUE.
      LS = LP
      I = 0
C
200   IF (LP .GT. U) GO TO 500
      I = I + 1
      J = GET(LP)
      LP = LP + 1
      J = MOD(J,256)
      IF (J .NE. ACCUM(I)) SAME = .FALSE.
      ACCUM(I) = J
      IF (I .LT. W) GO TO 200
C
300   IF (SAME) GO TO 400
      IF (I .EQ. 0) GO TO 9999
      CALL CONOUT (0, A, LS, FA)
C
          DO 320 J=1,I
          CALL PAD(1,1,1)
          K = ACCUM(J)
          IF (OPCNT .GT. 0) GO TO 315
          IF (FE .NE. 1) GO TO 310
          OPCNT = DECODE(1,K,6)
          GO TO 320
C
315   OPCNT = OPCNT - 1
      CALL CONOUT(1,WR,K,FR)
      CALL PAD(1,1,RR)
      GO TO 320
310       CALL CONOUT(1,B,K,FE)
320       CONTINUE
C
      IF (LP .LE. U) GO TO 110
      GO TO 600
C
400   NSAME = NSAME + 1
      IF (NSAME .GT. 1) GO TO 110
      CALL PAD(0,1,1)
      CALL WRITEL(0)
      GO TO 110
C
500   SAME = .FALSE.
      GO TO 300
C
600   CALL WRITEL(0)
      GO TO 9999
8025  CALL ERROR (117, 1)
9999  RETURN
      END
      INTEGER FUNCTION DECODE(CC,I,W)
C            *****************************************
C            *INSTRUCTION * DECODING * USING * CTRAN *
C            *****************************************
C     THE ELEMENTS OF CTRAN REPRESENT THE 8080 OPERATION CODES IN A
C     FORM WHICH IS MORE USABLE FOR INSTRUCTION DECODING IN BOTH THE
C     DECODE AND INTERP SUBROUTINES.  GIVEN AN INSTRUCTION I (BETWEEN 0
C     AND 255), CTRAN(I+1) PROVIDES AN ALTERNATE REPRESENTATION OF THE
C     INSTRUCTION, AS SHOWN BELOW...
C         5B    5B     5B       OR     5B     3B  2B    5B
C        ------------------          -----------------------
C        /    /     /     /          /      /    /    /    /
C        / X  /  Y  /   I /          / X    / Y1 /Y2  /  I /
C        /    /     /     /          /      /    /    /    /
C        ------------------          -----------------------
C     WHERE FIELD I SPECIFIES A 'CATEGORY' AND THE X AND Y FIELDS
C     QUALIFY INSTRUCTIONS WITHIN THE CATEGORY.
C    FIELD I       CATEGORY         VALUE OF X AND Y FIELDS
C    ------   ----------------- ----------------------------------------
C       0           MOV         THE FIELDS INDICATE THE VALID OPERANDS
C                              INVOLVED...
C                              ACC=0, B = 1, C = 2, D = 3, E = 4, H = 5,
C                               L = 6, M = 7, I = 8, SP= 9 (M IS MEMORY
C                              REFERENCING INSTRUCTION, AND I IS IMMED)
C                              THUS, /3/5/0/ IS A MOV D,H INSTRUCTION.
C
C       1     INCREMENT, DECRE- THE VALUE OF X DETERMINES THE INSTRUC-
C             MENT, ARITHMETIC, TION WITHIN THE CATEGORY..
C             OR LOGICAL        INR = 1, CDR = 2, ADD = 3, ADC = 4,
C                               SUB = 5, SBC = 6, ANA = 7, XRA = 8,
C                               ORA = 9, CMP = 10
C                               THE VALUE OF Y DETERMINES THE VALID
C                               REGISTER INVOLVED, AS ABOVE.  THUS,
C                               /3/4/1/ IS AN ADD E INSTRUCTION.
C    ------   ----------------- ----------------------------------------
C       2     JUMP, CALL, OR    THE VALUE OF X DETERMINES THE EXACT IN-
C                RETURN         STRUCTION.. JUMP=1, CALL=2, RETURN=3
C                               THE SUBFIELD Y1 DETERMINES THE ORIENTA-
C                               TION OF THE CONDITION.. T=1, F=0
C                               THE VALUE OF SUBFIELD Y2 GIVES THE CON-
C                               DITION.. CY=0, Z=1, S=2, P=3.
C                               THUS, /3/0/1/2/ IS AN RFZ (RETURN FALSE
C                               ZERO) INSTRUCTION.
C    ------   - --------------  ----------------------------------------
C       3     MISCELLANEOUS     THE VALUE OF THE Y FIELD DETERMINES THE
C                               INSTRUCTION (THE X FIELD GIVES THE VALUE
C                               OF AAA IN THE RST INSTRUCTION)
C                               RLC  = 1  RRC  = 2  RAL  = 3  RAR  = 4
C                               JMP  = 5  CALL = 6  RET  = 7  RST  = 8
C                               IN   = 9  OUT  = 10 HLT  = 11 STA  = 12
C                               LDA  = 13 XCHG = 14 XTHL = 15 SPHL = 16
C                               PCHL = 17 CMA  = 18 STC  = 19 CMC  = 20
C                               DAA  = 21 SHLD = 22 LHLD = 23 EI   = 24
C                               DI   = 25 NOP  = 26 27 --- 31 UNDEFINED
C                               (IBYTES GIVES NUMBER OF BYTES FOLLOWING
C                               THE FIRST 23 INSTRUCTIONS OF THIS GROUP)
C    -------   ---------------- ---------------------------------------
C     4 - 11   INSTRUCTIONS RE  THE Y FIELD GIVES A REGISTER PAIR NUM-
C              QUIRING A REGIS  BER A = 0, B = 1, D = 3, H = 5, SP = 9
C              TER PAIR
C                               THE INSTRUCTIONS IN EACH CATEGORY ARE
C                               DETERMINED BY THE I FIELD..
C                               LXI  = 4  PUSH = 5  POP  = 6
C                               DAD  = 7  STAX = 8  LDAX = 9
C                               INX  = 10 DCX  = 11
C    -------   ---------------- ---------------------------------------
C
      INTEGER CC,I,W,X,Y
      INTEGER CTRAN(256),INSYM(284),IBYTES(23)
      COMMON/INST/CTRAN,INSYM,IBYTES
      INSIZE=284
      IP = CTRAN(I+1)
      X = IP/1024
      Y = MOD(IP/32,32)
      IP = MOD(IP,32)+1
      DECODE = 0
C      POINT TO THE PROPER CATEGORY
C     (THE FIRST TWO ARE FOR CONDITION CODES AND REGISTER DESIGNATIONS)
      J = INSYM(IP+2)
C     SELECT THE PROPER INSTRUCTION CODE WITHIN THE CATEGORY
      IF (IP.GT.4) GO TO 500
      GO TO (100,200,300,400),IP
C     MOV
100   K = 1
      GO TO 210
C     INR ... CMP
200   K = X
C     MAY BE AN IMMEDIATE OPERATION
210   IF (Y.EQ.8) DECODE = 1
      GO TO 1000
C     JUMP CALL OR RETURN CONDITIONALLY
300   K = X
      IF (X.NE.3) DECODE = 2
      GO TO 1000
C     RLC ... NOP
400   K = Y
C     CHECK FOR JMP
      IF (Y.GT.23) GO TO 1000
C     RLC ... LDA
      DECODE = IBYTES(Y)
      GO TO 1000
C     LXI ... DCX
500   K = 1
      IF (IP.EQ.5) DECODE = 2
1000  J = J + K
      L = INSYM(J)
      J = INSYM(J+1)
      CALL FORM(CC,INSYM,L,J-1,INSIZE)
      L = J - L
C
      IF(IP.NE.4) GO TO 1050
C     CHECK FOR RST (IF FOUND ADD DECIMAL NUMBER)
      IF (Y.NE.8) GO TO 1100
C     FOUND RST INSTRUCTION
      CALL PAD(1,1,1)
      CALL CONOUT(1,1,X,10)
      L = L + 2
1050  IF (IP.NE.3) GO TO 1100
C     CONDITIONAL
      J = INSYM(2)+1+Y
      K = INSYM(J)
      J = INSYM(J+1)
      CALL FORM(1,INSYM,K,J-1,INSIZE)
      L = L + J - K
1100  CONTINUE
C     OPCODE IS WRITTEN.  L CHARACTERS ARE IN BUFFER, CHECK FOR MORE
      IF ((IP.LE.4).AND.(IP.GE.3)) GO TO 1200
C     WRITE REGISTER REFERENCE
      CALL PAD(1,1,1)
1110  M = Y
      IF (IP.EQ.1) M = X
      J = INSYM(1) + 1 + M
      K = INSYM(J)
      J = INSYM(J+1)
      CALL FORM(1,INSYM,K,J-1,INSIZE)
      L = L + J - K + 1
      IF (IP.NE.1) GO TO 1200
      IP = 0
      GO TO 1110
1200  IF (L.GE.W) GO TO 1300
      CALL PAD(1,1,W-L)
1300  RETURN
      END
      SUBROUTINE EMIT(OPR,OPA,OPB)
      INTEGER GET,RIGHT
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER REGMAP(9)
      COMMON/RGMAPP/REGMAP
      INTEGER OPR,OPA,OPB
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
C
C     THE FOLLOWING COMMENTS ARE SAMPLE CALLS TO THE EMIT
C     ROUTINE.  NOTE THAT EMIT REQUIRES THREE ARGUMENT AT ALL TIMES
C     (THE UNUSED ARGUMENTS ARE ZERO).
C
C             CALL EMIT(LD,RA,RB)
C             CALL EMIT(LD,RC,-34)
C             CALL EMIT(LD,RD,ME)
C             CALL EMIT(LD,ME,RE)
C             CALL EMIT(IN,RH,0)
C             CALL EMIT(DC,RL,0)
C             CALL EMIT(AD,RB,0)
C             CALL EMIT(AD,ME,0)
C             CALL EMIT(AD,-5,0)
C             CALL EMIT(SU,RB,0)
C             CALL EMIT(SB,ME,0)
C             CALL EMIT(ND,-5,0)
C             CALL EMIT(XR,0,0)
C             CALL EMIT(OR,RB,0)
C             CALL EMIT(CP,RH,0)
C             CALL EMIT(ROT,ACC,LFT)
C             CALL EMIT(ROT,CY,LFT)
C             CALL EMIT(ROT,CY,RGT)
C             CALL EMIT(JMP,148,0)
C             CALL EMIT(JMC,TRU*32+ZERO,148)
C             CALL EMIT(CAL,1048,0)
C             CALL EMIT(CLC,FAL*32+PARITY,148)
C             CALL EMIT(RTN,0,0)
C             CALL EMIT(RTC,FAL*32+CARRY,255)
C             CALL EMIT(RST,3,0)
C             CALL EMIT(INP,6,0)
C             CALL EMIT(OUT,10,0)
C             CALL EMIT(HALT,0,0)
C             EMIT A LITERAL BETWEEN 0 AND 255
C             CALL EMIT(0,44,0)
C
C             CALL EMIT(STA,300,0)
C             CALL EMIT(LDA,300,0)
C             CALL EMIT(XCHG,0,0)
C             CALL EMIT(SPHL,0,0)
C             CALL EMIT(PCHL,0,0)
C             CALL EMIT(CMA,0,0)
C             CALL EMIT(STC,0,0)
C             CALL EMIT(CMC,0,0)
C             CALL EMIT(DAA,0,0)
C             CALL EMIT(SHLD,300,0)
C             CALL EMIT(LHLD,300,0)
C             CALL EMIT(EI,0,0)
C             CALL EMIT(DI,0,0)
C
C             CALL EMIT(LXI,(RB,RD,RH,RSP),300)
C             CALL EMIT(PUSH,(RB,RD,RH,RA),0)
C             CALL EMIT(POP,(RB,RD,RH,RA),0)
C             CALL EMIT(DAD,(RB,RD,RH,RSP),0)
C             CALL EMIT(STAX,(RB,RD),0)
C             CALL EMIT(LDAX,(RB,RD),0)
C             CALL EMIT(INX,(RB,RD,RH,RSP),0)
C             CALL EMIT(DCX,(RB,RD,RH,RSP),0)
      INTEGER BITS(3),ALLOC
C
      N = 1
C
      IF (CONTRL(25).EQ.0) GO TO 100
C      WRITE EMITTER TRACE
      CALL PAD(0,16,1)
      CALL PAD(1,42,1)
      CALL CONOUT(2,-6,OPR,10)
      CALL PAD(1,48,1)
      IF (OPA.LT.0) CALL PAD(1,45,1)
      CALL CONOUT(2,-6,IABS(OPA),10)
      CALL PAD(1,48,1)
      IF (OPB.LT.0) CALL PAD(1,45,1)
      CALL CONOUT(2,-6,IABS(OPB),10)
      CALL PAD(1,43,1)
      CALL WRITEL(0)
100   IF (OPR.LE.0) GO TO 9000
      BITS(1) = CBITS(OPR)
      GO TO (1000,1500,1500,2000,2000,2000,2000,2000,2000,2000,2000,
     1  3000,4000,5000,4000,5000,10000,5100,7000,8000,8000,10000,
     2  9100,9100,9400,9999,9999,9999,9999,9999,9999,9100,9100,
     3  9999,9999,9200,9500,9300,9300,9300,9300,9300,9300)
     4    ,OPR
C
1000  CONTINUE
C     LOAD OPERATION
      IF (OPB.GT.0) GO TO 1200
C         LRI OPERATION
          N = 2
      BITS(1) = REGMAP(OPA)*8 + 6
          BITS(2) = - OPB
          GO TO 10000
1200  CONTINUE
C     CHECK FOR POSSIBLE LOAD REGISTER ELIMINATION
C     IS THIS A LMR OR LRM INSTRUCTION...
      IF (OPA.NE.ME) GO TO 1210
C         MAY CHANGE A MOV R,M INR R MOV M,R TO INR M
          IF (LASTIR.NE.CODLOC-1) GO TO 1205
              I = RIGHT(GET(CODLOC-1),3) + 48
C             THE REGISTER LOAD MAY HAVE BEEN ELIMINATED...
              IF (LASTLD.EQ.CODLOC-2.AND.OPB.EQ.LASTRG) GO TO 1202
                  CODLOC = CODLOC - 1
                  MEMBOT = MEMBOT - 1
1202          CONTINUE
              CALL PUT(CODLOC-1,I)
              LASTIR = 0
              LASTRG = 0
              LASTLD = 0
              IF (LASTIN.EQ.CODLOC.OR.LASTIN.EQ.CODLOC+1)
     1            LASTIN = CODLOC - 1
              GO TO 11000
1205      CONTINUE
C         THIS IS A LOAD MEMORY FROM REGISTER OPERATION - SAVE
          LASTLD = CODLOC
          LASTRG = OPB
          GO TO 1220
1210  IF (OPB.NE.ME) GO TO 1220
C         THIS IS A LOAD REGISTER FROM MEMORY - MAYBE ELIMINATE
          IF (LASTLD.NE.(CODLOC-1)) GO TO 1220
          IF (LASTRG.EQ.OPA) GO TO 11000
1220  CONTINUE
      BITS(1) = BITS(1) + REGMAP(OPA)*8 + REGMAP(OPB)
      GO TO 10000
C
C     IN OR DC
1500  CONTINUE
      BITS(1) = BITS(1) + REGMAP(OPA)*8
      GO TO 10000
C
2000  CONTINUE
C     AD AC SU SB ND XR OR CP
      IF (OPA.GT.0) GO TO 2200
C         IMMEDIATE OPERAND
          N = 2
      BITS(1) = BITS(1) + 70
          BITS(2) = - OPA
          GO TO 10000
C
2200  BITS(1) = BITS(1) + REGMAP(OPA)
      GO TO 10000
C
3000  CONTINUE
C     ROT
      I = (OPA-CY)*2 + (OPB-LFT)
      BITS(1) = BITS(1) + I*8
      GO TO 10000
C
C      JMP CAL
4000  CONTINUE
      N = 3
      I = OPA
4100  BITS(3) = I/256
      BITS(2) = MOD(I,256)
      GO TO 10000
C
C     JFC JTC CFC CTC
5000  CONTINUE
      N = 3
5100  I = MOD(OPA,32) - CARRY
      I = (I/2)*2 + MOD(I+1,2)
      J = OPA/32-FAL
      J = I*2 + J
      BITS(1) = BITS(1) + J*8
      I = OPB
      GO TO 4100
C
C     RET HLT
C     GO TO 10000
C
C     RST
7000  CONTINUE
      BITS(1) = BITS(1) + MOD(OPA,8)*8
      GO TO 10000
C
C     INP OUT
8000  CONTINUE
      N = 2
      BITS(2) = OPA
      GO TO 10000
C
C     LITERAL VALUE
9000  CONTINUE
      BITS(1) = OPA
      GO TO 10000
C     STA LDA SHLD LHLD (GET ADDRESS PART)
9100  N = 3
      BITS(3) = OPA/256
      BITS(2) = MOD(OPA,256)
      GO TO 10000
C
C     LXI (GET IMMEDIATE PART)
9200  N = 3
      BITS(3) = OPB/256
      BITS(2) = MOD(OPB,256)
C     AND DROP THROUGH...
C     LXI PUSH POP DAD STAX LDAX INX DCX
9300  I = REGMAP(OPA)
C     CHECK FOR ACC
      IF (I.EQ.7) I = 6
9310  CONTINUE
      BITS(1) = I*8 + BITS(1)
      GO TO 10000
C     XCHG - CHECK FOR PREVIOUS XCHG AND ELIMINATE IF FOUND
9400  CONTINUE
      IF (LASTEX.NE.(CODLOC-1)) GO TO 9410
          MEMBOT = MEMBOT - 1
          CODLOC = CODLOC - 1
          LASTEX = 0
          GO TO 11000
9410  LASTEX = CODLOC
      GO TO 10000
C     PUSH R - CHECK FOR XCHG PUSH D COMBINATION. CHANGE TO PUSH H
9500  IF (LASTEX.NE.(CODLOC-1)) GO TO 9300
      IF (OPA.NE.RD) GO TO 9300
          MEMBOT = MEMBOT - 1
          CODLOC = CODLOC - 1
          LASTEX = 0
          I = REGMAP(RH)
      GO TO 9310
C     XCHG SPHL PCHL CMA STC CMC DAA EI DI (NO ADDRESS PART)
9999  CONTINUE
C
10000 I = ALLOC(N)-1
      CODLOC = CODLOC + N
          DO 10100 J = 1,N
10100     CALL PUT(I+J,BITS(J))
C
11000 CONTINUE
      RETURN
      END
      SUBROUTINE PUNCOD(LB,UB,MODE)
C     PUNCH CODE FROM LOWER BOUND (LB) TO UPPER BOUND (UB)
C     MODE = 1  - - PUNCH HEADER ONLY
C     MODE = 2 - - PUNCH TRAILER ONLY
C     MODE = 3 - - PUNCH HEADER AND TRAILER
      INTEGER LB,UB,MODE
      INTEGER GET,L,U,LP,UP,K,KP,RIGHT,SHR
      INTEGER IMIN,J,ISUM
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER T(4)
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
C
      UP = UB
      LP = LB
      CALL WRITEL(0)
      IF (CONTRL(28).NE.0) GO TO 400
      T(1) = 25
      T(2) = 27
      T(3) = 13
      T(4) = 17
C
          DO 10 I=1,4
10        CALL PAD(1,47,20)
      CALL WRITEL(0)
C
      IF (MOD(LP,8).NE.0) CALL CONOUT(0,-8,LP,10)
100   IF(LP .GT. UP) GO TO 300
      IF(MOD(LP,4).NE.0) GO TO 200
      IF(MOD(LP,8).NE.0) GO TO 130
      IF(MOD(LP,256).NE.0) GO TO 120
C     *********
      CALL WRITEL(0)
          DO 110 I=1,4
110       CALL PAD(1,47,20)
C
120   CALL CONOUT(0,-8,LP,10)
      GO TO 200
C
130   CALL PAD(0,1,8)
C     DECODE A MEMORY LOCATION
200   CALL PAD(1,1,1)
      CALL FORM(1,T,3,3,4)
          K=GET(LP)
C
          DO 210 I=1,8
          KP = K/(2**(8-I))
          KP = MOD(KP,2)+1
210       CALL FORM(1,T,KP,KP,4)
C
      CALL FORM(1,T,4,4,4)
      LP = LP + 1
      GO TO 100
C
300   CALL WRITEL(0)
          DO 310 I=1,4
310       CALL PAD(1,47,20)
      CALL WRITEL(0)
      GO TO 9999
400   CONTINUE
C     WRITE ********
      IF (MOD(MODE,2).EQ.0) GO TO 402
      CALL PAD(0,47,20)
      CALL PAD(1,47,20)
402   CALL WRITEL(0)
      L = CONTRL(28)
      IF (L.LT.16) L=16
405   IF (LP.GT.UP) GO TO 500
      KP = UP - LP + 1
      K = IMIN(KP,L)
      IF (K.EQ.0) GO TO 500
      CALL PAD(1,51,1)
      CALL CONOUT(1,2,K,16)
      OBP = OBP - 1
      CALL CONOUT(1,4,LP,16)
      OBP = OBP - 1
      ISUM = K + RIGHT(LP,8) + SHR(LP,8)
      CALL CONOUT(1,2,0,16)
      OBP = OBP - 1
          DO 410 I = 1,K
          J = GET(LP)
          ISUM = ISUM + J
          LP = LP + 1
          CALL CONOUT(1,2,J,16)
          OBP = OBP - 1
410       CONTINUE
      ISUM = RIGHT(ISUM,8)
      ISUM = MOD(256-ISUM,256)
      CALL CONOUT(1,2,ISUM,16)
      OBP = OBP - 1
      CALL WRITEL(0)
      GO TO 405
500   CONTINUE
      IF ((MODE/2) .EQ. 0) GO TO 510
C     *****
C     WRITE END OF FILE RECORD
      CALL PAD(1,51,1)
      CALL PAD(1,2,10)
C
C     WRITE ***** AGAIN
      CALL PAD(0,47,20)
      CALL PAD(1,47,20)
510   CALL WRITEL(0)
9999  RETURN
      END
      SUBROUTINE CVCOND(S)
      INTEGER S
C     CONVERT THE CONDITION CODE AT S IN THE STACK TO A BOOLEAN VALUE
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      I = RASN(S)
      J = I/256
      K = MOD(J,16)
      J = J/16
      IA = MOD(I,16)
C     J = 1 IF TRUE , J = 0 IF FALSE
C
C     K = 1 IF CARRY, 2 IF ZERO, 3 IF SIGN, AND 4 IF PARITY
C
C     WE MAY GENERATE A SHORT SEQUENCE
      IF (K.GT.2.OR.IA.EQ.0) GO TO 40
      IF (REGS(1).NE.IA) GO TO 40
      IF (K.EQ.2) GO TO 10
C     SHORT CONVERSION FOR TRUE OR FALSE CARRY
      CALL EMIT(SB,RA,0)
      IF (J.EQ.0) CALL EMIT(CMA,0,0)
      GO TO 300
C     SHORT CONVERSION FOR TRUE OR FALSE ZERO
10    IF (J.EQ.0) CALL EMIT(AD,-255,0)
      IF (J.EQ.1) CALL EMIT(SU,-1,0)
      CALL EMIT(SB,RA,0)
      GO TO 300
C     DO WE HAVE TO ASSIGN A REGISTER
40    IF (IA.NE.0) GO TO 50
          CALL GENREG(1,IA,JP)
          IF (IA.NE.0) GO TO 60
              CALL ERROR(118,5)
              GO TO 9999
60        REGS(IA) = SP
          I = IA
C
C     CHECK PENDING REGISTER STORE
50    JP = REGS(1)
      IF (JP.EQ.0) GO TO 100
      IF (JP.EQ.IA) GO TO 100
          CALL EMIT(LD,JP,RA)
          REGS(1) = 0
C
100   CONTINUE
          CALL EMIT(LD,RA,-255)
          J = (FAL+J)*32 + (CARRY+K-1)
          CALL EMIT(JMC,J,CODLOC+4)
          CALL EMIT(XR,RA,0)
      GO TO 300
C
C     ACCUMULATOR CONTAINS THE BOOLEAN VALUE (0 OR 1)
300   CONTINUE
C     SET UP PENDING REGISTER STORE
      REGS(1) = IA
      RASN(S) = MOD(I,256)
9999  RETURN
      END
      SUBROUTINE SAVER
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
C     SAVE THE ACTIVE REGISTERS AND RESET TABLES
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
C     FIRST DETERMINE THE STACK ELEMENTS WHICH MUST BE SAVED
      IC1 = 0
      IC2 = 0
      I1 = 0
      I2 = 0
C
      IF (SP.EQ.0) GO TO 3000
      DO 1000 J=1,SP
      K = RASN(J)
      IF (K.GT.255) CALL CVCOND(J)
      IF (K.LE.0) GO TO 1000
      K = RASN(J)
      IF (K.GE.16) GO TO 800
C         SINGLE BYTE
          IF (LOCK(K).EQ.1) GO TO 1000
          ST(J) = I1
          IC1 = IC1 + 1
          I1 = J
          GO TO 1000
C
C         DOUBLE BYTE
800   L = MOD(K,16)
      K = K/16
      IF ((LOCK(L)+LOCK(K)).GT.0) GO TO 1000
      ST(J) = I2
      I2 = J
      IC2 = IC2 + 1
1000  CONTINUE
C
      LMEM = LMEM - IC1 - (IC2*2)
      IF  (((MOD(LMEM,2)*IC2).GT.0).AND.(IC1.EQ.0)) LMEM=LMEM-1
C     LMEM IS NOW PROPERLY ALIGNED.
      IF (LMEM.GE.0) GO TO 1100
          CALL ERROR(119,1)
          GO TO 99999
1100  CONTINUE
      K = LMEM
C
2000  IF ((I1+I2).EQ.0) GO TO 3000
      IF ((MOD(K,2).EQ.1).OR.(I2.EQ.0)) GO TO 2100
C     EVEN BYTE BOUNDARY WITH DOUBLE BYTES TO STORE
          I = I2
          I2 = ST(I)
          GO TO 2200
C
C      SINGLE BYTE
2100      I = I1
          I1 = ST(I)
2200   IF (I.GT.0) GO TO 2300
           CALL ERROR(120,1)
           GO TO 99999
C
C     PLACE TEMPORARY INTO SYMBOL TABLE
2300  SYTOP = SYTOP + 1
      ST(I) = SYTOP
      SYMBOL(SYTOP) = SYINFO
      J = RASN(I)
      L = 1
      IF (J.GE.16) L = 2
      SYMBOL(SYINFO) = K
      K = K + L
      SYINFO = SYINFO - 1
      SYMBOL(SYINFO) = 256 + L*16 + VARB
C     LENGTH IS 1*256
      SYINFO = SYINFO - 1
C     LEAVE ROOM FOR LXI CHAIN
      SYMBOL(SYINFO) = 0
      SYINFO = SYINFO - 1
      IF (SYTOP.LE.SYINFO) GO TO 2400
          CALL ERROR(121,5)
          GO TO 99999
C
2400  CONTINUE
C     STORE INTO MEMORY
      L = RASN(I)
      RASN (I) = 0
      SP = SP + 1
      CALL SETADR(SYTOP)
      CALL LITADD(SP)
2450  I = MOD(L,16)
      IF (I.NE.REGS(1)) GO TO 2500
          I = 1
          REGS(RA) = 0
          REGV(RA) = -1
2500  CONTINUE
      CALL EMIT(LD,ME,I)
      L = L / 16
      IF (L.EQ.0) GO TO 2700
C     DOUBLE BYTE STORE
      CALL EMIT(IN,RL,0)
      REGV(7) = REGV(7) + 1
      GO TO 2450
C
2700  CALL DELETE(1)
      GO TO 2000
C
C     END OF REGISTER STORES
3000  CONTINUE
      DO 4000 I=2,7
      IF (LOCK(I).EQ.1) GO TO 4000
      REGS(I) = 0
      REGV(I) = -1
4000  CONTINUE
99999 RETURN
      END
      SUBROUTINE RELOC
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      INTEGER INTPRO(8)
      COMMON /INTER/INTPRO
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER INLOC,OUTLOC,TIMLOC,CASJMP
      COMMON /BIFLOC/INLOC,OUTLOC,TIMLOC,CASJMP
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
      INTEGER RIGHT,SHL,SHR,GET
      INTEGER SMSSG(29)
      COMMON/SMESSG/SMSSG
      INTEGER STSIZE,STLOC
C
      IF (CONTRL(30).LT.2) GO TO 18
      DO 12 I=1,SYTOP
      CALL CONOUT(0,-4,I,10)
      CALL PAD(1,39,1)
      CALL CONOUT(1,-6,SYMBOL(I),10)
12    CONTINUE
C
      DO 14 I=SYINFO,SYMAX
      CALL CONOUT(0,-5,I,10)
      CALL PAD(1,39,1)
      J = SYMBOL(I)
      K = 45
      IF (J.GE.0) K = 1
      CALL PAD(1,K,1)
      CALL CONOUT(1,8,IABS(J),16)
14    CONTINUE
C
18    CONTINUE
C     COMPUTE MAX STACK DEPTH REQUIRED FOR CORRECT EXECUTION
      STSIZE = MAXDEP(1)
          DO 20 N=1,8
          I = INTPRO(N)
          IF (I.EQ.0) GO TO 20
C         GET INTERRUPT PROCEDURE DEPTH
          I = SYMBOL(I) - 3
          I = SYMBOL(I) + 1
C         NOTE THAT I EXCEEDS DEPTH BY 1 SINCE RET MAY BE PENDING
          STSIZE = STSIZE + I
20        CONTINUE
      STSIZE = STSIZE * 2
C
      N = STSIZE
      IF (CONTRL(47).NE.0) N = 0
C     ALIGN TO EVEN BOUNDARY, IF NECESSARY
      IF ((N.NE.0).AND.(MOD(LMEM,2).EQ.1)) LMEM=LMEM-1
      STLOC = LMEM
      LMEM = LMEM - N
C     STSIZE IS NUMBER OF BYTES REQD FOR STACK, STLOC IS ADDR
C
          IW = CONTRL(34)/14
          N = 0
C     COMPUTE PAGE TO START VARIABLES
      I = 0
      IF (MOD(CODLOC,256).GT.MOD(LMEM,256)) I = 1
      I = I+CODLOC/256
      IF (CONTRL(33).GT.I) I = CONTRL(33)
C
C     COMPUTE FIRST RELATIVE ADDRESS PAGE
      J = LMEM/256 - I
      IF (J.GE.0) GO TO 50
          CALL ERROR(122,1)
          GO TO 9999
50    DO 300 I=1,SYTOP
          M = SYMBOL(I)
          K = SYMBOL(M)
          IF (K.LT.0) GO TO 300
C
C     NOW FIX PAGE NUMBER
C
      L = RIGHT(SHR(K,8),8) - J
C     L IS RELOCATED PAGE NUMBER
      SYMBOL(M) = SHL(L,8)+RIGHT(K,8)
      K = SHR(K,16)
100   CONTINUE
      IF (K.EQ.0) GO TO 150
C     BACKSTUFF LHI L INTO LOCATION K-1
      IP = GET(K-1)*256+GET(K)
      CALL PUT(K-1,38)
      CALL PUT(K,L)
       K = IP
       GO TO 100
150   CONTINUE
C     BACKSTUFF LXI REFERENCES TO THIS VARIABLE
      K = SYMBOL(M-2)
      M = SYMBOL(M)
C     K IS LXI CHAIN HEADER, M IS REAL ADDRESS
160       IF (K.EQ.0) GO TO 300
          L = GET(K) + GET(K+1)*256
          CALL PUT(K,MOD(M,256))
          CALL PUT(K+1,M/256)
          K = L
          GO TO 160
300   CONTINUE
      IF (CONTRL(24).NE.0) CALL WRITEL(0)
C
C     RELOCATE AND BACKSTUFF THE STACK TOP REFERENCES
      STLOC = STLOC - J*256
310   IF (LXIS.EQ.0) GO TO 320
          I = LXIS
          LXIS = GET(I) + GET(I+1)*256
          CALL PUT(I,MOD(STLOC,256))
          CALL PUT(I+1,STLOC/256)
          GO TO 310
320   CONTINUE
      CALL FORM(0,SMSSG,1,11,29)
      IF (CONTRL(47).EQ.1) GO TO 330
      CALL FORM(1,SMSSG,12,13,29)
      CALL CONOUT(2,-10,STSIZE,10)
      CALL FORM(1,SMSSG,24,29,29)
      GO TO 340
330   CALL FORM(1,SMSSG,14,23,29)
340   CALL WRITEL(0)
C
C     NOW BACKSTUFF ALL OTHER TRC, TRA, AND PRO ADDRESSES
C
      DO 700 I = 1, SYTOP
          J = SYMBOL(I)
          K = -SYMBOL(J)
          L = IABS(SYMBOL(J-1))
          L = RIGHT(L,4)
          IF (L.NE.LABEL.AND.L.NE.PROC) GO TO 700
          L = RIGHT(SHR(K,2),14)
          N = RIGHT(K,2)
          K = SHR(K,16)
600       IF (L.EQ.0) GO TO 650
              M = GET(L) + GET(L+1) * 256
              CALL PUT(L,MOD(K,256))
              CALL PUT(L+1,K/256)
              L = M
          GO TO 600
650       SYMBOL(J) = SHL(K,16) + N
700   CONTINUE
      IF (PREAMB.LE.0) GO TO 900
          DO 710 I=1,8
          J = INTPRO(I)
          IF (J.EQ.0)  GO TO 710
              J = SYMBOL(J)
              J = IABS(SYMBOL(J))/65536
              INTPRO(I) = J*256 + 195
C             INTPRO CONTAINS INVERTED JUMP TO PROCEDURE
710       CONTINUE
      IF (INTPRO(1).EQ.0) INTPRO(1) = (OFFSET+PREAMB)*256+195
C     ** NOTE THAT JUMP INST IS 11000011B = 195D **
      K = OFFSET
      OFFSET = 0
      I = 0
      J = 1
720   L = INTPRO(J)
      J = J + 1
730       CALL PUT(I,MOD(L,256))
          L = L/256
          I = I + 1
          IF (I.GE.PREAMB) GO TO 740
          IF (MOD(I,8).EQ.0) GO TO 720
          GO TO 730
C
740   OFFSET = K
900   CONTINUE
9999  RETURN
      END
      SUBROUTINE LOADIN
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER GNC,RIGHT,SHL,SHR,GET
C     SAVE THE CURRENT INPUT FILE NUMBER
      M = CONTRL(20)
      CONTRL(20) = CONTRL(32)
C     GET RID OF LAST CARD IMAGE
      IBP = 99999
5     I = GNC(0)
      IF (I.EQ.1) GO TO 5
      IF (I.NE.41) GO TO 8000
C
C     PROCESS NEXT SYMBOL TABLE ENTRY
100   I = GNC(0)
      IF (I.EQ.41) GO TO 9999
C
      I = I - 2
C     BUILD ADDRESS OF INITIALIZED SYMBOL
      K = 32
          DO 200 J=1,2
          I = (GNC(0)-2)*K+I
200       K = K * 32
C
      J = SYMBOL(I)
      K = SYMBOL(J-1)
      K = MOD(K/16,16)
      J = SYMBOL(J)
C     J IS STARTING ADDRESS, AND K IS THE PRECISION OF
C     THE BASE VARIABLE
      IF (CODLOC.LE.J) GO TO 300
          CALL ERROR(123,1)
300   IF (CODLOC.GE.J) GO TO 350
          CALL PUT(CODLOC,0)
          CODLOC = CODLOC + 1
          GO TO 300
C
C     READ HEX VALUES UNTIL NEXT '/' IS ENCOUNTERED
350   LP = - 1
400   LP = LP + 1
      I = GNC(0) - 2
C     CHECK FOR ENDING /
      IF (I.EQ.39) GO TO 100
      L = I/16
      I = MOD(I,16)*16+(GNC(0)-2)
C     I IS THE NEXT HEX VALUE, AND L=1 IF BEGINNING OF A NEW BVALUE
          IF (K.NE.2) GO TO 1000
C         DOUBLE BYTE INITIALIZE
          IF (L.NE.0) GO TO 500
C         CHECK FOR LONG CONSTANT
          IF (LP.LT.2) GO TO 600
500       LP = 0
              CALL PUT(CODLOC,I)
              CALL PUT(CODLOC+1,0)
          GO TO 1100
C
C         EXCHANGE PLACES WITH H.O. AND L.O. BYTES
600           N = GET(CODLOC-2)
              CALL PUT(CODLOC-1,N)
              CALL PUT(CODLOC-2,I)
          GO TO 400
C
1000          CALL PUT(CODLOC,I)
1100           CODLOC = CODLOC + K
          GO TO 400
C
C
8000  CALL ERROR(124,1)
9999  CONTINUE
      CONTRL(20) = M
      RETURN
      END
      SUBROUTINE EMITBF(L)
C     EMIT CODE FOR THE BUILT-IN FUNCTION L.  THE BIFTAB
C     ARRAY IS HEADED BY A TABLE WHICH EITHER GIVES THE STARTING
C     LOCATION OF THE BIF CODE IN BIFTAB (IF NEGATIVE) OR THE
C     ABSOLUTE CODE LOCATION OF THE FUNCTION IF ALREADY
C     EMITTED.
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER GET,ALLOC
      INTEGER BIFTAB(41),BIFPAR
      COMMON /BIFCOD/BIFTAB,BIFPAR
      I = BIFTAB(L)
      IF (I.GE.0) GO TO 1000
C     CODE NOT YET EMITTED
      I = -I
      CALL EMIT(JMP,0,0)
C     BACKSTUFF ADDRESS LATER
      BIFTAB(L) = CODLOC
C     GET NUMBER OF BYTES TO EMIT
      K = BIFTAB(I)
      I = I + 1
C     THEN THE NUMBER OF RELATIVE ADDRESS STUFFS
      KP = BIFTAB(I)
      I = I + 1
C     START EMITTING CODE
      M = I + KP
      JP = 0
100   IF (JP.GE.K) GO TO 200
      IF (MOD(JP,3).NE.0) GO TO 110
          N = BIFTAB(M)
          M = M + 1
110   LP = ALLOC(1)
      CALL PUT(CODLOC,MOD(N,256))
      N = N/256
      CODLOC = CODLOC + 1
      JP = JP + 1
      GO TO 100
C
C     NOW GO BACK AND REPLACE RELATIVE ADDRESSES WITH
C     ABSOLUTE ADDRESSES.
C
200   JP = 0
      N = BIFTAB(L)
300   IF (JP.GE.KP) GO TO 400
      M = BIFTAB(I)
      I = I + 1
      K = GET(N+M) + GET(M+N+1)*256 + N
      CALL PUT(N+M,MOD(K,256))
      CALL PUT(N+M+1,K/256)
      JP = JP + 1
      GO TO 300
C
400   CONTINUE
      I = BIFTAB(L)
C     BACKSTUFF BRANCH AROUND FUNCTION
      CALL PUT(I-2,MOD(CODLOC,256))
      CALL PUT(I-1,CODLOC/256)
C
C     EMIT CALL ON THE FUNCTION
1000  CALL EMIT(CAL,I,0)
      RETURN
      END
      SUBROUTINE INLDAT
      INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER POLCHR(18),OPCVAL(51)
      COMMON /OPCOD/POLCHR,OPCVAL
      INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /ILCOD/ OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
C     EMIT DATA INLINE
      IQ = CODLOC
      L = 0
100   K = 0
          IF (LAPOL.EQ.0) GO TO 600
          DO 200 J=1,3
150       I = GNC(0)
          IF (I.EQ.1) GO TO 150
          IF ((I.LT.2).OR.(I.GT.33)) GO TO 600
200       K = K *32 + I - 2
C
      I = K
      K = LAPOL
      LAPOL = I
C
      KP = MOD(K,8)
      K = K / 8
C     KP IS TYP AND K IS DATA
      IF (L.GT.0) GO TO 300
C
C     DEFINE INLINE DATA SYMBOL
      IF (KP.NE.DEF) GO TO 600
      IC = K
      IF (K.GT.0) GO TO 400
C     INLINE CONSTANT -- SET UP SYMBOL ENTRY
      SYTOP = SYTOP + 1
      IC = - SYTOP
      SYMBOL(SYTOP) = SYINFO
      SYINFO = SYINFO - 2
C     WILL BE FILLED LATER
      IF (SYINFO.LT.SYTOP) GO TO 600
      GO TO 400
C
C     READ DATA AND STORE INTO ROM
300   CONTINUE
      IF (KP.EQ.OPR) GO TO 500
      IF (KP.NE.LIT) GO TO 600
      CALL EMIT(0,K,0)
400   L = L + 1
      GO TO 100
C
C     END OF DATA
500   CONTINUE
      IF (K.NE.DAT) GO TO 600
C     BACKSTUFF JUMP ADDRESS
C     NOW FIX SYMBOL TABLE ENTRIES
      K = IABS(IC)
      L = L - 1
      K = SYMBOL(K)
      SYMBOL(K) = - IQ
      K = K - 1
      J = SYMBOL(K)
C     CHECK SYMBOL LENGTH AGAINST COUNT
      J = J/256
      SYMBOL(K) = L*256+16+VARB
      IF (IC.LT.0) GO TO 550
C     CHECK SIZE DECLARED AGAINST SIZE READ
      IF (J.EQ.L) GO TO 1000
C
600   CONTINUE
      IF (KP.NE.LIN) GO TO 700
      CONTRL(14) = K
      GO TO 100
700   CALL ERROR(125,1)
      GO TO 1000
C
C     THIS IS AN ADDRESS REFERENCE TO A CONSTANT, SO..
550   SP = SP + 1
      ST(SP) = IC
      RASN(SP) = 0
      LITV(SP) = IQ
      PREC(SP) = 2
C
C
1000  CONTINUE
2000  RETURN
      END
      SUBROUTINE UNARY(IVAL)
      INTEGER IVAL,VAL
C     'VAL' IS AN INTEGER CORRESPONDING TO THE OPERATIONS--
C     RTL(1) RTR(2) SFL(3) SFR(4) SCL(5) SCR(6) HIV(7) LOV(8)
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
C     ** NOTE THAT THE FOLLOWING CODE ASSUMES THE VALUE OF RTL = 37
      VAL = IVAL - 36
      IF (RASN(SP).GT.255) CALL CVCOND(SP)
      IP = PREC(SP)
      GO TO (1000,1000,3000,3000,3000,3000,9990,5000,6000),VAL
C     RTL RTR
1000  CONTINUE
      IF (IP.GT.1) GO TO 9990
      IF (RASN(SP).NE.0) GO TO 1100
          CALL LOADV(SP,1)
          REGS(1) = MOD(RASN(SP),16)
1100  I = MOD(RASN(SP),16)
      K = REGS(1)
      IF (K.EQ.0) GO TO 1200
      IF (K.EQ.I) GO TO 1300
          CALL EMIT(LD,K,RA)
1200      CALL EMIT(LD,RA,I)
      REGS(1) = I
1300  I = LFT
      IF (VAL.EQ.2) I = RGT
      CALL EMIT(ROT,CY,I)
      GO TO 9999
C
C     SFL SFR  SCL SCR
3000  CONTINUE
      J = 1
      IF (((VAL.EQ.4).OR.(VAL.EQ.6)).AND.(IP.GT.1)) J =0
      I = RASN(SP)
      IF (I.GT.0) GO TO 3100
C
C         LOAD FROM MEMORY
          CALL LOADV(SP,J)
          I = RASN(SP)
           IF (J.EQ.1) REGS(1) = MOD(I,16)
C
C     MAY HAVE TO STORE THE ACCUMULATOR
3100  IA = MOD(I,16)
      IB = I/16
      K = IA
      IF (J.NE.1) K = IB
      JP = REGS(1)
C     WE WANT REGISTER K TO BE IN THE ACCUMULATOR
      IF (JP.EQ.K) GO TO 3200
      IF (JP.EQ.0) GO TO 3150
          CALL EMIT(LD,JP,RA)
3150      CALL EMIT(LD,RA,K)
3200  REGS(1) = K
C
C     SFL AND SFR TAKE SEPARATE PATHS NOW...
      IF ((VAL.EQ.4).OR.(VAL.EQ.6)) GO TO 4000
C
C     SFL - CLEAR CARRY AND SHIFT
          IF (VAL.EQ.3) CALL EMIT(AD,RA,RA)
          IF (VAL.EQ.5) CALL EMIT(ROT,ACC,LFT)
          IF (IP.LT.2) GO TO 9999
          CALL EMIT(LD,IA,RA)
          CALL EMIT(LD,RA,IB)
          CALL EMIT(ROT,ACC,LFT)
          REGS(1) = IB
          GO TO 9999
C
C     SFR - ACCUMULATOR CONTAINS VALUE TO SHIFT FIRST
4000  CONTINUE
          IF (VAL.EQ.4) CALL EMIT(OR,RA,0)
          CALL EMIT(ROT,ACC,RGT)
          IF (IP.LT.2) GO TO 9999
          CALL EMIT(LD,IB,RA)
          CALL EMIT(LD,RA,IA)
          CALL EMIT(ROT,ACC,RGT)
          REGS(1) = IA
          GO TO 9999
C
C     HIV
5000  CONTINUE
      IF (IP.LT.2) GO TO 9990
      IF (RASN(SP).GT.0) GO TO 5100
          CALL LOADV(SP,0)
5100  I = RASN(SP)
      IP = MOD(I/16, 16)
      IQ = MOD(I, 16)
      IF (REGS(1) .EQ. IQ) REGS(1) = 0
      REGS(IP) = 0
      REGV(IP) = -1
      RASN(SP) = IQ
      PREC(SP) = 1
      IF (REGS(1) .NE. IP) GO TO 5200
      REGS(1) = IQ
      GO TO 9999
5200  CALL EMIT (LD, IQ, IP)
      GO TO 9999
C
C     LOV
6000  CONTINUE
      PREC(SP) = 1
C     MAY HAVE TO RELEASE REGISTER
      I = RASN(SP)
      RASN(SP) = MOD(I,16)
      I = I/16
      IF (I.EQ.0) GO TO 9999
      REGS(I) = 0
      REGV(I) = -1
      IF (REGS(1).EQ.I) REGS(1) = 0
      GO TO 9999
C
9990  CALL ERROR(126,1)
9999  RETURN
      END
      SUBROUTINE EXCH
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
C     EXCHANGE THE TOP TWO ELEMENTS OF THE STACK
      J = SP-1
      IF ((ST(J).NE.0).OR.(RASN(J).NE.0).OR.(LITV(J).GE.0)) GO TO 40
C     SECOND ELEMENT IS PUSHED - CHECK TOP ELT
      IF ((RASN(SP).EQ.0).AND.(LITV(SP).LT.0)) GO TO 30
C     TOP ELT IS IN CPU REGS
C
C     ASSUME THERE WILL BE AN IMMEDIATE OPERATION, SO ALLOW
C          REG/PUSH TO BE CHANGED TO PUSH/REG
      GO TO 40
C
C     POP ELEMENT (SECOND IF DROP THRU, TOP IF FROM 30)
20        CALL GENREG(-1,IA,IB)
          IF (IA.NE.0) GO TO 25
              CALL ERROR(107,5)
              GO TO 40
25        IF (PREC(J).GT.1) IB = IA - 1
          CALL EMIT(POP,IA-1,0)
          CALL USTACK
          REGS(IA) = J
          IF (IB.NE.0) REGS(IB) = J
          RASN(J) = IB*16 + IA
          IF (J.NE.SP) GO TO 40
          J = SP - 1
          GO TO 20
C     SECOND ELT IS PUSHED, TOP ELT IS NOT IN CPU
30    IF (ST(SP).NE.0) GO TO 40
C     BOTH ARE PUSHED, SO GO THRU 20 TWICE
          J = SP
          GO TO 20
C
40    J = SP-1
      DO 100 I=2,7
      IF (REGS(I).NE.SP) GO TO 50
          REGS(I) = J
          GO TO 100
50    IF (REGS(I).EQ.J) REGS(I) = SP
100   CONTINUE
      I = PREC(SP)
      PREC(SP) = PREC(J)
      PREC(J) = I
C
      I = RASN(SP)
      RASN(SP) = RASN(J)
      RASN(J) = I
C
      I = ST(SP)
      ST(SP) = ST(J)
      ST(J) = I
C
      I = LITV(SP)
      LITV(SP) = LITV(J)
      LITV(J) = I
C
      RETURN
      END
      SUBROUTINE STACK(N)
C     ADD N TO CURRENT DEPTH, TEST FOR STACKSIZE EXC MAXDEPTH
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
      K = PRSP+1
      J = CURDEP(K) + N
      IF (J.GT.MAXDEP(K)) MAXDEP(K) = J
      CURDEP(K) = J
      RETURN
      END
      SUBROUTINE READCD
      INTEGER TERR(22)
      LOGICAL ERRFLG
      COMMON/TERRR/TERR,ERRFLG
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
      INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      INTEGER XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL
      COMMON /XFROPT/XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER STHEAD(12)
      COMMON/STHED/STHEAD
      INTEGER INTPRO(8)
      COMMON /INTER/INTPRO
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER POLCHR(18),OPCVAL(51)
      COMMON /OPCOD/POLCHR,OPCVAL
      INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER INLOC,OUTLOC,FIRSTI,CASJMP
      COMMON /BIFLOC/INLOC,OUTLOC,FIRSTI,CASJMP
      INTEGER OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /ILCOD/ OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      INTEGER LLOC,LLINE,LCNT
      INTEGER ALLOC
      CONTRL(14) = 1
      LLINE = 0
      LLOC = 0
      LCNT = CONTRL(34)/12
      ALTER = 0
      M = CONTRL(20)
      CONTRL(20) = CONTRL(21)
      POLCNT = 0
C     RESERVE SPACE FOR INTERRUPT LOCATIONS
          DO 10 I=1,8
          II = 9-I
          IF (INTPRO(II).NE.0) GO TO 20
10        CONTINUE
      PREAMB = 0
      GO TO 22
20    PREAMB = (II-1)*8+3
C     ADJUST CODLOC TO ACCOUNT FOR PREAMBLE
22    IF (CODLOC.LT.PREAMB) CODLOC = PREAMB
C     ALLOCATE 'PREAMBLE' CELLS AT START OF CODE
      I = ALLOC(PREAMB)
      OFFSET = CODLOC - PREAMB
C     SET STACK POINTER UPON PROGRAM ENTRY
      J = CONTRL(47)
      IF (J.EQ.1) GO TO 100
      IF (J.NE.0) GO TO 90
C     START CHAIN OF LXIS
      LXIS = CODLOC+1
90    CALL EMIT(LXI,RSP,J)
100   CONTINUE
      IF (ERRFLG) GO TO 9000
      IBASE = 0
C     MAY HAVE BEEN STACK OVERFLOW SO...
      IF (SP.LT.0) SP = 0
      IF (CONTRL(12).EQ.0) GO TO 10700
      IF ((ALTER.EQ.0).OR.(SP.LE.0)) GO TO 10700
C     WRITE STACK
      CALL PAD(0,1,1)
      CALL PAD(0,1,2)
      CALL FORM(1,STHEAD,1,2,12)
      CALL PAD(1,1,3)
      CALL FORM(1,STHEAD,3,4,12)
      CALL PAD(1,1,3)
      CALL FORM(1,STHEAD,5,8,12)
      CALL PAD(1,1,2)
      CALL FORM(1,STHEAD,9,12,12)
      CALL WRITEL(0)
          DO 10600 I=1,SP
          IP = SP - I + 1
          K = PREC(IP)
          CALL CONOUT(0,2,IP,10)
          CALL CONOUT(1,-2,K,10)
          CALL PAD(1,1,1)
          J = ST(IP)
          IF (J.EQ.0) GO TO 10200
          K = 30
          IF (J.GE.0) GO TO 10100
          K = 12
          J = -J
10100     CALL PAD(1,K,1)
          CALL CONOUT(1,5,J,10)
          GO TO 10300
C
10200     CALL PAD(1,1,6)
10300     CALL PAD(1,1,1)
          K = RASN(IP)
              DO 10400 J=1,2
              L = RIGHT(SHR(K,(2-J)*4),4)+11
              IF (L.EQ.11) L = 45
              CALL PAD(1,1,1)
10400         CALL PAD(1,L,1)
C
          K = LITV(IP)
          IF (K.LT.0) GO TO 10600
          L = 1
          IF (SHR(K,16).EQ.0) GO TO 10500
          L = 29
          K = RIGHT(K,16)
10500     CALL PAD(1,1,1)
          CALL PAD(1,L,1)
          CALL CONOUT(1,5,K,10)
10600     CALL WRITEL(0)
C     WRITE REGISTERS
      IF (CONTRL(12) .LT. 2) GO TO 10700
          DO 10650 I=1,7
          IP = REGS(I)
          KP = LOCK(I)
          LP = REGV(I)
          IF ((KP+IP+LP).LT. 0) GO TO 10650
              CALL PAD(1,1,1)
              CALL PAD(1,I+11,1)
              CALL PAD(1,42,1)
              K = 32
              IF (KP.EQ.1) K=23
              CALL PAD(1,K,1)
              CALL PAD(1,48,1)
              IF (IP.EQ.0) GO TO 10610
                  CALL CONOUT(1,2,IP,10)
                  GO TO 10620
10610             CALL PAD(1,47,1)
10620         CALL PAD(1,48,1)
              IF (LP.LT.0) GO TO 10630
                  CALL CONOUT(2,-10,LP,16)
                  GO TO 10640
10630             CALL PAD(1,47,1)
10640         CALL PAD(1,43,1)
10650     CONTINUE
      CALL WRITEL(0)
C
10700 K = 0
          IF (LAPOL.EQ.0) GO TO 250
          DO 200 J=1,3
110       I = GNC(0)
          IF(I.EQ.1) GO TO 110
          IF((I.GE.2) .AND.(I.LE.33)) GO TO 150
              CALL ERROR(127,5)
              GO TO 99999
150       K = K * 32 + (I-2)
200       CONTINUE
C
C     COPY THE ELT JUST READ TO THE POLISH LOOK-AHEAD, AND
C     INTERPRET THE PREVIOUS ELT
C
250   I = K
      K = LAPOL
      LAPOL = I
C     READ AGAIN (ONLY ON FIRST ARRIVAL HERE) IF ELT IS NULL
      IF (K.LT.0) GO TO 10700
C
C     CHECK FOR END OF CODE
      IF (K.EQ.0) GO TO 9000
      POLCNT = POLCNT + 1
      TYP = RIGHT(K,3)
      VAL = SHR(K,3)
C     $G=0 FOR NO TRACE, $G=1 GIVES LINES VS LOCS,
C     $G=2 YIELDS FULL INTERLIST OF I.L.
      I = CONTRL(18)
      IF (I.EQ.0) GO TO 2000
      IF (I.GT.1) GO TO 900
C
C     PRINT LINE NUMBER = CODE LOCATION, IF ALTERED
      IF ((LLINE.EQ.CONTRL(14)).OR.(LLOC.EQ.CODLOC)) GO TO 2000
C     CHANGED COMPLETELY, SO PRINT IT
      LLINE = CONTRL(14)
      LLOC = CODLOC
      I = 1
      IF (LCNT.GT.0) GO TO 300
          LCNT = CONTRL(34)/12
          I = 0
300   LCNT = LCNT - 1
      CALL PAD(I,1,1)
      CALL CONOUT(1,-4,LLINE,10)
      CALL PAD(1,39,1)
      CALL CONOUT(1,4,LLOC,16)
      GO TO 2000
C
C     OTHERWISE INTERLIST THE I.L.
900       CALL CONOUT(0,5,CODLOC,10)
          CALL PAD(1,1,1)
          CALL CONOUT(1,4,CODLOC,16)
          CALL PAD(1,1,1)
          CALL CONOUT(1,-5,POLCNT,10)
          CALL PAD(1,1,1)
          I = TYP*3+1
          CALL FORM(1,POLCHR,I,I+2,18)
          CALL PAD(1,1,1)
          I = TYP + 1
          J = 1
      GO TO (1000,1001,1001,1001,1004,1004),I
1000  J = OPCVAL(VAL+1)
          DO 400 I=1,3
          KP = SHR(J,(3-I)*6)
          CALL PAD(1,RIGHT(KP,6),1)
400       CONTINUE
C
      GO TO 1100
C
1001  J = 30
1004  CALL PAD(1,J,1)
      CALL CONOUT(1,5,VAL,10)
1100  CONTINUE
      CALL WRITEL(0)
C
2000  CONTINUE
      TYP = TYP+1
      SP = SP + 1
      IF (SP.LE.MAXSP) GO TO 2100
C         STACK OVERFLOW
          CALL ERROR(128,5)
          SP = 1
2100  PREC(SP) = 0
      ST(SP) = 0
      RASN(SP) = 0
      LITV(SP) = -1
      ALTER = 0
      GO TO (3000,4000,5000,6000,7000,8000),TYP
C     OPERATOR
3000  SP = SP - 1
      CALL OPERAT(VAL)
      GO TO 100
C     LOAD ADDRESS
4000  CONTINUE
      IF (SP.LE.1) GO TO 4010
C     CHECK FOR ACTIVE CONDITION CODE WHICH MUST BE CHANGED TO BOOLEAN
      IF (RASN(SP-1).GT.255) CALL CVCOND(SP-1)
4010  I = SYMBOL(VAL)
      J = SYMBOL(I-1)
      IF (J.GE.0) GO TO 4500
C     LOAD ADDRESS OF BASED VARIABLE.  CHANGE TO
C     LOAD VALUE OF THE BASE, USING THE VARIABLE'S PRECISION
          IBASE = RIGHT(SHR(-J,4),4)
          VAL = SYMBOL(I-2)
      GO TO 5000
4500  CALL SETADR(VAL)
      GO TO 100
C     LOAD VALUE
5000  CONTINUE
      I = SYMBOL(VAL)
      J = SYMBOL(I-1)
      IF (SP.LE.1) GO TO 5010
C     ALLOW ONLY A LABEL VARIABLE TO BE STACKED
      IF(MOD(IABS(J),16).EQ.LABEL) GO TO 5010
C     CHECK FOR ACTIVE CONDITION CODE WHICH MUST BE CHANGED TO BOOLEAN
      IF (RASN(SP-1).GT.255) CALL CVCOND(SP-1)
5010  CONTINUE
C     CHECK FOR CONDITION CODES
      IF (VAL.GT.INTBAS) GO TO 5400
      IF (VAL.LE.4) GO TO 5100
C     MAY BE A CALL TO INPUT OR OUTPUT
      IF ((VAL.GE.FIRSTI).AND.(VAL.LE.INTBAS)) GO TO 5400
C     CHECK FOR REFERENCE TO 'MEMORY'
C     ** NOTE THAT 'MEMORY' MUST BE AT LOCATION 5 IN THE SYMBOL TABLE **
      IF (VAL.EQ.5) GO TO 5400
C     ** NOTE THAT 'STACKPTR' MUST BE AT 6 IN SYM TAB
      IF (VAL.EQ.6) GO TO 5300
          CALL ERROR(129,1)
          GO TO 100
C     CARRY ZERO MINUS PARITY
C     SET TO TRUE/CONDITION (1*16+VAL)
5100  RASN(SP) = (16+VAL)*256
      ST(SP) = 0
      PREC(SP) = 1
      ALTER = 1
      GO TO 100
5300  CONTINUE
C     LOAD VALUE OF STACKPOINTER TO REGISTERS IMMEDIATELY
      CALL GENREG(2,IA,IB)
      IF (IB.NE.0) GO TO 5310
          CALL ERROR(107,5)
          GO TO 100
5310  RASN(SP) = IB*16+IA
      LITV(SP) = -1
      ST(SP) = 0
      REGS(IA) = SP
      REGS(IB) = SP
      PREC(SP) = 2
      CALL EMIT(LXI,RH,0)
      CALL EMIT(DAD,RSP,0)
      CALL EMIT(LD,IA,RL)
      CALL EMIT(LD,IB,RH)
      REGV(RH) = -1
      REGV(RL) = -1
      ALTER = 1
      GO TO 100
5400  IF (J.GE.0) GO TO 5500
C
C     VALUE REFERENCE TO BASED VARIABLE. FIRST INSURE THAT THIS
C     IS NOT A LENGTH ATTRIBUTE REFERENCE, (I.E., THE VARIABLE IS
C     NOT AN ACTUAL PARAMETER FOR A CALL ON LENGTH OR LAST) BY
C     INSURING THAT THE NEXT POLISH ELT IS NOT AN ADDRESS
C     REFERENCE TO SYMBOL (LENGTH+1) OR (LAST+1)
C     NOTE THAT THIS ASSUMES LENGTH AND LAST ARE SYMBOL NUMBERS
C     18 AND 19
C
      IF (LAPOL.EQ.153.OR.LAPOL.EQ.161) GO TO 5500
C     LOAD VALUE OF BASE VARIABLE.  CHANGE TO LOAD
C     VALUE OF BASE, FOLLOWED BY A LOD OP.
          IBASE = RIGHT(SHR(-J,4),4) + 16
          VAL = SYMBOL(I-2)
          I = SYMBOL(VAL)
          J = SYMBOL(I-1)
5500  ALTER = 1
C         EXAMINE ATTRIBUTES
          ST(SP) = VAL
          I = RIGHT(J,4)
          J = SHR(J,4)
          K = RIGHT(J,4)
          IF (IBASE.GT.0) K = MOD(IBASE,16)
          PREC(SP) = K
          IF (I.LT.(LITER-1)) GO TO 5800
          IF ((K.GT.0).AND.(K.LT.3)) GO TO 5900
              CALL ERROR(130,1)
              GO TO 100
5900          LITV(SP) = RIGHT(SHR(J,4),16)
5800  CONTINUE
C     CHECK FOR BASE ADDRESS WHICH MUST BE LOADED
      IF (IBASE.LT.16) GO TO 100
C     MUST BE A BASED VARIABLE VALUE REFERENCE.
C     LOAD THE VALUE OF THE BASE AND FOLLOW IT BY
C     A LOAD OPERATION.
      K = PREC(SP)
C     MARK AS A BYTE LOAD FOR THE LOD OPERATION IN OPERAT
C     LEAVES 2 IF DOUBLE BYTE RESULT AND 6 (=2 MOD 4) IF SINGLE BYTE
      PREC(SP) = 10 - 4*K
      CALL OPERAT(LOD)
      GO TO 100
C
C     DEFINE LOCATION
6000  CONTINUE
C     MARK LAST REGISTER LOAD NIL
      LASTRG = 0
      LASTEX = 0
      LASTIN = 0
      LASTIR = 0
      SP = SP - 1
C     SAVE REGISTERS IF THIS IS A PROC OR A LABEL WHICH WAS
C     REFERENCED IN A GO-TO STATEMENT OR WAS COMPILER-GENERATED.
      IP = SYMBOL(VAL)
      I = IABS(SYMBOL(IP-1))
C
C     SAVE THIS DEF SYMBOL NUMBER AND THE LITERAL VALUES OF THE
C     H AND L REGISTERS FOR POSSIBLE TRA CHAIN STRAIGHTENING.
C
      IF(RIGHT(I,4).NE.LABEL) GO TO 6001
      DEFSYM = VAL
      DEFRH = REGV(RH)
      DEFRL = REGV(RL)
C
C     WE MAY CONVERT THE SEQUENCE
C
C          TRC L, TRA/PRO/RET, DEF L
C
C     TO AN EQUIVALENT CONDITIONAL TRA/PRO/RET...
C
6001  IF (I/256.NE.1) GO TO 6004
      IF (TSTLOC.NE.CODLOC) GO TO 6004
      IF (CONLOC.NE.XFRLOC-3) GO TO 6004
      J = -SYMBOL(IP)
      K = RIGHT(SHR(J,2),14)
      IF (K.NE.CONLOC+1) GO TO 6004
C
C
C     ADJUST BACKSTUFFING CHAIN FOR JMP OR CALL
C
      IF (XFRSYM.LE.0) GO TO 6002
      K = SYMBOL(XFRSYM)
C     DECREMENT BACKSTUFF LOCATION BY 3
      SYMBOL(K) = SYMBOL(K) + 12
6002  CONTINUE
C     ARRIVE HERE WITH THE CONFIGURATION TRC...DEF
C
          SYMBOL(IP) = -(SHL(SHR(J,16),16)+RIGHT(J,2))
          K = MOD(IABS(SYMBOL(IP-1)),256)
          IF (SYMBOL(IP-1).LT.0) K = -K
          SYMBOL(IP-1) = K
          J = GET(CONLOC)
      J = GET(CONLOC)
      J = SHR(J,3)
      K = MOD(MOD(J,2)+1,2)
      K = SHL(SHR(J,1),1)+K
      J = GET(XFRLOC)
      L = RIGHT(SHR(J,1),2)
      J = SHL(K,3) + SHL(L,1)
6003          CALL PUT(CONLOC,J)
              CONLOC = CONLOC + 1
              XFRLOC = XFRLOC + 1
              J = GET(XFRLOC)
              IF (XFRLOC.NE.CODLOC) GO TO 6003
          CODLOC = CONLOC
          MEMBOT = MEMBOT - 3
          CONLOC = -1
          XFRLOC = -1
          TSTLOC = -1
C
C     NOTICE THAT DEFRH AND DEFRL ARE NOW INCORRECT
C     DEFSYM=0 PREVENTS USE OF THESE VARIABLES...
C     ... IF A TRA IMMEDIATELY FOLLOWS
C
          DEFSYM = 0
6004  CONTINUE
      J = RIGHT(I,4)
      IF (J.NE.LABEL) GO TO 6005
C         LABEL FOUND.  CHECK FOR REFERENCE TO LABEL
          I = I/256
          IF (I.EQ.0) GO TO 6020
C     CHECK FOR SINGLE REFERENCE, NO CONFLICT WITH H AND L
      IF (I.NE.1) GO TO 6010
      I = SYMBOL(IP-2)
C     CHECK FOR PREVIOUS REFERENCE  FORWARD
      IF (I.EQ.0) GO TO 6010
      L = MOD(I,256)
      I = I/256
      J = MOD(I,512)
      I = I/512
      IF (MOD(I,2).NE.1) L = -1
      IF (MOD(I/2,2).NE.1) J = -1
C     J IS H REG, L IS L REG
      LOCK(6) = 1
      LOCK(7) = 1
      CALL SAVER
C     COMPARE OLD HL WITH NEW HL
      LOCK(6) = 0
      LOCK(7) = 0
      K = REGV(6)
      REGV(6) = -1
      IF ((K.EQ.-255).OR.(K.EQ.J)) REGV(6) = J
      K = REGV(7)
      REGV(7) = -1
      IF ((K.EQ.-255).OR.(K.EQ.L)) REGV(7) = L
      GO TO 6020
C
C     OTHERWISE NOT A LABEL, CHECK FOR PROCEDURE ENTRY
6005  CONTINUE
      IF (J.NE.PROC) GO TO 6010
C         SET UP PROCEDURE STACK FOR PROCEDURE ENTRY
          PRSP = PRSP + 1
          IF (PRSP.LE.PRSMAX) GO TO 6008
              CALL ERROR(145,5)
              GO TO 6010
6008      J = IP - 2
          PRSTK(PRSP) = J
C         MARK H AND L AS UNALTERED INITIALLY
C          /  1B  /  1B  /  1B  /  1B  /  9B  /  8B  /
C          /H UNAL/L UNAL/H VALD/L VALD/H VALU/L VALU/
C          -------------------------------------------
          SYMBOL(J) = SHL(3,19)
          CALL SAVER
          REGV(6) = -254
          REGV(7) = -254
          K=CODLOC
C         SET UP STACK DEPTH COUNTERS
          MAXDEP(PRSP+1) = 0
          CURDEP(PRSP+1) = 0
          DO 6009 I=1,8
          IF (VAL.NE.INTPRO(I)) GO TO 6009
C         INTERRUPT PROCEDURE IS MARKED WITH HO 1
          PRSTK(PRSP) = J + 65536
          CALL EMIT(PUSH,RH,0)
          CALL EMIT(PUSH,RD,0)
          CALL EMIT(PUSH,RB,0)
          CALL EMIT(PUSH,RA,0)
          CALL STACK(4)
6009      CONTINUE
          GO TO 6025
C
6010  CALL SAVER
C
6020      CONTINUE
C         LABEL IS RESOLVED.  LAST TWO BITS OF ENTRY MUST BE 01
          K=CODLOC
6025      I = -SYMBOL(IP)
          J = MOD(I,4)
          I = I/4
          IF (J.EQ.1) GO TO 6200
              CALL ERROR(131,1)
6200  SYMBOL(IP) = -(SHL(K,16) + SHL(I,2) + 3)
C
C     NOW CHECK FOR PROCEDURE ENTRY POINT
C
      I = SYMBOL(IP-1)
      IF (RIGHT(I,4).NE.PROC) GO TO 100
      I = SHR(I,8)
C
C     BUILD RECEIVING SEQUENCE FOR REGISTER PARAMETERS
C
      IF (I.LT.1) GO TO 100
      K = I - 2
      IF (K.LT.0) K = 0
      IF (I.GT.2) I = 2
      DO 6300 J = 1, I
          SP = SP + 1
          IF (SP.LE.MAXSP) GO TO 6310
              CALL ERROR(113,5)
              SP = 1
C     (RD,RE) = 69    (RB,RC) = 35
6310      IF (J.EQ.1) L = 35
          IF (J.EQ.2) L = 69
          RASN(SP) = L
          ST(SP) = 0
          LITV(SP) = -1
          PREC(SP) = 2
          SP = SP + 1
          IF (SP.LE.MAXSP) GOTO 6320
              CALL ERROR(113,5)
              SP = 1
6320      RASN(SP) = 0
          LITV(SP) = -1
          CALL SETADR(VAL+K+J)
          CALL OPERAT(STD)
6300      CONTINUE
      GO TO 100
C     LITERAL VALUE
7000  CONTINUE
      IF (SP.LE.1) GO TO 7010
C     CHECK FOR ACTIVE CONDITION CODE WHICH MUST BE CHANGED TO BOOLEAN
      IF (RASN(SP-1).GT.255) CALL CVCOND(SP-1)
7010  ALTER = 1
      LITV(SP) = VAL
      PREC(SP) = 1
      IF (LITV(SP).GT.255) PREC(SP) = 2
      GO TO 100
C     LINE NUMBER
8000  CONTRL(14) = VAL
      SP = SP - 1
      GO TO 100
9000  CONTINUE
      CALL EMIT(EI,0,0)
      CALL EMIT(HALT,0,0)
C
C     MAY BE LINE/LOC'S LEFT IN OUTPUT BUFFER
      IF (CONTRL(18).NE.0) CALL WRITEL(0)
C
99999 CONTRL(20) = M
      RETURN
      END
      SUBROUTINE OPERAT(VAL)
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
      INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER CODLOC,ALTER,CBITS(22)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL
      COMMON /XFROPT/XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL
      INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /BIFCOD/BIFTAB,BIFPAR
      INTEGER BIFTAB(41),BIFPAR
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER INLOC,OUTLOC,FIRSTI,CASJMP
      COMMON /BIFLOC/INLOC,OUTLOC,FIRSTI,CASJMP
      INTEGER CHAIN
C     ADD ADC SUB SBC MUL DIV MOD NEG AND IOR
C     XOR NOT EQL LSS GTR NEQ LEQ GEQ INX TRA
C     TRC PRO RET STO STD XCH DEL CAT LOD BIF
C     INC CSE END ENB ENP HAL RTL RTR SFL SFR
C     HIV LOV CVA ORG AX1 AX2 AX3
      ICY = 0
      ICOM = 0
      IQ = 0
      GO TO (
     1   1000, 2000, 3000, 3500, 4000, 5000, 6000,99999, 9000,10000,
     2  11000,12000,13000,14000,15000,16000,17000,18000,19000,20000,
     3  21000,22000,23000,24000,24000,26000,27000,28000,29000,99999,
     4  31000,32000,99999,99999,99999,36000,37000,37000,37000,37000,
     5  37000,37000,43000,44000,45000,45100,45200,45500,46000,99999),
     6  VAL
C
C     ADD
1000  CONTINUE
C     MAY DO THE ADD IN H AND L (USING INX OPERATOR)
      IF (PREC(SP).NE.1) CALL EXCH
      IF (PREC(SP-1).NE.1) GO TO 1100
      CALL EXCH
      ICY = 1
      IOP = AD
      IOP2 = AC
      ICOM = 1
      GO TO 88888
1100  CONTINUE
C     SET PREC = 1 FOR INX
      JP = 1
      GO TO 19001
C
C     ADC
2000  CONTINUE
      ICY = 1
      IOP = AC
      IOP2 = AC
      ICOM = 1
      GO TO 88888
C
C     SUB
3000  CONTINUE
C     CHANGE ADDRESS VALUE - 1 TO ADDRESS VALUE + 65535 AND APPLY ADD
      IF (PREC(SP-1).EQ.1.OR.LITV(SP).NE.1) GO TO 3100
          LITV(SP) = 65535
          PREC(SP) = 2
          GO TO 1100
3100  CONTINUE
      ICY = 1
      IOP = SU
      IOP2 = SB
      GO TO 88888
C
C     SBC
3500  CONTINUE
      ICY = 1
      IOP = SB
      IOP2 = SB
      GO TO 88888
C
C     MUL
4000  I = 1
      J = 2
      GO TO 6100
C     DIV
5000  I = 2
      J = 1
      GO TO 6100
C     MOD
6000  I = 2
      J = 2
6100  CONTINUE
C     CLEAR CONDITION CODE
      IF (RASN(SP) .GT. 255) CALL CVCOND(SP)
C     CLEAR PENDING STORE
      IF (REGS(RA) .NE. 0) CALL EMIT (LD, REGS(RA), RA)
      REGS(RA) = 0
C     LOCK ANY CORRECTLY ASSIGNED REGISTERS
C     ....AND STORE THE REMAINING REGISTERS.
      IF (MOD(RASN(SP),16) .EQ. RE) LOCK(RE) = 1
      IF (RASN(SP)/16 .EQ. RD) LOCK(RD) = 1
      IF (MOD(RASN(SP-1),16) .EQ. RC) LOCK(RC) = 1
      IF (RASN(SP-1)/16 .EQ. RB) LOCK(RB) = 1
      CALL SAVER
C     MARK REGISTER C USED.
      IF (REGS(RC) .EQ. 0) REGS(RC) = -1
C     LOAD TOP OF STACK INTO REGISTERS D AND E.
      CALL LOADV(SP, 0)
      IF (PREC(SP) .EQ. 1) CALL EMIT (LD, RD, 0)
C     NOW DEASSIGN REGISTER C UNLESS CORRECTLY LOADED.
      IF (REGS(RC) .EQ. -1) REGS(RC) = 0
C     LOAD T.O.S. - 1 INTO REGISTERS B AND C.
      CALL LOADV(SP-1, 0)
      IF (PREC(SP-1) .EQ. 1) CALL EMIT(LD, RB, 0)
      CALL DELETE(2)
C
C     CALL THE BUILT-IN FUNCTION
      CALL EMITBF(I)
C     REQUIRES 2 LEVELS IN STACK FOR BIF (CALL AND TEMP.)
      CALL STACK(2)
      CALL USTACK
      CALL USTACK
C    AND THEN RETRIEVE RESULTS
          DO 6500 K=1,7
6500      LOCK(K) = 0
C     CANNOT PREDICT WHERE REGISTERS H AND L WILL END UP
      REGV(RL) = -1
      REGV(RH)=-1
      SP = SP + 1
      ST(SP) = 0
      PREC(SP) = 2
      LITV(SP) = -1
      IF (J.EQ.2) GO TO 6600
      RASN(SP) = RB*16 + RC
      REGS(RB)=SP
      REGS(RC)=SP
      GO TO 99991
6600  RASN(SP) = RD*16 + RE
      REGS(RD)=SP
      REGS(RE)=SP
      GO TO 99991
C
C     AND
9000  CONTINUE
      IOP = ND
9100  ICOM = 1
      GO TO 88887
C
C     IOR
10000 CONTINUE
      IOP = OR
      GO TO 9100
C
C     XOR
11000 CONTINUE
      IOP = XR
      GO TO 9100
C
C     NEGATE (COMPLEMENT THE ENTIRE NUMBER)
12000 CONTINUE
      I = RASN(SP)
      IF (I.LE.255) GO TO 12100
C
C     CONDITION CODE - CHANGE PARITY
          J = 1 - (I/4096)
          RASN(SP) = J*4096 + MOD(I,4096)
      GO TO 99991
C
12100  CONTINUE
C     PERFORM XOR WITH 255 OR 65535 (BYTE OR ADDRESS)
      I = PREC(SP)
      J = 256**I
      SP = SP + 1
      LITV(SP) = J - 1
      PREC(SP) = I
      GO TO 11000
C
13000 CONTINUE
C     EQUAL TEST
      IF ((PREC(SP)+PREC(SP-1)).GT.2) GO TO 13200
C
C     MARK AS TRUE/ZERO (1*16+2)
      J = 18
13050 ICOM = 1
13080 IOP = SU
13090 IOP2 = 0
13100 CALL APPLY(IOP,IOP2,ICOM,ICY)
C         MARK AS CONDITION CODE
          RASN(SP) = J*256 + RASN(SP)
          GO TO 99991
C
C     DOUBLE BYTE EQUAL
13200 CONTINUE
      IQ = 1
C     MARK AS TRUE/ZERO (1*16 + 2)
      J = 18
13300 ICOM = 1
13400 IOP = SU
      IOP2 = SB
      ICY = 1
      CALL APPLY(IOP,IOP2,ICOM,ICY)
C     CHANGE TO CONDITION CODE
          I = RASN(SP)
          IP = MOD(I,16)
          IF (IQ.EQ.1) CALL EMIT(OR,IP,0)
C
C     GET RID OF HIGH ORDER REGISTER IN THE RESULT
          REGS(1) = IP
          RASN(SP) = J*256 + IP
          PREC(SP) = 1
          LITV(SP) = -1
          ST(SP) = 0
          J = MOD(I/16,16)
          IF (J.EQ.0) GO TO 99991
              LOCK(J) = 0
              REGS(J) = 0
              REGV(J) = - 1
          GO TO 99991
C
14000 CONTINUE
C     LSS - SET TO TRUE/CARRY (1*16+1)
      J = 17
      IF ((PREC(SP)+PREC(SP-1)).GT.2) GO TO 13400
14010 IF (LITV(SP).NE.1) GO TO 13080
      IOP = CP
      GO TO 13090
C
15000 CONTINUE
C     GTR - CHANGE TO LSS
      CALL EXCH
      GO TO 14000
C
16000 CONTINUE
C     NEQ
C     MARK AS FALSE/ZERO (0*16+2)
      J = 2
      IQ = 1
      IF ((PREC(SP)+PREC(SP-1)).GT.2) GO TO 13300
      GO TO 13050
C
17000 CONTINUE
C     LEQ - CHANGE TO GEQ
      CALL EXCH
C
18000 CONTINUE
C     GEQ - SET TO FALSE/CARRY (0*16+1)
      J = 1
      IF ((PREC(SP)+PREC(SP-1)).GT.2) GO TO 13400
      GO TO 14010
C
C     INX
19000 CONTINUE
      JP = PREC(SP-1)
C     INX IS ALSO USED FOR ADDING ADDRESS VALUES, ENTERING FROM ADD
19001 CONTINUE
C     BASE MAY BE INDEXED BY ZERO...
      IF (LITV(SP).NE.0) GO TO 19002
C         JUST DELETE THE INDEX AND IGNORE THE INX OPERATOR
          CALL DELETE(1)
          GO TO 99991
19002 CONTINUE
      IF (RASN(SP).GT.255) CALL CVCOND(SP)
      J = REGS(1)
      IH = RASN(SP)
      IL = MOD(IH,16)
      IH = IH/16
      JH = RASN(SP-1)
      JL = MOD(JH,16)
      JH = JH/16
C     CHECK FOR PENDING STORE TO BASE OR INDEX
      IF ((J.EQ.0).OR.((J.NE.JH).AND.(J.NE.JL)
     1    .AND.(J.NE.IH).AND.(J.NE.IL))) GO TO 19010
          CALL EMIT(LD,J,RA)
          REGS(1) = 0
19010 CONTINUE
C     MAKE SURE THAT D AND E ARE AVAILABLE
      IF ((REGS(RE).EQ.0).AND.(REGS(RD).EQ.0)) GO TO 19020
      IF ((IL.EQ.RE).OR.(JL.EQ.RE)) GO TO 19020
C     MARK ALL REGISTERS FREE
      IF (IL.NE.0) REGS(IL) = 0
      IF (JL.NE.0) REGS(JL) = 0
      CALL GENREG(2,IA,IB)
      REGS(IA) = 1
      CALL GENREG(2,IC,IB)
      REGS(IA) = 0
C     ALL REGS ARE CLEARED EXCEPT BASE AND INDEX, IF ALLOCATED.
      IF (IL.NE.0) REGS(IL) = SP
      IF (JL.NE.0) REGS(JL) = SP-1
C     GET INDEX FROM MEMORY, IF NECESSARY
19020 CONTINUE
C     IF LITERAL 1 OR -1, USE INX OR DCX
      IF (LITV(SP).EQ.1.OR.LITV(SP).EQ.65535) GO TO 19040
C     IF THE INDEX IS CONSTANT, AND THE BASE AN ADDRESS VARIABLE,
C     DOUBLE THE LITERAL VALUE AT COMPILE TIME
      IF (LITV(SP).LT.0.OR.JP.EQ.1) GO TO 19030
          LITV(SP) = LITV(SP) + LITV(SP)
          JP = 1
19030 CONTINUE
      I = 0
      IF (LITV(SP).GE.0) I = 3
      CALL LOADV(SP,I)
19040 CONTINUE
C     IF THE INDEX WAS ALREADY IN THE REGISTERS, MAY
C     HAVE TO EXTEND PRECISION TO ADDRESS.
      IH = RASN(SP)
      IL = MOD(IH,16)
      IH = IH/16
      IF (IL.EQ.0.OR.IH.NE.0) GO TO 19050
          IH = IL-1
          CALL EMIT (LD,IH,0)
19050 CONTINUE
      I = DAD
      IF (LITV(SP).EQ.1) I = INCX
      IF (LITV(SP).EQ.65535) I = DCX
      IF (IH.EQ.0) IH = RH
C     DELETE THE INDEX.  (NOTE THAT SP WILL THEN POINT TO THE BASE)
      CALL DELETE(1)
C     LOAD THE BASE INTO THE H AND L REGISTERS
      CALL LOADV(SP,5)
C     ADD THE BASE AND INDEX
      CALL EMIT(I,IH,0)
C     AND ADD INDEX AGAIN IF BASE IS AN ADDRESS VARIABLE.
      IF (JP.NE.1) CALL EMIT(I,IH,0)
      CALL EMIT(XCHG,0,0)
C     NOTE XCHG HERE AND REMOVE WITH PEEPHOLE OPTIMIZATION LATER
C
      I = PREC(SP)
      CALL DELETE(1)
      SP = SP + 1
      ST(SP) = 0
      PREC(SP) = I
      LITV(SP) = -1
      REGV(RH) = -1
      REGV(RL) = -1
      RASN(SP) = RD*16 + RE
      REGS(RD) = SP
      REGS(RE) = SP
      GO TO 99991
C
C     TRA -   CHECK STACK FOR SIMPLE LABEL VARIABLE
20000 IOP = 1
C     IN CASE THERE ARE ANY PENDING VALUES ...
      LOCK(6) = 1
      LOCK(7) = 1
      CALL SAVER
      LOCK(6) = 0
      LOCK(7) = 0
C     THIS MAY BE A JUMP TO AN ABSOLUTE ADDRESS
      M = LITV(SP)
      IF (M .LT. 0) GO TO 20050
C     ABSOLUTE JUMP - PROBABLY TO ASSEMBLY LANGUAGE SUBRTNE...
C     ...SO MAKE H AND L REGISTERS UNKNOWN
          REGV(RH) = -1
          REGV(RL) = -1
          CALL EMIT (JMP, M, 0)
          CALL DELETE (1)
          GO TO 99991
20050     I = ST(SP)
          IF (I.GT.0) GO TO 20100
          IF ((IOP.EQ.1).AND.(I.EQ.0)) GO TO 20700
C         COULD BE A COMPUTED ADDRESS
              CALL ERROR(134,1)
              GO TO 99990
20100     I = SYMBOL(I)
          J = SYMBOL(I-1)
          J = RIGHT(J,4)
C         MAY BE A SIMPLE VARIABLE
          IF ((IOP.EQ.1).AND.(J.EQ.VARB)) GO TO 20700
          IF (((IOP.EQ.3).AND.(J.EQ.PROC)).OR.(J.EQ.LABEL)) GO TO 20200
              CALL ERROR(135,1)
              GO TO 99990
20200     J = - SYMBOL(I)
          M = SHR(J,16)
          IF (IOP.NE.1) GO TO 20206
          IT = IABS(SYMBOL(I-1))
          IT = RIGHT(SHR(IT,4),4)
C          IT IS TYPE OF LABEL...
C          3 IS USER-DEFINED OUTER BLOCK, 4 IS USER DEFINED
C          NOT OUTER BLOCK, 5 IS COMPILER DEFINED
          IF (IT.NE.5) GO TO 20206
C
C         THIS TRA IS ONE OF A CHAIN OF COMPILER GENERATED
C         TRA'S - STRAIGHTEN THE CHAIN IF NO CODE HAS BEEN
C         GENERATED SINCE THE PREVIOUS DEF.
C
          IF (DEFSYM.LE.0) GO TO 20206
          K = SYMBOL(DEFSYM)
          IF(RIGHT(SHR(SYMBOL(K-1),4),4).NE.5) GO TO 20206
          L = -SYMBOL(K)
          JP = SHR(L,16)
          IF (JP.NE.CODLOC) GO TO 20205
C
C         ADJUST THE REFERENCE COUNTS AND OPTIMIZATION
C         INFORMATION FOR BOTH DEF'S.
C
          IA = SHR(IABS(SYMBOL(K-1)),8)
          IB = 0
          IF (IA.EQ.1) IB = SYMBOL(K-2)
          IF (DEFRH.EQ.-255) IA = IA - 1
          SYMBOL(K-1) = 84
C         I.E., ZERO REFERENCES TO COMPILER GENERATED LABEL
          IF (SHR(IABS(SYMBOL(I-1)),8).EQ.1) SYMBOL(I-2) = IB
          SYMBOL(I-1) = SYMBOL(I-1) + IA * 256
C         CORRECTED REFERENCE COUNT FOR OBJECT OF THE DEF
C
C         MERGE THE BACKSTUFFING CHAINS
C
20201     IA = RIGHT(SHR(L,2),14)
          IF (IA.EQ.0) GO TO 20203
              IB = GET(IA) + GET(IA+1) * 256
              L = SHL(JP,16) + SHL(IB,2) + RIGHT(L,2)
              SYMBOL(K) = -L
              IP = RIGHT(SHR(J,2),14)
                  CALL PUT(IA,MOD(IP,256))
                  CALL PUT(IA+1,IP/256)
              J = SHL(M,16) + SHL(IA,2) + RIGHT(J,2)
              SYMBOL(I) = -J
              GO TO 20201
20203     CONTINUE
C
C         EQUATE THE DEFS
C
          DO 20202 IA = 1,SYTOP
          IF (SYMBOL(IA) .EQ. K) SYMBOL(IA) = I
20202     CONTINUE
C
C         OMIT THE TRA IF NO PATH TO IT
C
20204     REGV(RH) = DEFRH
          REGV(RL) = DEFRL
20205     IF (REGV(RH).NE.-255) GO TO 20206
              CALL DELETE(1)
              GO TO 99991
20206     CONTINUE
          IF (IT.NE.3.OR.IOP.NE.1) GO TO 20208
C         WE HAVE A TRA TO THE OUTER BLOCK...
          J = CONTRL(47)
          IF ((PRSP.EQ.0).OR.(J.EQ.1)) GO TO 20208
          IF (J.NE.0) GO TO 20207
              J = LXIS
              LXIS = CODLOC + 1
20207     CALL EMIT(LXI,RSP,MOD(J,65536))
C
20208      J = -SYMBOL(I)
          M = RIGHT(SHR(J,2),14)
C             CONNECT ENTRY INTO CHAIN
              K = CODLOC + 1
              IF (IOP.EQ.4) K = CODLOC
C             IOP = 4 IF WE ARRIVED HERE FROM CASE TABLE JMP
              SYMBOL(I) = -(SHL(SHR(J,16),16) + SHL(K,2) + RIGHT(J,2))
C
C     CHECK FOR SINGLE REFERENCE
      J = SYMBOL(I-1)
      K = IABS(J)/256
      IF (K.NE.1) GO TO 20300
C     MAKE SURE THIS IS THE FIRST FWD REFERENCE
      L = SYMBOL(I-2)
      IF (L .NE. 0) GO TO 20220
C     SAVE H AND L, MARK AS A FORWARD REFERENCE
C     /  1B   /  1B   /  9B   /  8B   /
C     /H VALID/L VALID/H VALUE/L VALUE/
      K = 0
      L = REGV(7)
      IF ((L.LT.0).OR.(L.GT.255)) GO TO 20210
      K = L + 131072
20210 L = REGV(6)
      IF ((L.LT.0).OR.(L.GT.511)) GO TO 20220
      K = (L + 1024) * 256 + K
20220 SYMBOL(I-2) = K
C
C         TRA, TRC, PRO, AX2 (CASE TRA)
20300     GO TO (20400,20500,20600,20650),IOP
C
20400         CONTINUE
C             MAY BE INC TRA COMBINATION IN DO-LOOP
              IF ((LASTIN+1).NE.CODLOC) GO TO 20410
C                 CHANGE TO JFZ TO TOP OF LOOP
                  CALL EMIT(JMC,FAL*32+ZERO,M)
                  CALL DELETE(1)
                  GO TO 99991
20410         XFRLOC = CODLOC
              XFRSYM = ST(SP)
              TSTLOC = CODLOC+3
              CALL EMIT(JMP,M,0)
              CALL DELETE(1)
C             MARK H AND L NIL (= - 255)
20550         REGV(6) = -255
              REGV(7) = -255
              GO TO 99991
C
20500         CONLOC = CODLOC
              CALL EMIT(JMC,IOP2,M)
              CALL DELETE(2)
              GO TO 99991
C
20600         XFRLOC = CODLOC
              XFRSYM = ST(SP)
              TSTLOC = CODLOC+3
              CALL EMIT(CAL,M,0)
C              ADJUST THE MAXDEPTH, IF NECESSARY
              J = SYMBOL(I-3) + 1
C             J IS NUMBER OF DOUBLE-BYTE STACK ELEMENTS REQD
              CALL STACK(J)
C             NOW RETURNED FROM CALL SO...
              CURDEP(PRSP+1) = CURDEP(PRSP+1) - J
C
C             NOW FIX THE H AND L VALUES UPON RETURN
              J = SYMBOL(I-2)
              K = SHR(J,19)
C             MAY BE UNCHANGED FROM CALL
              IF (K.EQ.3) GO TO 20610
C                 COMPARE VALUES
                  J = RIGHT(J,19)
                  L = MOD(J,256)
                  J = J / 256
                  K = MOD(J,512)
                  J = J/512
                  IF (MOD(J,2).NE.1) L = -1
                  IF (MOD(J/2,2).NE.1) K = -1
                  REGV(6) = K
                  REGV(7) = L
20610     CONTINUE
              CALL DELETE(1)
C             MAY HAVE TO CONSTRUCT A RETURNED
C             VALUE AT THE STACK TOP
              J = SYMBOL(I-1)
              J = MOD(J/16,16)
              IF (J.LE.0) GO TO 99991
C             SET STACK TOP TO PRECISION OF PROCEDURE
                  SP = SP + 1
                  PREC(SP) = J
                  ST(SP) = 0
                  I = RC
                  IF (J.GT.1) I = RB*16+I
                  RASN(SP) = I
                  REGS(RA) = RC
                  REGS(RC) = SP
                  IF (J.GT.1) REGS(RB) = SP
                  LITV(SP) = -1
               GO TO 99991
C         CAME FROM A CASE VECTOR
20650     CALL EMIT(0,MOD(M,256),0)
          CALL EMIT(0,M/256,0)
          CALL DELETE(1)
          GO TO 99991
C
C     JUMP TO COMPUTED LOCATION
20700 CALL LOADV(SP,4)
      CALL DELETE(1)
      CALL EMIT(PCHL,0,0)
C     PC HAS BEEN MOVED, SO MARK H AND L UNKNOWN
      REGV(RH) = -255
      REGV(RL) = -255
      GO TO 99991
C     TRC
21000 CONTINUE
      J = SP - 1
      I = LITV(J)
      IF(RIGHT(I,1).NE.1) GO TO 21100
C     THIS IS A DO FOREVER (OR SOMETHING SIMILAR) SO IGNORE THE JUMP
          CALL DELETE(2)
          GO TO 99991
C
C     NOT A LITERAL '1'
21100 IOP  = 2
C     CHECK FOR CONDITION CODE
      I = RASN(J)
      IF (I.LE.255) GO TO 21200
C     ACTIVE CONDITION CODE, CONSTRUCT MASK FOR JMC
          I = I / 256
          J = I / 16
          I = MOD(I,16)
          IOP2 = (FAL + 1 - J)*32 + (CARRY + I - 1)
      GO TO 20050
C
C     OTHERWISE NOT A CONDITION CODE, CONVERT TO CARRY
21200 CONTINUE
      IF (I.NE.0) GO TO 21300
C     LOAD VALUE TO ACCUMULATOR
          PREC(J) = 1
          CALL LOADV(J,1)
          GO TO 21400
C
C     VALUE ALREADY LOADED
21300 I = MOD(I,16)
      J = REGS(1)
      IF (J.EQ.I) GO TO 21400
      IF (J.NE.0) CALL EMIT(LD,J,RA)
      CALL EMIT(LD,RA,I)
C
21400 REGS(1) = 0
      CALL EMIT(ROT,CY,RGT)
      IOP2 = FAL*32 + CARRY
      GO TO 20050
C
C     PRO
C
C     ROL     ROR     SHL     SHR
C     SCL     SCR
C     TIME    HIGH    LOW     INPUT
C     OUTPUT  LENGTH  LAST    MOVE
C     DOUBLE  DEC
C
22000 CONTINUE
      I = ST(SP)
      IF (I.GT.INTBAS) GO TO 22500
C     THIS IS A BUILT-IN FUNCTION.
      CALL DELETE(1)
      IF (I.LT.FIRSTI) GO TO 22499
      I = I - FIRSTI + 1
C
      GO TO ( 22300, 22300, 22300, 22300,
     *        22300,22300,
     1        22200, 22300, 22300, 22050,
     2        22100, 22310, 22310, 22499,
     3         22320,22350),I
C      INPUT(X)
22050  CONTINUE
C         INPUT FUNCTION. GET INPUT PORT NUMBER
          I = LITV(SP)
          IF ((I.LT.0).OR.(I.GT.255)) GO TO 22499
          CALL DELETE(1)
          SP = SP + 1
          CALL GENREG(1,J,K)
          IF (J.EQ.0) GO TO 22499
          K = REGS(1)
          IF (K.NE.0) CALL EMIT(LD,K,RA)
          REGS(1) = J
          RASN(SP) = J
          LITV(SP) = -1
          ST(SP) = 0
          PREC(SP) = 1
          REGS(J) = SP
          CALL EMIT(INP,I,0)
          GO TO 99991
C
C     OUTPUT(X)
22100 CONTINUE
C         CHECK FOR PROPER OUTPUT PORT NUMBER
          I = LITV(SP)
          IF ((I.LT.0).OR.(I.GT.255)) GO TO 22499
          CALL DELETE(1)
          SP = SP + 1
C         NOW BUILD AN ENTRY WHICH CAN BE RECOGNIZED BY
C         OPERAT.
          LITV(SP) = I
          RASN(SP) = 0
          PREC(SP) = 1
          ST(SP) =  OUTLOC
          GO TO 99991
C     TIME(X)
22200 CONTINUE
      IF (RASN(SP).GT.255) CALL CVCOND(SP)
C
C    EMIT THE FOLLOWING CODE SEQUENCE FOR 100 USEC PER LOOP
C       8080 CPU ONLY
C     (GET TIME PARAMETER INTO THE ACCUMULATOR)
C              MVI   B,12   (7 CY OVERHEAD)
C     START    MOV   C,B    (5 CY * .5 USEC = 2.5 USEC)
C     --------------------
C     TIM180   DCR   C      (5 CY * .5 USEC = 2.5 USEC)
C              JNZ   TIM180 (10 CY* .5 USEC = 5.0 USEC)
C     --------------------
C                  12 *     (15 CY* .5 USEC = 7.5 USEC)
C                   =       (180 CY* .5 USEC = 90 USEC)
C              DCR   A      (5 CY * .5 USEC = 2.5 USEC)
C              JNZ   START  (10 CY* .5 USEC = 5.0 USEC)
C
C              TOTAL TIME   (200 CY*.5 USEC = 100 USEC/LOOP)
C
      J = REGS(RA)
      I = RASN(SP)
      IP = I/16
      I = MOD(I,16)
      IF ((J.NE.0).AND.(J.EQ.I)) GO TO 22210
C         GET TIME PARAMETER INTO THE ACCUMULATOR
          IF ((J.NE.0).AND.(J.NE.IP)) CALL EMIT(LD,J,RA)
          REGS(RA) = 0
          IF (I.EQ.0) CALL LOADV(SP,1)
          I = MOD(RASN(SP),16)
          IF (J.NE.0) CALL EMIT(LD,RA,I)
22210 REGS(RA) = 0
      CALL EMIT(LD,I-1,-12)
      CALL EMIT(LD,I,I-1)
      CALL EMIT(DC,I,0)
      CALL EMIT(JMC,FAL*32+ZERO,CODLOC-1)
      CALL EMIT(DC,RA,0)
      CALL EMIT(JMC,FAL*32+ZERO,CODLOC-6)
C
      CALL DELETE(1)
      GO TO 99991
C     STOP HERE BEFORE GOING TO THE UNARY OPERATORS
C     ** NOTE THAT THIS DEPENDS UPON FIXED RTL = 37 **
22300 CONTINUE
      VAL = 36 + I
      IF (VAL.LE.42) GO TO 22307
C     ** NOTE THAT THIS ALSO ASSUMES ONLY 6 SUCH BIFS
22305 CALL UNARY(VAL)
      GO TO 99991
C
C     MAY HAVE TO ITERATE
22307 CONTINUE
      I = LITV(SP)
      IF (I.LE.0) GO TO 22308
C     GENERATE IN-LINE CODE FOR SHIFT COUNTS OF
C         1 OR 2 FOR ADDRESS VALUES
C         1 TO 3 FOR SHR OF BYTE VALUES
C         1 TO 6 FOR ALL OTHER SHIFT FUNCTIONS ON BYTE VALUES
      J = 6
      IF (VAL.EQ.40) J = 3
      IF (PREC(SP-1).NE.1) J = 2
      IF (I.GT.J) GO TO 22308
      CALL DELETE(1)
      DO 22306 J = 1, I
          CALL UNARY(VAL)
22306 CONTINUE
      GO TO 99991
C     BUILD A SMALL LOOP AND COUNT DOWN TO ZERO
22308 CONTINUE
      CALL EXCH
C     LOAD THE VALUE TO DECREMENT
      CALL LOADV(SP-1,0)
      J = RASN(SP-1)
      J = MOD(J,16)
      IF (REGS(RA).NE.J) GO TO 22311
          CALL EMIT(LD,J,RA)
          REGS(RA) = 0
22311 CONTINUE
      LOCK(J) = 1
C     LOAD THE VALUE WHICH IS TO BE OPERATED UPON
          KP = PREC(SP)
          I  = 1
          IF (KP.GT.1) I = 0
          IF (RASN(SP).NE.0) GO TO 22312
              CALL LOADV(SP,I)
          IF (I.EQ.1) REGS(1) = MOD(RASN(SP),16)
22312     K = RASN(SP)
          M = MOD(K,16)
          K = K/16
          JP = REGS(RA)
          IF (I.EQ.1.AND.JP.EQ.M) GO TO 22314
          IF (JP.EQ.0) GO TO 22313
               CALL EMIT(LD,JP,RA)
                 REGS(RA) = 0
22313     IF (I.EQ.0) GO TO 22314
              CALL EMIT(LD,RA,M)
              REGS(RA) = M
22314     CONTINUE
          I = CODLOC
          CALL UNARY(VAL)
          IF (KP.EQ.1) GO TO 22309
          K = REGS(1)
          IF (K.NE.0) CALL EMIT(LD,K,RA)
          REGS(1) = 0
22309  CALL EMIT(DC,J,0)
      CALL EMIT(JMC,FAL*32+ZERO,I)
C     END UP HERE AFTER OPERATION COMPLETED
      CALL EXCH
      LOCK(J) = 0
      CALL DELETE(1)
      GO TO 99991
C
C     LENGTH AND LAST
C     ** NOTE THAT THIS ASSUMES THAT LENGTH AND LAST ARE
C     BUILT-IN FUNCTIONS 10 AND 11 **
22310 CONTINUE
      J = ST(SP)
      IF (J.LE.0) GO TO 22499
      J = SYMBOL(J)-1
      J = IABS(SYMBOL(J))/256+12-I
      CALL DELETE(1)
      SP = SP + 1
      ST(SP) = 0
      I = 1
      IF (J.GT.255) I=2
      PREC(SP) = I
      RASN(SP) = 0
      LITV(SP) = J
      IF (J.LT.0) GO TO 22499
      GO TO 99991
C
C     DOUBLE
22320 CONTINUE
      IF(PREC(SP).GT.1) GO TO 99999
      IF(RASN(SP).NE.0) GO TO 22330
      IF(LITV(SP).LT.0) GO TO 22332
          PREC(SP) = 2
          ST(SP) = 0
          GO TO 99991
C         LOAD VALUE TO ACCUMULATOR AND GET A REGISTER
22332     CALL LOADV(SP,1)
          REGS(1) = MOD(RASN(SP),16)
C
22330 IA = RASN(SP)
      PREC(SP) = 2
      ST(SP) = 0
      IF (IA.GT.15) GO TO 99991
      LOCK(IA) = 1
      IB = IA - 1
      REGS(IB) = SP
      LOCK(IA) = 0
      RASN(SP) = IB*16 + IA
C     ZERO THE REGISTER
      CALL EMIT(LD,IB,0)
      IF (IB.NE.0) GO TO 99991
      CALL ERROR(133,5)
      GO TO 99991
C
C
C     DEC
22350 CONTINUE
      J = MOD(RASN(SP),16)
      IF (J.EQ.0) GO TO 22499
      IF (PREC(SP).NE.1) GO TO 22499
      I = REGS(RA)
      IF (I.EQ.J) GO TO 22370
C     MAY BE A PENDING REGISTER STORE
      IF (I.NE.0) CALL EMIT(LD,I,RA)
      CALL EMIT(LD,RA,J)
      REGS(RA) = J
22370 CALL EMIT(DAA,0,0)
      GO TO 99991
C
C     BUILT IN FUNCTION ERROR
22499 CALL ERROR(136,1)
      GO TO 99999
C
C     PASS THE LAST TWO (AT MOST) PARAMETERS IN THE REGISTERS
C
22500 I = RIGHT(ST(SP),16)
      I = SYMBOL(I)
      I = SHR(SYMBOL(I-1),8)
      I = IMIN(I,2)
      IF (I.LT.1) GO TO 22630
      J = SP - I - I
      DO 22520 K = 1, I
          IP = RASN(J)
          JP = MOD(IP/16,16)
          IP = MOD(IP,16)
          IF (IP.NE.0) LOCK(IP) = 1
          IF (JP.NE.0) LOCK(JP) = 1
          PREC(J) = IMIN(PREC(J),PREC(J+1))
      IF (PREC(J).GT.1.OR.JP.EQ.0) GO TO 22510
              REGS(JP) = 0
              LOCK(JP) = 0
              JP = 0
          IF (REGS(1).EQ.IP) LOCK(1) = 1
          IF (REGS(1).EQ.JP) LOCK(1) = 1
22510     RASN(J) = JP*16+IP
          J = J + 2
22520     CONTINUE
      J = SP - 1 - I - I
      IT = 0
C     STACK ANY STUFF WHICH DOES NOT GO TO THE PROCEDURE
          DO 22530 K=1,SP
C         CHECK FOR VALUE TO PUSH
          JP = RASN(K)
          IF (JP.EQ.0) GO TO 22524
C         POSSIBLE PUSH IF NOT A PARAMETER
          IF (K.GT.J) GO TO 22530
C             REGISTERS MUST BE PUSHED
             JPH = JP/16
             KP = REGS(RA)
              JP = MOD(JP,16)
             IF (KP.EQ.0) GO TO 22522
C            PENDING ACC STORE, CHECK HO AND LO REGISTERS
             IF (KP.NE.JPH) GO TO 22521
C            PENDING HO BYTE STORE
                 CALL EMIT(LD,JPH,RA)
                 REGS(RA) = 0
                 GO TO 22522
C            CHECK LO BYTE
22521        IF (KP.NE.JP) GO TO 22522
                  CALL EMIT (LD,JP,RA)
                  REGS(RA) = 0
22522     CALL EMIT(PUSH,JP-1,0)
          CALL STACK(1)
          ST(K) = 0
          IT = RASN(K)
          JP = MOD(IT,16)
          IF (JP.NE.0) REGS(JP) = 0
          JP = IT/16
          IF (JP.NE.0) REGS(JP) = 0
          RASN(K) = 0
          LITV(K) = -1
          IT = K
          GO TO 22530
C     REGISTERS NOT ASSIGNED - CHECK FOR STACKED VALUE
22524     IF ((ST(K).NE.0).OR.(LITV(K).GE.0)) GO TO 22530
          IF (IT.EQ.0) GO TO 22530
              CALL ERROR(150,1)
22530     CONTINUE
22550 IT = RH
      J = SP - I - I
      DO 22590 K = 1, I
          ID = K + K + 2
          IP = RASN(J)
          JP = MOD(IP/16,16)
          IP = MOD(IP,16)
22560     ID = ID - 1
          IF (IP.EQ.0) GO TO 22590
          IF (IP.EQ.ID) GO TO 22580
          IF (REGS(ID).EQ.0) GO TO 22570
              M = REGS(ID)
              ML = RASN(M)
              MH = MOD(ML/16,16)
              ML = MOD(ML,16)
              IF (ML.EQ.ID) ML = IT
              IF (MH.EQ.ID) MH = IT
              CALL EMIT(LD,IT,ID)
              REGS(IT) = M
              RASN(M) = MH*16+ML
              IT = IT + 1
22570     REGS(IP) = 0
          LOCK(IP) = 0
          IF (REGS(1).NE.IP) GO TO 22575
          IP = 1
          REGS(1) = 0
          LOCK(1) = 0
22575     CALL EMIT(LD,ID,IP)
          REGS(ID) = J
22580     LOCK(ID) = 1
          IP = JP
          IF (IP.EQ.-1) GO TO 22590
          JP = -1
          GO TO 22560
22590     J = J + 2
      J = SP - I - I
      DO 22600 K = 1, I
          IF (RASN(J).EQ.0) CALL LOADV(J,0)
          IP = K + K
          REGS(IP) = J
          LOCK(IP) = 1
          IF (PREC(J+1).EQ.2.AND.PREC(J).EQ.1) CALL EMIT(LD,IP,0)
          J = J + 2
22600     CONTINUE
      IF (REGS(1).NE.0) CALL EMIT(LD,REGS(1),RA)
      DO 22610 K = 1, 7
          REGS(K) = 0
          REGV(K) = -1
          LOCK(K) = 0
22610     CONTINUE
      J = I + I
      DO 22620 K = 1, J
          CALL EXCH
          IF ((ST(SP).NE.0).OR.(RASN(SP).NE.0).OR.
     1    (LITV(SP).GE.0)) GO TO 22615
      CALL EMIT(POP,RH,0)
      CALL USTACK
      REGV(RH) = -1
      REGV(RL) = -1
22615 CALL DELETE(1)
22620     CONTINUE
      IOP = 3
      GO TO 20050
22630 CONTINUE
      LOCK(6) = 1
      LOCK(7) = 1
      CALL SAVER
      LOCK(6) = 0
      LOCK(7) = 0
      IOP = 3
      GO TO 20050
C
C     RET
23000 CONTINUE
      JP = PRSP
      IF (JP.GT.0) GO TO 23050
          CALL ERROR(146,1)
          GO TO 20550
23050 CONTINUE
C     CHECK FOR TYPE AND PRECISION OF PROCEDURE
      L = MOD(PRSTK(JP),65536) + 1
      L = SYMBOL(L)/16
      L = MOD(L,16)
C     L IS THE PRECISION OF THE PROCEDURE
      IF (L.EQ.0) GO TO 23310
      I = RASN(SP)
      IF (I.EQ.0) CALL LOADV(SP,1)
      IF (I.GE.256) CALL CVCOND(SP)
      K = RASN(SP)
      JP = REGS(1)
      J = MOD(K,16)
      K = K/16
      IF ((I.EQ.0).OR.(J.EQ.JP)) GO TO 23200
C         HAVE TO LOAD THE ACCUMULATOR.  MAY HAVE H.O. BYTE.
          IF ((JP.EQ.0).OR.(JP.NE.K)) GO TO 23150
          CALL EMIT(LD,K,RA)
23150     CALL EMIT(LD,RA,J)
C
23200 IF (K.EQ.0) GO TO 23300
      IF (K.NE.RB) CALL EMIT(LD,RB,K)
23300 CONTINUE
C     COMPARE PRECISION OF PROCEDURE WITH STACK
      IF (L.GT.PREC(SP)) CALL EMIT(LD,RB,0)
23310 CALL DELETE(1)
      IF (PRSTK(PRSP).LE.65535) GO TO 23320
C         INTERRUPT PROCEDURE - USE THE DRT CODE BELOW
          JP = PRSP
          K = 0
          GO TO 45020
23320 CALL EMIT(RTN,0,0)
C     MERGE VALUES OF H AND L FOR THIS PROCEDURE
C         CAN ALSO ENTER WITH JP SET FROM END OF PROCEDURE
          JP = PRSP
23350     XFRLOC = CODLOC-1
          XFRSYM = 0
          TSTLOC = CODLOC
          I = MOD(PRSTK(JP),65536)
          JP = SYMBOL(I)
          K = REGV(6)
          L = REGV(7)
          J = RIGHT(JP,19)
          JP = SHR(JP,19)
          IF (JP.NE.3) GO TO 23360
          IF ((K.EQ.-254).AND.(L.EQ.-254)) GO TO 99991
C     H AND L HAVE BEEN ALTERED IN THE PROCEDURE
          KP = K
          LP = L
          GO TO 23370
C     OTHERWISE MERGE VALUES OF H AND L
C
23360     LP = MOD(J,256)
          J = J / 256
          KP = MOD(J,512)
          J = J/512
          IF (MOD(J,2).EQ.0) LP = -1
          IF (MOD(J/2,2).EQ.0) KP = -1
C     COMPARE K WITH KP AND L WITH LP
23370     J = 0
          IF ((L.GE.0).AND.(LP.EQ.L)) J = 131072+L
          IF ((K.GE.0).AND.(KP.EQ.K)) J = (K+1024) * 256 + J
          SYMBOL(I) = J
C     MARK H AND L NIL BEFORE RETURNING FROM SUBR
      GO TO 20550
C
C     STO AND STD
24000 I = ST(SP)
C     CHECK FOR OUTPUT FUNCTION
      IF (I.EQ.OUTLOC) GO TO 24050
C     CHECK FOR COMPUTED ADDRESS OR SAVED ADDRESS
      IF (I.GE.0) GO TO 24100
C     CHECK FOR ADDRESS REFERENCE OUTSIDE INTRINSIC RANGE
      I = -I
      IF (I.GT.INTBAS) GO TO 24100
C     CHECK FOR 'MEMORY' ADDRESS REFERENCE
C    ** NOTE THAT STACKTOP MUST BE AT 6 **
      IF (I.LE.6) GO TO 24100
      IF (I.EQ.5) GO TO 24100
C     IGNORE THE STORE FOR INTRINSIC PARAMETERS
      GO TO 24200
C     OUTPUT FUNCTION
24050 CONTINUE
          J = LITV(SP)
          I = RASN(SP-1)
          IF ((I.GT.0) .AND. (I.LT.256)) GO TO 24060
C         LOAD VALUE TO ACC
          I = REGS(RA)
          IF (I.GT.0) CALL EMIT(LD,I,RA)
          CALL LOADV(SP-1,1)
          I = RASN(SP-1)
          GO TO 24070
C     OPERAND IS IN THE GPRS
24060     I = MOD(I,16)
          K = REGS(RA)
          IF ((K.GT.0).AND.(K.NE.I))CALL EMIT(LD,K,RA)
          IF (K.NE.I) CALL EMIT(LD,RA,I)
C     NOW MARK ACC ACTIVE IN CASE SUBSEQUENT STO OPERATOR
24070     REGS(RA) = MOD(I,16)
          CALL EMIT(OUT,J,0)
          CALL DELETE(1)
      GO TO 24200
24100 I= 1
C     CHECK FOR STD
      IF (VAL.EQ.25) I = 0
      CALL GENSTO(I)
C     * CHECK FOR STD *
24200 IF(VAL.EQ.25) CALL DELETE(1)
      GO TO 99991
C     XCH
26000 CALL EXCH
      GO TO 99991
C     DEL
27000 CONTINUE
      IF ((ST(SP).NE.0).OR.(RASN(SP).NE.0).OR.(LITV(SP).GE.0))
     1    GO TO 27100
C     VALUE IS STACKED, SO GET RID OF IT
      CALL EMIT(POP,RH,0)
      REGV(RH) = -1
      REGV(RL) = -1
      CALL USTACK
27100 CALL DELETE(1)
      GO TO 99991
C
C     CAT (INLINE DATA FOLLOWS)
28000 CONTINUE
      CALL INLDAT
      GO TO 99999
C
C    LOD
29000 CONTINUE
      IL = 0
      K = PREC(SP)
C     MAY BE A LOD FROM A BASE FOR A BASED VARIABLE
      PREC(SP) = MOD(K,4)
      IA = RASN(SP)
      IF (IA.GT.0) GO TO 29050
C     CHECK FOR SIMPLE BASED VARIABLE CASE
      I = ST(SP)
      IF (I.LE.0) GO TO 29010
C         RESERVE REGISTERS FOR THE RESULT
          CALL GENREG(2,IA,IB)
          REGS(IA) = SP
          REGS(IB) = SP
          RASN(SP) = IB*16 + IA
C         MAY BE ABLE TO SIMPLIFY LHLD
          LP = REGV(RH)
          L = REGV(RL)
          IF ((LP.EQ.-3).AND.(-L.EQ.I)) GO TO 29110
          IF ((LP.EQ.-4).AND.(-L.EQ.I)) GO TO 29007
          J = CHAIN(I,CODLOC+1)
          CALL EMIT(LHLD,J,0)
          REGV(RH) = -3
          REGV(RL) = -I
          GO TO 29110
29007 CALL EMIT(DCX,RH,0)
      REGV(RH) = -3
      GO TO 29110
C
29010 CONTINUE
C     FIRST CHECK FOR AN ADDRESS REFERENCE
      IF (ST(SP).EQ.0) GO TO 29011
C         CHANGE THE ADDRESS REFERENCE TO A VALUE REFERENCE
          ST(SP) = -ST(SP)
          LITV(SP) = -1
          GO TO 99991
C     LOAD THE ADDRESS
29011 CONTINUE
      CALL LOADV(SP,0)
      IA = RASN(SP)
29050 IB = IA/16
      IA = MOD(IA,16)
      I = REGS(1)
      IF (IA.EQ.I) IA = 1
      IF (IB.EQ.I) IB = 1
      IF (IB.EQ.(IA-1)) IL = IB
      IF ((IA*IB).NE.0) GO TO 29100
          CALL ERROR(138,5)
          GO TO 99991
29100 CONTINUE
C     MAY BE POSSIBLE TO USE LDAX OR XCHG
      IF (IL.NE.RD) GO TO 29105
C     POSSIBLE XCHG OR LDAX
      IF (LASTEX.EQ.(CODLOC-1)) GO TO 29102
C     LAST INSTRUCTION NOT AN XCHG
      IF (MOD(PREC(SP),2).EQ.1) GO TO 29110
C     DOUBLE XCHG OR DOUBLE BYTE LOAD WITH ADDR IN D AND E
29102 CALL EMIT(XCHG,0,0)
      GO TO 29107
C
29105 CONTINUE
      CALL EMIT(LD,RL,IA)
      CALL EMIT(LD,RH,IB)
29107 IL = 0
      REGV(RH) = -1
      REGV(RL) = -1
29110 I = PREC(SP) - K/4
      PREC(SP) = I
C     RECOVER THE REGISTER ASSIGNMENT FROM RASN
      IB = RASN(SP)
      IA = MOD(IB,16)
      IB = IB/16
      J = REGS(1)
      K = J*(J-IA)*(J-IB)
C     JUMP IF J=0, IA, OR IB
      IF (K.EQ.0) GO TO 29150
          CALL EMIT(LD,J,RA)
C     SET PENDING STORE OPERATION IN REGS(1)
29150 CONTINUE
C     MAY BE ABLE TO CHANGE REGISTER ASSIGNMENT TO BC
      IF (IA.NE.RE) GO TO 29160
      IF ((REGS(RB).NE.0).OR.(REGS(RC).NE.0)) GO TO 29160
C         BC AVAILABLE, SO RE-ASSIGN
          REGS(IA) = 0
          REGS(IB) = 0
          REGS(RB) = SP
          REGS(RC) = SP
          IA = RC
          IB = RB
          RASN(SP) = RB*16+RC
29160 REGS(RA) = IA
      IF (IL.EQ.0) CALL EMIT(LD,RA,ME)
      IF (IL.NE.0) CALL EMIT(LDAX,IL,0)
      IF (I.GT.1) GO TO 29200
C     SINGLE BYTE LOAD - RELEASE H.O. REGISTER
          IB = RASN(SP)
          RASN(SP) = MOD(IB,16)
          IB = IB/16
          IF (IB.EQ.REGS(1)) REGS(1) = 0
          REGS(IB) = 0
          REGV(IB) = -1
          GO TO 29300
C
29200 CALL EMIT(INCX,RH,0)
C     MAY HAVE DONE A PREVOUS LHLD, IF SO MARK INCX H
      IF (REGV(RH).EQ.-3) REGV(RH) = -4
      CALL EMIT(LD,IB,ME)
29300 CONTINUE
      REGS(6) = 0
      REGS(7) = 0
      ST(SP) = 0
      GO TO 99991
C
C     INC
31000 CONTINUE
C     PLACE A LITERAL 1 AT STACK TOP AND APPLY ADD OPERATOR
      SP = SP + 1
      LITV(SP) = 1
C     CHECK FOR SINGLE BYTE INCREMENT, MAY BE COMPARING WITH 255
      IF (PREC(SP-1).NE.1) GO TO 1000
      CALL APPLY(AD,AC,1,1)
      LASTIN = CODLOC
C     TRA WILL NOTICE LASTIN = CODLOC AND SUBSTITUTE JFZ
      GO TO 99991
C
C     CSE (CASE STATEMENT INDEX)
32000 CONTINUE
C     LET X BE THE VALUE OF THE STACK TOP
C     COMPUTE 2*X + CODLOC, FETCH TO HL, AND JUMP WITH PCHL
C     RESERVE REGISTERS FOR THE JUMP TABLE BASE
      CALL GENREG(2,IA,IB)
      LOCK(IA) = 1
      LOCK(IB) = 1
C     INDEX IS IN H AND L, SO DOUBLE IT
      CALL EMIT(DAD,RH,0)
C     NOW LOAD THE VALUE OF TABLE BASE, DEPENDING UPON 9 BYTES
C     LXI R X Y, DAD R, MOV EM, INX H, MOV DM XCHG PCHL
      CALL EMIT(LXI,IB,CODLOC+9)
      CALL EMIT(DAD,IB,0)
      CALL EMIT(LD,RE,ME)
      CALL EMIT(INCX,RH,0)
      CALL EMIT(LD,RD,ME)
      CALL EMIT(XCHG,0,0)
      CALL EMIT(PCHL,0,0)
C     PHONEY ENTRY IN SYMBOL TABLE TO KEEP CODE DUMP CLEAN
      SYTOP = SYTOP + 1
      SYMBOL(SYTOP) = SYINFO
      SYMBOL(SYINFO) = -CODLOC
      SYINFO = SYINFO - 1
C     SET ENTRY TO LEN=0/PREC=2/TYPE=VARB/
      SYMBOL(SYINFO) = 32+VARB
      CASJMP = SYINFO
C     CASJMP WILL BE USED TO UPDATE THE LENGTH FIELD
      SYINFO = SYINFO - 1
      IF (SYINFO.LE.SYTOP) CALL ERROR(108,5)
C
      LOCK(IB) = 0
      REGV(RH) = -1
      REGV(RL) = -1
C     MARK H AND L NIL AT CASE OR COMPUTED JUMP BEFORE RETURNING
      GO TO 20550
C     HAL (HALT)
36000 CONTINUE
      CALL EMIT(EI,0,0)
      CALL EMIT(HALT,0,0)
      GO TO 99991
C
C     RTL RTR SFL SFR
37000 CONTINUE
      CALL UNARY(VAL)
      GO TO 99991
C
C     CVA (CONVERT ADDRESS TO DOUBLE PRECISION VARIABLE)
43000 CONTINUE
C     CVA MUST BE IMMEDIATELY PRECEDED BY AN INX OR ADR REF
      PREC(SP) = 2
C     IF THE ADDRESS IS ALREADY IN THE GPR'S THEN NOTHING TO DO
      IF (RASN(SP).GT.0) GO TO 99991
      IF (ST(SP).LT.0) GO TO 43100
      IF (ST(SP).GT.0) GO TO 43050
          CALL ERROR(139,1)
          GO TO 99999
C
C     LOAD VALUE OF BASE FOR ADDRESS REF TO A BASED VARIABLE
43050 CALL LOADV(SP,3)
      GO TO 99991
C
C     CHECK FOR ADDRESS REF TO DATA IN ROM.
43100 JP = LITV(SP)
      IF (JP.GT.65535) GO TO 43190
      IF (JP.LT.0) CALL ERROR(149,1)
C         LEAVE LITERAL VALUE
          ST(SP) = 0
          GO TO 99991
C
C     DO LXI R WITH THE ADDRESS
43190 CALL GENREG(2,IA,IB)
      IF (IA.GT.0) GO TO 43200
          CALL ERROR(140,5)
          GO TO 99999
C
43200 J = CHAIN(-ST(SP),CODLOC+1)
      CALL EMIT(LXI,IB,J)
      ST(SP) = 0
      RASN(SP) = IB*16+IA
      REGS(IA) = SP
      REGS(IB) = SP
      GO TO 99991
C
C
C     ORG
44000 CONTINUE
      I = LITV(SP)
      IF (CODLOC.LE.I) GO TO 44100
          CALL ERROR(141,1)
C
44100 J = CONTRL(47)
      K = 3
      IF (J.EQ.1) K = 0
      IF (CODLOC.NE.(OFFSET+PREAMB+K)) GO TO 44200
C         THIS IS THE START OF PROGRAM, CHANGE OFFSET
          OFFSET = I - PREAMB
          CODLOC = I + K
          IF (LXIS.GT.0) LXIS = CODLOC - 2
C         WE HAVE ALREADY GENERATED LXI SP (IF ANY)
          GO TO 99990
C     SOME CODE HAS BEEN GENERATED, SO LXI IF NECESSARY
44200 IF (CODLOC.GE.I) GO TO 44300
          CALL EMIT(0,0,0)
          GO TO 44200
C
44300 IF (J.EQ.1) GO TO 99990
      IF (J.GT.1) GO TO 44400
          J = LXIS
          LXIS = CODLOC + 1
44400 CALL EMIT(LXI,RSP,J)
      GO TO 99990
C
C     DRT (DEFAULT RETURN FROM SUBROUTINE)
C     MERGE H AND L VALUES USING RET OPERATION ABOVE
45000 CONTINUE
          JP = PRSP
      IF (PRSTK(JP).LE.65535) GO TO 45005
C     THIS IS THE END OF AN INTERRUPT PROCEDURE
      CURDEP(JP+1) = CURDEP(JP+1) - 4
45005 CONTINUE
          IF (PRSP.GT.0) PRSP = PRSP - 1
C         GET STACK DEPTH FOR SYMBOL TABLE
          IF (JP.LE.0) GO TO 45010
      IF (CURDEP(JP+1).NE.0) CALL ERROR(150,1)
          K = MAXDEP(JP+1)
          L = MOD(PRSTK(JP),65536) - 1
C         K IS MAX STACK DEPTH, L IS SYMBOL TABLE COUNT ENTRY
          SYMBOL(L) = K
45010     K = REGV(6)
          L = REGV(7)
          IF ((K.EQ.-255).AND.(L.EQ.-255)) GO TO 99999
      IF (PRSTK(JP).LE.65535) GO TO 45030
45020 CONTINUE
C         POP INTERRUPTED REGISTERS AND ENABLE INTERRUPTS
          CALL EMIT(POP,RA,0)
          CALL EMIT(POP,RB,0)
          CALL EMIT(POP,RD,0)
          CALL EMIT(POP,RH,0)
          CALL EMIT(EI,0,0)
45030 CALL EMIT(RTN,0,0)
          IF ((K.EQ.-254).AND.(L.EQ.-254)) GO TO 20550
          IF (JP.GT.0) GO TO 23350
          CALL ERROR(146,1)
          GO TO 20550
C
C     ENA  -  ENABLE INTERRUPTS
45100 CONTINUE
      CALL EMIT(EI,0,0)
      GO TO 99999
C     DIS  - DISABLE INTERRUPTS
45200 CONTINUE
      CALL EMIT(DI,0,0)
      GO TO 99999
C
C     AX1 - CASE BRANCH TO CASE SELECTOR
45500 CONTINUE
C     LOAD CASE NUMBER TO H AND L
      CALL EXCH
      CALL LOADV(SP,4)
      CALL DELETE(1)
      REGV(RH) = -1
      REGV(RL) = -1
C     USE TRA CODE
      GO TO 20000
C
C     MAY NOT BE OMITTED EVEN THOUGH NO OBVIOUS PATH EXISTS).
46000 IOP = 4
C     CASJMP POINTS TO SYMBOL TABLE ATTRIBUTES - INC LEN FIELD
      SYMBOL(CASJMP) = SYMBOL(CASJMP) + 256
      GO TO 20050
88887 IOP2 = IOP
88888 CALL APPLY (IOP,IOP2,ICOM,ICY)
      GO TO 99991
99990 SP = SP - 1
99991 ALTER = 1
99999 RETURN
      END
      SUBROUTINE SYDUMP
C     DUMP THE SYMBOL TABLE FOR THE SIMULATOR
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER GNC,RIGHT,SHL,SHR,GET
      INTEGER CHAR(32),ICHAR,ADDR
C     CLEAR THE OUTPUT BUFFER
      CALL WRITEL(0)
      L = 0
C     SAVE THE CURRENT INPUT FILE NUMBER, POINT INPUT
C     AT SYMBOL FILE.
      M = CONTRL(20)
      CONTRL(20) = CONTRL(32)
C     GET RID OF LAST CARD IMAGE
      IBP = 99999
50    I = GNC(0)
      IF (I.EQ.1) GO TO 50
      IF (I.NE.41) GO TO 8000
C
C     PROCESS NEXT SYMBOL TABLE ENTRY
100   I = GNC(0)
      IF (I.EQ.41) GO TO 9000
C     PROCESS THE NEXT SYMBOL
110   I = I - 2
C     BUILD ADDRESS OF INITIALIZED SYMBOL
      K = 32
          DO 200 J=1,2
          I = (GNC(0)-2)*K+I
200       K = K * 32
C
      IF(I.GT.4.AND.I.NE.6) GO TO 260
250   J=GNC(0)
      IF(J.EQ.41) GO TO 100
      GO TO 250
260   CONTINUE
C     WRITE SYMBOL NUMBER, SYMBOL, AND ABSOLUTE ADDRESS (OCTAL)
          CALL CONOUT(1,-5,I,10)
          CALL PAD(1,1,1)
          ICHAR = 1
          DO 290 K = 1,32
            CHAR(K) = 40
290       CONTINUE
C     READ UNTIL NEXT / SYMBOL
300       J = GNC(0)
          IF (J.EQ.41) GO TO 400
          CHAR(ICHAR) = J
          ICHAR = ICHAR + 1
C     WRITE NEXT CHARACTER IN STRING
          CALL PAD(1,J,1)
          GO TO 300
C
C     END OF SYMBOL
400   CALL PAD(1,1,1)
C     WRITE OCTAL ADDRESS
      J = SYMBOL(I)
      I = IABS(SYMBOL(J))
      J = SYMBOL(J-1)
      IF (MOD(J,16).EQ.VARB) GO TO 410
C     SYMBOL IS A LABEL, SO SHIFT RIGHT TO GET ADDR
      I = I/65536
410   CONTINUE
      CALL CONOUT(1,5,I,16)
      ADDR = I
      CALL PAD(1,1,3)
      IF (CONTRL(13).EQ.0) GO TO 430
        N = CONTRL(26)
        CONTRL(26) = CONTRL(13)
        CALL WRITEL(0)
        L = 1
        CONTRL(26) = N
430   CONTINUE
      OBP = CONTRL(36) - 1
      IF (CONTRL(24).EQ.0) GO TO 440
        CALL FORM(1,CHAR,1,32,32)
        CALL CONOUT(1,4,ADDR,16)
        CALL WRITEL(0)
440   CONTINUE
      GO TO 100
C
8000  CALL ERROR(143,1)
C
9000  IF (L.EQ.0) GO TO 9999
      IF (CONTRL(13).EQ.0) GO TO 9999
        CALL PAD(1,1,1)
        CALL PAD(1,38,1)
        N = CONTRL(26)
        CONTRL(26) = CONTRL(13)
        CALL WRITEL(0)
        CONTRL(26) = N
C
9999  CONTINUE
      CONTRL(20) = M
      RETURN
      END
      BLOCK DATA
      INTEGER TITLE(10),VERS
      COMMON/TITLES/TITLE,VERS
      INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS
      LOGICAL ERRFLG
      INTEGER TERR(22)
      COMMON/TERRR/TERR,ERRFLG
      INTEGER SMSSG(29)
      COMMON/SMESSG/SMSSG
      COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS
C     PSTACK IS THE PROCEDURE STACK USED IN HL OPTIMIZATION
      INTEGER XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL
      INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR
      COMMON /XFROPT/XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL
C     XFROPT IS USED IN BRANCH OPTIMIZTION
      INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM
      COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM
C     BUILT-IN FUNCTION CODE (MULTIPLICATION AND DIVISION)
      INTEGER BIFTAB(41),BIFPAR
      COMMON /BIFCOD/BIFTAB,BIFPAR
      INTEGER IBUFF(80),OBUFF(120),IBP,OBP,
     1    ITRAN(256),OTRAN(64)
      COMMON /FILES/IBUFF,OBUFF,IBP,OBP,
     1    ITRAN,OTRAN
      INTEGER CONTRL(64)
      COMMON /CNTRL/CONTRL
      INTEGER MSSG(77)
      COMMON/MESSG/MSSG
C
      INTEGER POLCHR(18),OPCVAL(51)
      COMMON /OPCOD/POLCHR,OPCVAL
C     OPRADRVALDEFLITLIN
      INTEGER INTPRO(8)
      COMMON /INTER/INTPRO
      INTEGER DEBASE
      COMMON /BASE/DEBASE
      INTEGER INLOC,OUTLOC,FIRSTI,CASJMP
      COMMON /BIFLOC/INLOC,OUTLOC,FIRSTI,CASJMP
      INTEGER CTRAN(256),C1(100),C2(100),C3(56)
      EQUIVALENCE (C1(1),CTRAN(1)),(C2(1),CTRAN(101)),
     1    (C3(1),CTRAN(201))
      INTEGER INSYM(284),INSYM1(150),INSYM2(134)
      EQUIVALENCE (INSYM1(1),INSYM(1)),
     1    (INSYM2(1),INSYM(151))
      INTEGER IBYTES(23)
      COMMON /INST/CTRAN,INSYM,IBYTES
      INTEGER CODLOC,ALTER,CBITS(43)
      COMMON /CODE/CODLOC,ALTER,CBITS
      INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC,
     1   CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,
     1   JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT,
     2   STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI,
     3   LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX,
     4   RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL,
     5   CY,ACC,CARRY,ZERO,SIGN,PARITY
      INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16),
     1    SP,MAXSP,INTBAS
      COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS
      INTEGER REGMAP(9)
      COMMON /RGMAPP/ REGMAP
      INTEGER VARB,INTR,PROC,LABEL,LITER
      COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER
      INTEGER STHEAD(12)
      COMMON /STHED/ STHEAD
      INTEGER OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      COMMON /ILCOD/ OPR,ADR,VLU,DEF,LIT,LIN,
     *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR,
     *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC,
     *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS,
     *AX1,AX2,AX3
      INTEGER WDSIZE,WFACT,TWO8,FACT(5)
      INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB
      COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT
      COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB
C     ... PLM2 VERS ...
      DATA OFFSET/0/
      DATA TITLE/27,23,24, 4, 1,33,16,29,30, 1/
      DATA VERS/20/
C     COMPILATION TERMINATED
      DATA TERR/14,26,24,27,20,23,12,31,20,26,25, 1,
     1    31,16,29,24,20,25,12,31,16,15/
      DATA ERRFLG /.FALSE./
C     STACK SIZE = OVERRIDDEN BYTES
      DATA SMSSG /30,31,12,14,22,1,
     1    30,20,37,16,1,  39,1,
     2    26,33,16,29,29,20,15,15,16,25,1,
     3    13,36,31,16,30/
      DATA PRSTK /15*0/, PRSMAX /15/, PRSP /0/
      DATA MAXDEP /16*0/, CURDEP /16*0/, LXIS /0/
C     PEEP IS USED IN PEEPHOLE OPTIMIZATION (SEE EMIT)
C         LAPOL IS A ONE ELEMENT POLISH LOOK-AHEAD
C         LASTLD IS CODLOC OF LAST REGISTER TO MEMORY STORE
C         LASTRG IS THE EFFECTED REGISTER
C         LASTIN IS THE CODLOC OF THE LAST INCREMENT
C         (USED IN DO-LOOP INDEX INCREMENT)
C         LASTEX IS LOCATION OF LAST XCHG OPERATOR
C         LASTIR IS THE CODLOC OF THE LAST REGISTER INCREMENT
C         (USED IN APPLY AND GENSTO TO GEN INR MEMORY)
      DATA LAPOL/-1/, LASTLD/0/, LASTRG/0/, LASTIN /0/, LASTEX /0/,
     1    LASTIR /0/
      DATA XFRLOC /-1/, XFRSYM /0/, TSTLOC /-1/, CONLOC /-1/,
     1    DEFSYM /0/, DEFRH /-1/, DEFRL /-1/
      DATA SYMAX /3000/, SYTOP /0/, SYINFO /3000/
      DATA BIFPAR /0/
C     BUILT-IN FUNCTION VECTOR --
C     MULTIPLY AND DIVIDE OR MOD
C     +  FIRST TWO GIVE BASE LOCATIONS OF BIF CODE SEGMENTS
C     +  NEXT COMES NUMBER OF BYTES, NUMBER OF RELOCATIONS, AND
C     +  A VECTOR OF ABSOLUTE LOCATIONS WHERE STUFFS OCCUR
C
C     THE CODE SEGMENTS ARE ABSOLUTE, PACKED THREE PER ENTRY
C
C
C MULTIPLY
C
C 121 147 120 154 242 012 000 096 105 235 068 077 033 000 000 235
C 120 177 200 235 120 031 071 121 031 079 210 030 000 025 235 041
C 195 016 000
C
C DIVIDE
C
C 122 047 087 123 047 095 019 033 000 000 062 017 229 025 210 018
C 000 227 225 245 121 023 079 120 023 071 125 023 111 124 023 103
C 241 061 194 012 000 183 124 031 087 125 031 095 201
C
      DATA BIFTAB/
     1 -3, -20,
     1 35, 3, 5, 27, 33,
     1 7902073, 848538, 6905856, 5063915, 33, 11630827,
     1 7924680, 7948063, 13782815, 1638430, 12790251, 16,
     1 45, 2, 15, 35,
     1 5713786, 6238075, 8467, 1129984, 13769189,
     1 14876690, 7992801, 7884567, 8210199, 8154903,
     1 15820567, 836157, 8173312, 8214303, 13197087,
     1 0, 0, 0/
      DATA CONTRL /64*0/
      DATA IBP /81/, OBP /0/
      DATA OTRAN /1H ,1H0,1H1,1H2,1H3,1H4,
     1    1H5,1H6,1H7,1H8,1H9,1HA,1HB,1HC,1HD,1HE,1HF,
     2    1HG,1HH,1HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,
     3    1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ,
     4    1H$,1H=,1H.,1H/,1H(,1H),1H+,1H-,1H',1H*,1H,,
     5    1H<,1H>,1H:,1H;,12*0/
C     PASS-NOPROGRAM
C     ERROR
C     ()NEARAT
C     PARSE STACK
C     SYMBOL  ADDR WDS CHRS   LENGTH PR TY
      DATA MSSG /27,12,30,30,45,
     1    25,26,27,29,26,18,29,12,24,1,
     2    16,29,29,26,29,
     3    42,43,25,16,12,29,12,31,
     4    27,12,29,30,16,1,30,31,12,14,22,51,1,
     5    30,36,24,13,26,23, 1,1,  12,15,15,29, 1, 34,15,30, 1,
     6    14,19,29,30, 1,1,1, 23,16,25,18,31,19,  1,27,29,  1,31,36/
      DATA INTPRO /8*0/
      DATA POLCHR /26,27,29, 12,15,29, 33,12,23, 15,16,17,
     1    23,20,31, 23,20,25/
      DATA DEBASE /16/
      DATA INLOC /16/, OUTLOC /17/, CASJMP /0/, FIRSTI /7/
C     NUMBER OF BYTES FOLLOWING FIRST 13 INSTRUCTIONS IN CATEGORY 3
      DATA IBYTES /0,0,0,0,2,2,0,0,1,1,0,2,2,
     1     0,0,0,0,0,0,0,0,2,2/
      DATA C1 /
     1    835,   36,   40,   42, 1057, 2081, 1280,   35,  995,   39,
     2     41,   43, 1089, 2113, 2304,   67,  995,  100,  104,  106,
     3    1121, 2145, 3328,   99,  995,  103,  105,  107, 1153, 2177,
     4    4352,  131,  995,  164,  707,  170, 1185, 2209, 5376,  675,
     5     995,  167,  739,  171, 1217, 2241, 6400,  579,  995,  292,
     6     387,  298, 1249, 2273, 7424,  611,  995,  295,  419,  299,
     7    1025, 2049,  256,  643, 1056, 1088, 1120, 1152, 1184, 1216,
     8    1248, 1024, 2080, 2112, 2144, 2176, 2208, 2240, 2272, 2048,
     9    3104, 3136, 3168, 3200, 3232, 3264, 3296, 3072, 4128, 4160,
     A   4192, 4224, 4256, 4288, 4320, 4096, 5152, 5184, 5216, 5248/
      DATA C2 /
     1   5280, 5312, 5344, 5120, 6176, 6208, 6240, 6272, 6304, 6336,
     2    6368, 6144, 7200, 7232, 7264, 7296, 7328, 7360,  355, 7168,
     3     32,   64,   96,  128,  160,  192,  224,    0, 3105, 3137,
     4    3169, 3201, 3233, 3265, 3297, 3073, 4129, 4161, 4193, 4225,
     5    4257, 4289, 4321, 4097, 5153, 5185, 5217, 5249, 5281, 5313,
     6    5345, 5121, 6177, 6209, 6241, 6273, 6305, 6337, 6369, 6145,
     7    7201, 7233, 7265, 7297, 7329, 7361, 7393, 7169, 8225, 8257,
     8    8289, 8321, 8353, 8385, 8417, 8193, 9249, 9281, 9313, 9345,
     9    9377, 9409, 9441, 9217,10273,10305,10337,10369,10401,10433,
     A  10465,10241, 3106,   38, 1058,  163, 2082,   37, 3329,  259/
      DATA C3 /
     1   3234,  227, 1186,  995, 2210,  195, 4353, 1283, 3074,  102,
     2    1026,  323, 2050,  101, 5377, 2307, 3202,  995, 1154,  291,
     3    2178,  995, 6401, 3331, 3170,  166, 1122,  483, 2146,  165,
     4    7425, 4355, 3298,  547, 1250,  451, 2274,  995, 8449, 5379,
     5    3138,    6, 1090,  803, 2114,    5, 9473, 6403, 3266,  515,
     6    1218,  771, 2242,  995,10497, 7427/
C
      DATA INSYM1 /
     1     15, 38, 60, 66,108,116,234,240,247,253,259,266,273,279, 10,
     2     27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 38, 12, 13, 14, 15,
     3     16, 19, 23, 24, 20, 30, 27,  8, 48, 50, 52, 53, 55, 56, 57,
     4     58, 60, 25, 14, 25, 37, 27, 27, 26, 14, 37, 24, 27, 16,  1,
     5     63, 66, 24, 26, 33, 10, 78, 81, 84, 87, 90, 93, 96, 99,102,
     6    105,108, 20, 25, 29, 15, 14, 29, 12, 15, 15, 12, 15, 14, 30,
     7     32, 13, 30, 13, 14, 12, 25, 12, 35, 29, 12, 26, 29, 12, 14,
     8     24, 27,  3,113,114,115,116, 21, 14, 29, 31,149,152,155,158,
     9    161,164,168,171,174,176,179,182,185,188,192,196,200,204,207,
     A    210,213,216,220,224,226,228,231,231,231,231,231,234, 29, 23/
      DATA INSYM2 /
     1     14, 29, 29, 14, 29, 12, 23, 29, 12, 29, 21, 24, 27, 14, 12,
     2     23, 23, 29, 16, 31, 29, 30, 31, 20, 25, 26, 32, 31, 19, 23,
     3     31, 30, 31, 12, 23, 15, 12, 35, 14, 19, 18, 35, 31, 19, 23,
     4     30, 27, 19, 23, 27, 14, 19, 23, 14, 24, 12, 30, 31, 14, 14,
     5     24, 14, 15, 12, 12, 30, 19, 23, 15, 23, 19, 23, 15, 16, 20,
     6     15, 20, 25, 26, 27, 45, 45, 45,  1,237,240, 23, 35, 20,  1,
     7    243,247, 27, 32, 30, 19,  1,250,253, 27, 26, 27,  1,256,259,
     8     15, 12, 15,  1,262,266, 30, 31, 12, 35,  1,269,273, 23, 15,
     9     12, 35,  1,276,279, 20, 25, 35,  1,282,285, 15, 14, 35/
      DATA CODLOC /0/
C  STA    011    000    LDA    011    000    XCHG   SPHL   PCHL
C  CMA    STC    CMC    DAA    SHLD   011    000    LHLD   011
C  000    EI     DI     LXI B  011    000    PUSH B POP B  DAD B
C  STAX B LDAX B INX B  DCX B  NOP    NOP    NOP    NOP    NOP
C  050 011 000 058 011 000 235 249 233 047 055 063 039 034 011 000
C  042 011 000 251 243 001 011 000 197 193 009 002 010 003 011 000
      DATA CBITS /64,4,5,128,136,144,152,160,168,176,184,7,
     1    195,194,205,196,201,192,199,219,211,118,
     2    50,58,235,249,233,47,55,63,39,34,42,251,243,1,
     3    197,193,9,2,10,3,11/
      DATA LD /1/, IN /2/, DC /3/, AD /4/, AC /5/, SU /6/,
     1   SB /7/, ND /8/, XR /9/, OR /10/, CP /11/, ROT /12/,
     2   JMP /13/, JMC /14/, CAL /15/, CLC /16/, RTN /17/, RTC /18/,
     3   RST /19/, INP /20/, OUT /21/, HALT /22/,
     4   STA /23/, LDA /24/, XCHG /25/, SPHL /26/, PCHL /27/, CMA /28/,
     5   STC /29/, CMC /30/, DAA /31/, SHLD /32/, LHLD /33/, EI /34/,
     6   DI /35/, LXI /36/, PUSH /37/, POP /38/, DAD /39/, STAX /40/,
     7   LDAX /41/, INCX /42/, DCX /43/
      DATA RA /1/, RB /2/, RC /3/, RD /4/, RE /5/, RH /6/, RL /7/,
     1   RSP/9/, ME /8/, LFT /9/, RGT /10/, TRU /12/, FAL /11/, CY /13/,
     2   ACC /14/, CARRY /15/, ZERO /16/, SIGN /17/, PARITY /18/
      DATA REGS/7*0/, REGV/7*-1/, LOCK /7*0/,  SP /0/, MAXSP /16/
      DATA REGMAP /7,0,1,2,3,4,5,6,6/
C     INTBAS IS THE LARGEST INTRINSIC SYMBOL NUMBER
      DATA INTBAS /23/
      DATA VARB /1/, INTR /2/, PROC /3/, LABEL /4/, LITER /6/
C     PRSTRASNLITV
      DATA STHEAD /27,29,30,31,29,12,30,25,23,20,31,33/
      DATA OPR /0/, ADR /1/, VLU /2/, DEF /3/, LIT /4/, LIN /5/,
     *NOP/ 0/,ADD/ 1/,ADC/ 2/,SUB/ 3/,SBC/ 4/,MUL/ 5/,DIV/ 6/,MDF/ 7/,
     *NEG/ 8/,AND/ 9/,IOR/10/,XOR/11/,NOT/12/,EQL/13/,LSS/14/,GTR/15/,
     *NEQ/16/,LEQ/17/,GEQ/18/,INX/19/,TRA/20/,TRC/21/,PRO/22/,RET/23/,
     *STO/24/,STD/25/,XCH/26/,DEL/27/,DAT/28/,LOD/29/,BIF/30/,INC/31/,
     *CSE/32/,END/33/,ENB/34/,ENP/35/,HAL/36/,RTL/37/,RTR/38/,SFL/39/,
     *SFR/40/,HIV/41/,LOV/42/,CVA/43/,ORG/44/,DRT/45/,ENA/46/,DIS/47/,
     *AX1/48/,AX2/49/,AX3/50/
      DATA OPCVAL /
     * 104091,  50127,  50126, 124941, 123726, 100375,  62753, 119832,
     * 103442,  50767,  83613, 145053, 104095,  67351,  96158,  75741,
     * 103452,  95260,  74780,  83555, 128844, 128846, 112474, 119839,
     * 124890, 124879, 144275,  62487,  62239,  95887,  54545,  83534,
     *  59280,  67151,  67149,  67163,  78615, 120791, 120797, 123991,
     * 123997,  79137,  95905,  59468, 108370,  63327,  67148,  62750,
     *  51395,  51396,  51397/
      DATA WDSIZE /31/, TWO8 /256/, MAXMEM /2500/
      END