!! %option stack=40
!!!!!!  19-Feb-82!!!! 26/6/78 - IMPASEMS412
{Modified to run on new subsystem so that old supervisor can be supported}

%OWNSTRING(4) P2VERSION = "4.13"


!!!!!!%CONTROL 3;                     ! CHECK SWITCHES AND STACK LIMIT
%BEGIN;                         ! INTERDATA 7/32 IMP ASSEMBLER !

! SIZE CONSTANTS

   %CONSTINTEGER MAX ENVIRS = 13
!  %CONSTINTEGER MAX VARS   = 490
   %CONSTINTEGER MAX LABELS = 80
   %CONSTINTEGER MAX DEPTH  = 16
   %CONSTINTEGER MAX STACK  = 31
   %CONSTINTEGER INIT GLA   = 32;    !  **USED LOCALLY AND IN PASS 3**
   %CONSTINTEGER LAST PERM  = -24;   ! MUST MATCH PERM TABLE IN PASS 3

!  STATIC GLA LAYOUT
!
!     0:  STACK LIMIT
!     4:  @diag tables (zero if missing)
!     8:  IOCP switch base
!    12:  IOCP gla base
!    16:  IOCP code base
!    20:  IOCP base level locals
!    24:  -spare-
!    28:  -spare-
!


   %CONSTINTEGER INITIAL FREE = 5120;  ! INITIAL FREE STACK(BYTES)
   %CONSTINTEGER MIN FREE = 600;   ! LOWER LIMIT ON FREE STACK SPACE

! ON THE 32-BIT SERIES, EFFICIENT(RX1) BASE+DISPLACEMENT ADDRESSING
! IS ONLY AVAILABLE FOR VALUES OF DISPLACEMENT < 16*1024.
! ARRAYS WITH FIXED BOUNDS ARE PUT INTO THE STATIC STACK FRAME
! UNTIL THE FRAME SIZE > 'MAX STATIC' LEAVING [16*1024 - MAX STATIC]
! BYTES AVAILABLE FOR SCALARS.  THERE MAY STILL BE PROBLEMS WITH
! LARGE RECORDS (WHICH CAN CONTAIN ARRAYS).

   %CONSTINTEGER  MAX STATIC = 13000



! WORDLENGTH DEPENDENT VALUES:

   %CONSTINTEGER  REGLEN=4;     ! REGISTER LENGTH(IN 8-BIT BYTES)



!  COMPILER CONTROL OPTIONS (DEFAULT MARKED *)
   %CONSTINTEGER TEST SWITCH = 1;   !* CHECK SWITCH JUMPS
   %CONSTINTEGER STKDIAG     = 2;   !* CHECK EXTENT OF STACK
   %CONSTINTEGER ARRAY DIAG  = 4;   !* CHECK ARRAY BOUNDS
   %CONSTINTEGER FORDIAG     = 8;   !* VALIDATE %FOR PARAMETERS
   %CONSTINTEGER ASS DIAG    =16;   !* TEST FOR TRUNCATION
   %CONSTINTEGER UNASS DIAG  =32;   !* CHECK FOR UNASSIGNED VARIABLES
   !
   %CONSTINTEGER TRUSTED     =4096; !  ENABLE DIRTY OPTIMISATIONS

! %CONTROL 0 GIVES TIGHTEST CODE (NO CHECKING AT ALL!)




!  COMPILER ERROR CODES
!  --------------------
!  CODE      ROUTINE                    MEANING
!  ----      -------                    -------
!    1       RELEASE                    TOO MANY CALLS ON 'RELEASE'
!    2       CHECK RELEASED             TOO FEW CALLS ON 'RELEASE'
!    3       HAZARD                     FAULTY PARAM. SUPPLIED TO HAZARD??
!    4       ""                         "" ????
!    5       RX, RI2, RI3               ILLEGAL ADDRESS FIELD GENERATE
!    6       LOOKUP                     UNDEFINED NAME IN INTERMEDIATE COD
!    7       STACK, SSTACK ETC          DESCRIPTOR STACK OVERFLO
!    8       SET BOTH, POP LHS, ASSIGN  DESCRIPTOR STACK UNDERFLO
!    9       AMAP                       FAULTY PARAM. SUPPLIED TO 'AMAP'
!    10      LOAD                       'REAL' AS ADDRESS?
!    11      LOAD                       FLOATING REG. REQ'D
!    12      "                          "
!    13      COP                        FAULTY PARAM. SUPPLIED TO 'COP'
!    14      ASSEMBLE                   DESCRIPTOR STACK NON-EMPTY AT 'O
!    15      ASSIGN                     FAULTY PARAM. SUPPLIED TO 'ASSIGN'
!    16      LOAD                       'REAL', INTEGER REQ''D
!    17      DESCRIPTOR                 NO FREE DESCRIPTORS
!    18      DROP                       DESCRIPTOR NOT IN USE
!    19      ASSEMBLE                   DANGLING DESCRIPTOR

! REGISTERS

   %CONSTINTEGER R0   = 1
   %CONSTINTEGER R1   = 2
   %CONSTINTEGER R2   = 3
   %CONSTINTEGER R3   = 4
   %CONSTINTEGER R4   = 5
   %CONSTINTEGER P2   = 6
   %CONSTINTEGER P1   = 7
   %CONSTINTEGER R9   = 8
   %CONSTINTEGER R10  = 9
   %CONSTINTEGER R11  = 10
   %CONSTINTEGER R12  = 11
   %CONSTINTEGER LINK = 12
   %CONSTINTEGER FPR0 = 13
   %CONSTINTEGER FPR2 = 14
   !             FPR4 = 15
   !             FPR6 = 16
   !             FPR8 = 17
   !             FPR10= 18
   !             FPR12= 19
   %CONSTINTEGER FPR14= 20

   !   21 - 40 ARE STORE EQUIVALENTS OF ABOVE

   %CONSTINTEGER R15  = 41
   %CONSTINTEGER GLA  = 42
   %CONSTINTEGER WSP  = 43
   %CONSTINTEGER CODE = 44

   %CONSTINTEGER ANY  = 45
   %CONSTINTEGER ANY0 = 46
   %CONSTINTEGER ANYF = 47
   %CONSTINTEGER PARAM= 48

   %CONSTINTEGER STORE= 20

   %CONSTBYTEINTEGERARRAY BASE REG(0:5) = R0, R15, R9, R10, R11, R12
   %CONSTBYTEINTEGERARRAY ACTUAL(0:44) = 0,
                                     0, 1, 2, 3, 4, 5, 6, 9,
                                    10,11,12, 8,
                                     0, 2, 4, 6, 8,10,12,14,
                                     0(20), 15, 13, 7, 14


! DATA FORMS

   !  EXTERNAL

   %CONSTINTEGER SWITCH    = 6
   %CONSTINTEGER ARRAY     = 11
   %CONSTINTEGER ARRAYNAME = 12

   !  INTERNAL

   %CONSTINTEGER CONSTANT = 0
   %CONSTINTEGER V IN R   = 1
   %CONSTINTEGER A IN S   = 2
   %CONSTINTEGER V IN S   = 3
   %CONSTINTEGER A IN REC = 4
   %CONSTINTEGER V IN REC = 5
   %CONSTINTEGER AV IN S  = 6
   %CONSTINTEGER AV IN REC= 7

!  LABEL CONSTANTS

   %CONSTINTEGER DEFINE   = 0
   %CONSTINTEGER REDEFINE = 1

! DATA TYPES

   %CONSTINTEGER INTEGER = 1
   %CONSTINTEGER BYTE    = 2
   %CONSTINTEGER SHORT   = 3
   %CONSTINTEGER STRING  = 4
   %CONSTINTEGER RECORD  = 5
   %CONSTINTEGER REALS   = 6
   %CONSTINTEGER LONG    = 7

   %CONSTINTEGER UNSIGNED HALFWORD = 255;   ! INTERNAL TO PASS 2

! OWN INFO

!  %CONSTINTEGER OWN    = 1
   %CONSTINTEGER CON    = 2
   %CONSTINTEGER PERMRT = 7

! PROC INFO

   %CONSTINTEGER FORMATS   = '2'
   %CONSTINTEGER PROCEDURE = '1'
   %CONSTINTEGER SPEC      = '0'

!  OBJECT FILE DIRECTIVES

   %CONSTINTEGER START     = 1
   %CONSTINTEGER LOAD CODE = 2
   %CONSTINTEGER LOAD GLA  = 3
   %CONSTINTEGER LINE FLAG = 4
   %CONSTINTEGER C END     = 5
!  %CONSTINTEGER L DATA    = 6
   %CONSTINTEGER DLINE     = 10
   %CONSTINTEGER DIAGS     = 11

! DIRECTIVE FILE COMMANDS

   %CONSTINTEGER TAG DEF   = 1
   %CONSTINTEGER C REF     = 2;  ! CONDITIONAL JUMP REF.
   %CONSTINTEGER J REF     = 3;  ! UNCONDITIONAL JUMP REF.
   %CONSTINTEGER R REF     = 4;  ! ROUTINE REF. (UNCONDITIONAL)
   %CONSTINTEGER P REF     = 5;  ! PERM REF. (UNCONDITIONAL)
   %CONSTINTEGER PATCH GLA = 6
   %CONSTINTEGER PATCHCODE = 7
   %CONSTINTEGER D END     = 8;  ! END OF DIRECTIVES FILE

! FILE DEFINITION

   %CONSTINTEGER INSTREAM = 2
   %CONSTINTEGER REPORT   = 0;    ! ...ERROR MESSAGE STREAM
   %CONSTINTEGER LIST     = 1
   %CONSTINTEGER OBJECT   = 2
   %CONSTINTEGER DIRECT   = 3


! SYMBOLS

   %CONSTINTEGER COMMA = ','
   %CONSTINTEGER MINUS = '-'

! PERM ROUTINES (FPR4,  FPR2,P1,P2,R4,  R3,R2,R1,R0)

   %CONSTINTEGER MONITOR    = X'1EF01'
   %CONSTINTEGER R COPY     = X'00902'
   %CONSTINTEGER R CLEAR    = X'00903'
   %CONSTINTEGER SWJUMP     = X'1EF04'
   %CONSTINTEGER ASET       = X'06F05'
   %CONSTINTEGER IEXP       = X'00B07'
   %CONSTINTEGER REXP       = X'18108'
   %CONSTINTEGER ALLOC      = X'02E09'
   %CONSTINTEGER SMOVE      = X'0090B', CONC1 = X'0090B'
   %CONSTINTEGER CONC2      = X'0630C'
   %CONSTINTEGER SCOMP      = X'06B0D'
   %CONSTINTEGER RSYM       = X'1EF0E'
! PERM ITEMS TO PERFORM VARIOUS RUN-TIME CHECKS
   %CONSTINTEGER EXBUNASS   = X'01112'
   %CONSTINTEGER EXB        = X'00113'
   %CONSTINTEGER A REF      = X'00314'
   %CONSTINTEGER STRINGASS  = X'00015';      ! ASSIGN TEST FOR STRINGS
   %CONSTINTEGER ASSTH      = X'00016';      ! ASSIGN TEST FOR SHORTS
   %CONSTINTEGER ASSTB      = X'00017';      ! ASSIGN TEST FOR BYTES
   %CONSTINTEGER FORTEST    = X'1EF18'

!   FIXED GLA WORDS

   !    (WORD 0 IS STACK LIMIT POINTER)
   %CONSTINTEGER SIGNAL EP = 4;       ! ADDRESS OF %SIGNAL


!   NOTEWORTHY CODE BLOCK DISPLACEMENTS

   %CONSTINTEGER UNASS PAT = 16;       ! UNASSIGNED VARIABLE PATTERN (80808080)

! OPERATIONS

   %CONSTINTEGER NOT = 1
   %CONSTINTEGER NEG = 2
   %CONSTINTEGER ADD = 3
   %CONSTINTEGER SUB = 4
   %CONSTINTEGER MUL = 6
   %CONSTINTEGER DIV = 7
   %CONSTINTEGER AND = 8
   %CONSTINTEGER IOR = 9
   %CONSTINTEGER XOR = 10
   %CONSTINTEGER LSH = 11
   %CONSTINTEGER RSH = 12
   %CONSTINTEGER EXP = 13
   %CONSTINTEGER CONC= 14
   %CONSTINTEGER SADD= 15;                !  SPECIAL ADD (V=V+??)
   %CONSTINTEGER RDIV= 16
   %CONSTINTEGER REM = 17

! OPCODES

   %CONSTINTEGER LIS = X'2400', LCS = X'2500'
   %CONSTINTEGER LR  = X'0800'
   %CONSTINTEGER LH  = X'4800', STH = X'4000'
   %CONSTINTEGER LHI = X'C800'
   %CONSTINTEGER LM  = X'D100', STM = X'D000'
   %CONSTINTEGER LHL = X'7300'


   %CONSTINTEGER AIS=X'2600', AHI=X'CA00', AH=X'4A00', AR=X'0A00'
   %CONSTINTEGER SIS=X'2700', SHI=X'CB00', SH=X'4B00', SR=X'0B00'
   %CONSTINTEGER AM  = X'5100'
   %CONSTINTEGER AHM = X'6100'

   %CONSTINTEGER C   = X'5900',  CH =X'4900', CI =X'F900', CR =X'0900'
   %CONSTINTEGER CL  = X'5500',  CLH=X'4500', CLI=X'F500', CLR=X'0500'
   %CONSTINTEGER                 CHI=X'C900'
   %CONSTINTEGER                CLHI=X'C500'
   %CONSTINTEGER CHVR = X'1200'




   %CONSTINTEGER TI  = X'F300', THI = X'C300'

   %CONSTINTEGER LBR = X'9300', LB  = X'D300', STB = X'D200'
   %CONSTINTEGER CLB = X'D400'

   %CONSTINTEGER SRA = X'EE00'

   %CONSTINTEGER BAL = X'4100'
   %CONSTINTEGER JUMP= 12
   %CONSTINTEGER BFCR= X'0300'

   %CONSTINTEGER SVC = X'E100'
   %CONSTINTEGER LME = X'7200', STME= X'7100'
   %CONSTINTEGER LER = X'2800'
   %CONSTINTEGER LE  = X'6800', STE = X'6000'
   %CONSTINTEGER CER = X'2900'
   %CONSTINTEGER CE  = X'6900'
   %CONSTINTEGER AER=X'2A00', SER=X'2B00', MER=X'2C00', DER=X'2D00'
   %CONSTINTEGER AE =X'6A00', SE =X'6B00', ME =X'6C00', DE =X'6D00'
   %CONSTINTEGER FXR = X'2E00', FLR = X'2F00'

!   FULLWORD OPCODES
   %CONSTINTEGER LW  = X'5800', ST = X'5000'
   %CONSTINTEGER LI  = X'F800'
   %CONSTINTEGER LA  = X'E600'

   %CONSTINTEGER SLLS= X'1100'
   %CONSTINTEGER SRLS= X'1000'
   %CONSTINTEGER SLL = X'ED00'
   %CONSTINTEGER SRL = X'EC00'

   %CONSTINTEGER AW  = X'5A00'
   %CONSTINTEGER SW  = X'5B00'
   %CONSTINTEGER AI  = X'FA00'
   %CONSTINTEGER SI  = X'FB00'

   %CONSTINTEGER MW  = X'5C00'
   %CONSTINTEGER MR  = X'1C00'
   %CONSTINTEGER DW  = X'5D00'
   %CONSTINTEGER DR  = X'1D00'

   %CONSTINTEGER OR=X'0600', OW=X'5600', OH=X'4600', OI=X'F600'
   %CONSTINTEGER XR=X'0700', XW=X'5700', XH=X'4700', XI=X'F700'
   %CONSTINTEGER NR=X'0400', NW=X'5400', NH=X'4400', NI=X'F400'
   %CONSTINTEGER OHI = X'C600', XHI = X'C700', NHI = X'C400'


   %RECORDFORMAT VARFM(%INTEGER DISP, %SHORTINTEGER FORMAT, EXTRA,  %C
                   ID, LENGTH,  %BYTEINTEGER BASE, TYPE, FORM, SIZE)
   %RECORDFORMAT  STACKFM(%INTEGER  DISP, FORMAT, EXTRA, LENGTH, DV,  %C
                          %SHORTINTEGER  BASE, LOP,TYPE, FORM,  %C
                        %RECORD(STACKFM)%NAME  LINK)
   %RECORDFORMAT SPTFM(%RECORD(STACKFM)%NAME V)
   %RECORDFORMAT LABELFM(%SHORTINTEGER ID, TAG, %C
                         %BYTEINTEGER REG, BASE, %C
                         %INTEGER LIMIT, DISP)
   %RECORDFORMAT USEFM(%INTEGER  DISP, CA, %C
                       %SHORTINTEGER BASE, %C
                       %BYTEINTEGER TYPE,FORM)
   %RECORDFORMAT ENVFM(%INTEGER LABEL, LIMEN, %C
                                 %RECORD(USEFM)%ARRAY E(1:40))

!  DATA ARRAYS

   %RECORD(USEFM)%ARRAY USE(1 : 44);! REGISTER USAGE
   %RECORD(USEFM) KNOWN
   %INTEGERARRAY ACTIVITY(0 : 44);! REGISTER ACTIVITY
   %RECORD(LABELFM)%ARRAY LABELS(1 : MAX LABELS)
   %RECORD(SPTFM)%ARRAY STACKED(1 : MAX DEPTH);! MAIN STACK
   %RECORD(STACKFM)%ARRAY STAK(0 : MAX STACK); ! STACK ELEMENTS
   %INTEGERARRAY USED(0:20)
   %RECORDFORMAT DFM(%RECORD(STACKFM)%NAME D, %RECORD(DFM)%NAME LINK)
   %RECORD(STACKFM)%NAME DESC ASL
   %RECORD(DFM)%ARRAY DLIST(0:MAX STACK)
   %RECORD(DFM)%NAME DASL
   %RECORD(DFM) USING

   %OWNBYTEINTEGERARRAY VBUF(1:10)
   %OWNINTEGER VP = 0
   %OWNINTEGER XLEVEL = 0
   %INTEGER BLOCK WORD
   %OWNRECORD(VARFM) BEGIN
   %RECORD(ENVFM) NULL ENV
   %constrecord(*)%name null == (0)      {   %OWNRECORD(STACKFM) NULL   }
   %RECORD(VARFM)%NAME DECVAR

   %OWNINTEGER CONTROL = B'11111111'; ! ALL CHECKS ENABLED INITIALLY
   %OWNINTEGER PERMS = LAST PERM
   %INTEGER DYNAMIC, DOPE
   %SHORTINTEGER HALF
   %INTEGER J
   %INTEGER CA;           !  CODE ADDRESS
   %INTEGER GA, DIAG GLA; !  GLA ADDRESS
   %INTEGER DA
   %INTEGER LINE SIZE
   %OWNINTEGER REALGA;   ! FRIG FOR OWNREALARRAY
   %INTEGER LIMEN;      !  BACKWARD EXTENT OF KNOWLEDGE
   %INTEGER CURRENT LINE
   %INTEGER ENVP;       !  LAST ENVIRONMENT USED (CIRCULAR)
   %INTEGER STP;        ! STACK POINTER
   %INTEGER STACK ASL;  ! STACK DESCRIPTOR POINTER
   %ownINTEGER FRAME = 0;      ! LOCAL STACK FRAME EXTENT
   %OWNINTEGER  MIN TEMP = 0
   %INTEGER PARMS;      ! START OF PARAMETER STACK
   %INTEGER LOCAL
   %INTEGER INVERT,SWOPPED;!  CONDITION INVERSION FLAG
   %INTEGER UNCOND JUMP;      !  ADDRESS OF CODE HOLE
   %RECORD(LABELFM)%NAME FLAB;    ! %FOR LABEL
   %INTEGER GTYPE,GMODE;      ! PARAMETER FLIP-FLOP
   %INTEGER OTYPE=0, OWNTYPE, OWNFORM, OWNVAL
   %INTEGER  FAULTY, ENTER UNASS

   %RECORD(STACKFM) ST WORK
   %RECORD(STACKFM) CCV
   %INTEGER CCREG, CCCA=-1;      !  CONDITION-CODE INFO

   %RECORD(STACKFM)%NAME ACTIVE STRING
   %BYTEINTEGERNAME CSLEN
   %BYTEINTEGERARRAY CURRENT STRING(0 : 255)

   %RECORD(ENVFM)%ARRAY ENVIR(0:MAX ENVIRS);! WELL AWAY FROM ALL

   %INTEGER  MAX VARS;  MAX VARS = FREE SPACE - INITIAL FREE
   %BEGIN
      MAX VARS = MAX VARS + INITIAL FREE//4 %IF MAX VARS <= 0
      MAX VARS = 16 %IF MAX VARS <= 0
      MAX VARS = MAX VARS>>4;  ! BYTE LENGTH OF 'VARFM'
!      SELECT OUTPUT(LIST)
!      PRINTSTRING("PASS 2 VERSION ");!  PRINTSTRING(P2VERSION)
!      WRITE(MAX VARS, 1);!  PRINTSTRING(" VARS");!  NEWLINE
   %END

   %RECORD(VARFM)%ARRAY  VAR(1:MAX VARS)


%ROUTINESPEC  RX(%INTEGER  OP, R, X, D)


%ROUTINE PHEX(%INTEGER N)
   %INTEGER J,K
   %CYCLE J = 1,1,4
      K = (N>>12)&15;  N = N<<4
      %IF K > 9 %THEN K = K-10+'A' %ELSE K = K+'0'
      PRINTSYMBOL(K)
   %REPEAT
%END

%ROUTINE DECODE(%INTEGER WORD)
   %OWNINTEGER LAST,N
   SELECTOUTPUT(LIST)
   %IF LAST # CURRENT LINE %START
      LAST = CURRENT LINE
      NEWLINE %UNLESS N = 0
      N = 16
      WRITE(CURRENT LINE, 4);  SPACE
      PHEX(CA);  PRINTSYMBOL(':')
   %ELSE
      SPACES(11) %IF N = 16
   %FINISH
   SPACES(2);  PHEX(WORD)
   N = N-1
   N = 16 %AND NEWLINE %IF N <= 0
   SELECTOUTPUT(OBJECT)
%END
   %ROUTINE SHOW(%RECORD(STACKFM)%NAME V)
      SELECTOUTPUT(REPORT) %IF CONTROL < 0
      WRITE(V_TYPE, 1);  WRITE(V_FORM, 2)
      WRITE(V_BASE, 2);  WRITE(V_DISP, 5)
      WRITE(V_EXTRA, 5);  WRITE(V_LENGTH, 5)
      %IF V_LOP # 0 %START
         WRITE(V_LOP, 2);  PRINTSYMBOL(':')
         SHOW(V_LINK)
      %ELSE
         NEWLINE
      %FINISH
      SELECTOUTPUT(OBJECT) %IF CONTROL < 0
   %END
   %ROUTINE ABORT(%INTEGER CODE)
      %INTEGER I,J,L,FATAL
      %SWITCH SW(-15:0)
      %RECORD(DFM)%NAME DD
      I = REPORT;  FATAL = 1
      CONTROL = 0
      %CYCLE
         SELECT OUTPUT(I)
         %IF CODE > 0 %START;      ! ... IT'S A COMPILER FAULT
            PRINT STRING("*COMPILER ERROR"); WRITE(CODE,1)
            PRINT STRING(" AT LINE");  WRITE(CURRENT LINE,1)
            NEWLINE
            %IF STP > 0 %START
               PRINT STRING("STACK"); NEWLINE
               SHOW(STACKED(J)_V) %FOR J = 1,1,STP
            %FINISH
            %UNLESS USING_LINK == NULL %START
               PRINTSTRING("USING:");  NEWLINE
               DD == USING_LINK
               %CYCLE
                  SHOW(DD_D);  DD == DD_LINK
                  %EXIT %IF DD == NULL
               %REPEAT
            %FINISH
            ->CONT %IF I = REPORT
            %SIGNAL 15,1;            ! ... SIGNAL COMPILER FAULT
         %FINISH
         PRINT SYMBOL('*');  WRITE(CURRENT LINE,1);  PRINT STRING(": ")
         -> SW(CODE)

SW(0):
   PRINT STRING("MORE STORE PLEASE!!");  -> CONT
SW(-1):
SW(-2):
   PRINT STRING("MORE STORE REQ'D FOR THIS COMPILATION");  -> CONT
SW(-3):
   PRINT STRING("BLOCKS TOO DEEPLY NESTED");  -> CONT
SW(-4):
   PRINT STRING("TOO MANY NAMES");  -> CONT
SW(-5):
   PRINT STRING("TOO MANY LABELS");  -> CONT
SW(-6):
   PRINT STRING("DIVISION BY ZERO");  -> NON FATAL
SW(-7):
SW(-8):
   PRINT STRING("ARRAY INSIDE OUT");  -> NON FATAL
SW(-9):
   PRINT STRING("DECLARATION OUT OF CONTEXT");  -> NON FATAL
SW(-10):
   PRINT STRING("FAULTY SWITCH DECLARATION");  -> NON FATAL
SW(-11):
   PRINT STRING("%RESULT UNSPECIFIED");  -> NON FATAL
SW(-12):
   PRINT STRING("ILLEGAL %FOR PARAMETERS");  ->WARNING
SW(-13):
   PRINTSTRING("STRING CONSTANT TOO LONG");  ->WARNING
SW(-14):
   PRINTSTRING("UNASSIGNED CHECK INHIBITED")
   CONTROL = CONTROL&(\UNASS DIAG);  ->WARNING
SW(-15):
   PRINTSTRING("LOCALS > 16K ???")

WARNING:
      L = 0

NON FATAL:
      FATAL = 0
CONT:
      NEWLINE
      %IF I = LIST %START
         %SIGNAL 15,2 %IF FATAL # 0
         FAULTY = FAULTY+L;  SELECT OUTPUT(OBJECT); %RETURN
      %FINISH
      I = LIST

      %REPEAT
   %END
   %ROUTINE DISPLAY VAR(%RECORD(VARFM)%NAME V)
      SELECTOUTPUT(LIST)
      WRITE(V_ID, 3);  PRINTSYMBOL(':')
      WRITE(V_TYPE, 2);  WRITE(V_FORM, 2)
      WRITE(V_BASE, 3);  WRITE(V_DISP, 4)
      WRITE(V_EXTRA, 4);  WRITE(V_FORMAT, 4)
      NEWLINE
      SELECTOUTPUT(OBJECT)
   %END
   %ROUTINE REAL ERROR(%INTEGER N)
      %INTEGER I
      %CONSTSHORTINTEGERARRAY SYM(1:14) = '\', '?', '?', '?', '@',
                                          '?', '?', '&', '!',-'!',
                                         -'<', -'>', '?', '.'
      I = REPORT
      %CYCLE
         SELECT OUTPUT(I)
         PRINTSYMBOL('*');  WRITE(CURRENT LINE, 4)
         PRINTSTRING(" ILLEGAL REAL OPERATION '")
         N = SYM(N)
         PRINTSYMBOL(-N) %IF N < 0
         PRINTSYMBOL(|N|);  PRINTSYMBOL('''');  NEWLINE
         %EXIT %IF I = LIST
         I = LIST
      %REPEAT
      FAULTY = FAULTY+1
      SELECTOUTPUT(OBJECT)
   %END
   %PREDICATE FLOATING(%RECORD(STACKFM)%NAME V)
      %TRUE %IF V_TYPE = REALS %OR (V_LOP # 0    %C
             %AND (V_LOP = RDIV %OR (v_link ## NULL %and V_LINK_TYPE = REALS)))
      %FALSE
   %END
   %PREDICATE SAME(%RECORD(STACKFM)%NAME L, R)
      %FALSE %IF L_BASE # R_BASE %OR L_DISP # R_DISP
      %FALSE %IF L_TYPE # R_TYPE %OR L_FORM # R_FORM
      %FALSE %IF L_EXTRA # R_EXTRA
      %TRUE
   %END
   %PREDICATE ZERO(%RECORD(STACKFM)%NAME V)
      %FALSE %IF V_DISP # 0 %OR V_BASE # 0 %OR V_FORM # CONSTANT
      %FALSE %IF V_LOP # 0
      %TRUE
   %END
   %PREDICATE CONST(%RECORD(STACKFM)%NAME V)
      %FALSE %UNLESS V_FORM = CONSTANT %AND V_LOP = 0
      %FALSE %IF V_TYPE > SHORT
      %TRUE
   %END
   %INTEGERFN POWER(%INTEGER N)
      %INTEGER MASK, J
      MASK = 1
      %FOR J = 0, 1, 14 %CYCLE
         %RESULT = J %IF N = MASK
         MASK = MASK<<1
      %REPEAT
      %RESULT = -1
   %END
   %INTEGERFN TEMP
      %INTEGER T
      T = (FRAME+(REGLEN-1))&(\(REGLEN-1))
      FRAME = T+REGLEN
      %RESULT = T
   %END
   %INTEGERFN TAG
      %INTEGER N, S
      N = 0
      %CYCLE
         S = NEXTSYMBOL
         %RESULT = N %UNLESS '0' <= S <= '9'
         N = N*10+S-'0'
         SKIPSYMBOL
      %REPEAT
   %END
   %INTEGERFN EVAL(%INTEGER L)
      %INTEGER J, N, B, S, MOD
      %CONSTBYTEINTEGERARRAY BASIS('V' : 'Z') = 3, 1, 8, 4, 0
      %RESULT = 0 %IF L < 2
      READSYMBOL(B);  B = BASIS(B)
      N = 0
      %IF B = 0 %START
         %FOR J = 2,1,L %CYCLE
            READ SYMBOL(S)
            N = (N*4+N)*2 + S-'A'
         %REPEAT
      %ELSE
         MOD = 'A';  MOD = 0 %IF B = 8
         %FOR J = 2,1,L %CYCLE
            READ SYMBOL(S)
            N = N<<B + (S-MOD)
         %REPEAT
      %FINISH
      %RESULT = N
   %END
   %REALFN  REAL CONSTANT
   %INTEGER  I,L,S,J,M
   %REAL  N,FACTOR,TEN,ONE
      I = 10;  TEN = I;   ! ...TO PREVENT COMPILE-TIME FLOATING
      I = 1;  ONE = I;   ! ... AND AGAIN
      M = 0;  N = 0;  L = TAG;  SKIP SYMBOL
      %CYCLE  J = 1,1,L
         READ SYMBOL(S)
         %IF S = '.' %START
            FACTOR = 1;  M = 1
         %ELSE
            I = S-'A'
            %IF M = 0 %START
               N = N*TEN + I
            %ELSE
               FACTOR = FACTOR/TEN
               N = N + I*FACTOR
            %FINISH
         %FINISH
      %REPEAT
      %RESULT = N
   %END
   %ROUTINE RELEASE(%INTEGER REG)
      %RETURN %IF REG = 0 %OR ACTIVITY(REG) < 0;!  LOCKED
      ACTIVITY(REG) = ACTIVITY(REG)-1
      ABORT(1) %IF ACTIVITY(REG) < 0
   %END
   %ROUTINE CLAIM(%INTEGER REG)
      %RETURN %IF REG = 0 %OR ACTIVITY(REG) < 0
      USED(REG) = CA
      ACTIVITY(REG) = ACTIVITY(REG)+1
   %END
   %ROUTINE FORGET(%INTEGER REG)
      USE(REG)_CA = LIMEN;  USE(REG+STORE)_CA = LIMEN
   %END
   %ROUTINE FORGET DEST(%RECORD(STACKFM)%NAME V)
      %CONSTBYTEINTEGERARRAY BITS(0:7) = 15,15,8,12,12,12,15,15
      %INTEGER R, MASK, ADDR, TYPE
      %RECORD(USEFM)%NAME U

      ADDR = V_DISP!3;  MASK = BITS(V_TYPE)>>(V_DISP&3)

      %FOR R = 1, 1, 40 %CYCLE
         U == USE(R)
         %IF U_CA > LIMEN %START
            %IF U_BASE&255 = V_BASE %AND U_FORM # A V IN S %START
               %IF U_DISP!3 = ADDR %START
                  TYPE = U_TYPE
                  TYPE = 7 %IF U_FORM&128 # 0
                  type = 0 %if type = 255      {unsigned halfword}
                  %IF BITS(TYPE)>>(U_DISP&3) & MASK # 0 %START
                     U_CA = LIMEN;        ! FORGET IT
                  %FINISH
               %FINISH
            %FINISH
         %FINISH
      %REPEAT
   %END
   %ROUTINE HAZARD(%INTEGER REG)
      %RECORD(DFM)%NAME P
      %INTEGER N, T, OP
      %ROUTINE MOD(%RECORD(STACKFM)%NAME V)
         %SWITCH S(0:7)
               N = N-1
               ->S(V_FORM)
S(CONSTANT):
S(A IN REC):
S(V IN REC):
S(AV IN REC):  ABORT(3)
S(A IN S):     V_FORM = A IN REC;  V_EXTRA = T;  ->DONE
S(AV IN S):    V_FORM = AV IN REC;  V_EXTRA = T;  ->DONE
S(V IN S):     V_FORM = V IN REC;  V_EXTRA = T;  ->DONE
S(V IN R):     V_FORM = V IN S;  V_DISP = T
DONE:          V_BASE = LOCAL
      %END
      N = ACTIVITY(REG)
      %RETURN %IF N <= 0
      ACTIVITY(REG) = 0
      T = TEMP
      %IF FPR0 <= REG <= FPR14 %THEN OP = STE %ELSE OP = ST
      RX(OP, REG, LOCAL, T)
      P == USING_LINK
      %CYCLE
         %EXIT %IF P == NULL
         MOD(P_D) %IF P_D_BASE = REG
         P == P_LINK
      %REPEAT
      ABORT(4) %IF N # 0
   %END
   %ROUTINE HAZARD ALL
      %INTEGER J
      HAZARD(J) %FOR J = 1, 1, 20
   %END
   %ROUTINE REMEMBER(%INTEGER REG, %RECORD(STACKFM)%NAME V)
      %RECORD(USEFM)%NAME U
      REMEMBER(REG+STORE,V) %IF REG <= STORE
      U == USE(REG)
      U_BASE = V_BASE
      U_DISP = V_DISP
      U_TYPE = V_TYPE
      U_FORM = V_FORM
      U_CA   = CA
      %IF CONTROL < 0 %START
         SELECTOUTPUT(LIST)
         PRINTSTRING(" REMEMBER:")
         WRITE(U_TYPE, 1);  WRITE(U_FORM, 1);  WRITE(U_BASE, 3)
         WRITE(U_DISP,5)
         NEWLINE
         SELECTOUTPUT(OBJECT)
      %FINISH
   %END
   %INTEGERFN FIND USE(%INTEGER TYPE, FORM, BASE, DISP)
      %RECORD(USEFM)%NAME U
      %INTEGER J, B, BB, BCA, BBCA
      B = BASE&255;  BB = BASE>>8
      %IF ACTIVITY(B) < 0 %THEN BCA = LIMEN+1 %ELSE BCA = USE(B)_CA
      %IF ACTIVITY(BB)< 0 %THEN BBCA= LIMEN+1 %ELSE BBCA= USE(BB)_CA
      %RESULT = 0 %IF BCA <= LIMEN %OR BBCA <= LIMEN
      %FOR J = 1, 1, 40 %CYCLE
         U == USE(J)
         %IF BCA < U_CA %AND BBCA < U_CA %START
            %IF U_BASE = BASE  %AND U_DISP = DISP %START
               %IF U_TYPE = TYPE %AND U_FORM = FORM %START
                  %IF J > STORE %START
                     J = J-STORE
                     USE(J) = U %IF USE(J)_CA <= LIMEN
                  %FINISH
                  CLAIM(J)
                  RELEASE(B);  RELEASE(BB)
                  %RESULT = J
               %FINISH
            %FINISH
         %FINISH
      %REPEAT
      %RESULT = 0
   %END
   %INTEGERFN GPR(%INTEGER ADDR)
      %RECORD(USEFM)%NAME UR, US
      %INTEGER R, BESTR, BESTCA, BOOTR, BOOTCA, REG, MAXCA
      %CONSTBYTEINTEGERARRAY PREF(0:11) =
                  P1, R11, R9, P2,
                  R10, R12, R4, R3, R1, R2, LINK, R0

      BESTR = -1;  BOOTR = -1
      BESTCA = CA;  BOOTCA = CA

      %CYCLE R = 0, 1, 11-ADDR
         REG = PREF(R)
         %IF ACTIVITY(REG) = 0 %START;! FREE
            UR == USE(REG);  US == USE(REG+STORE)
            MAXCA = UR_CA
            MAXCA = US_CA %IF US_CA > MAXCA
            %RESULT = REG %IF MAXCA <= LIMEN;! NOT KNOWN
            %IF MAXCA < BESTCA %START
               BESTCA = MAXCA;  BESTR = REG
            %FINISH
         %ELSE %IF 0 < ACTIVITY(REG) < 2 %AND USED(REG) < BOOTCA
            BOOTR = REG;  BOOTCA = USED(REG)
         %FINISH
      %REPEAT
      %RESULT = BESTR %IF BESTR >= 0
      !  NONE FREE SO BOOT ONE OUT
      BOOTR = R1 %IF BOOTR < 0;! NONE BETTER
      HAZARD(BOOTR);  USED(BOOTR) = CA
      %RESULT = BOOTR
   %END
   %INTEGERFN EVEN ODD PAIR
      %CONSTBYTEINTEGERARRAY PAIRS(1:5) = R0, R10, R2, R4, LINK
      %CONSTBYTEINTEGERARRAY NEXT(1:5)  = R1, R11, R3, P2, R9
      %INTEGER J, BEST, BESTCA, MAX, HELP, REG, NREG
      %RECORD(USEFM)%NAME U1, U2
      BEST = 0;  BESTCA = CA;  HELP = 0
      %CYCLE J = 1, 1, 5
         REG = PAIRS(J);  NREG = NEXT(J)
         U1 == USE(REG);  U2 == USE(NREG)
         %IF ACTIVITY(REG) = 0 %START
            %IF ACTIVITY(NREG) = 0 %START
               MAX = U1_CA
               MAX = U2_CA %IF U2_CA > MAX
               %IF MAX < BESTCA %START
                  BESTCA = MAX;  BEST = J
               %FINISH
            %ELSE
               HELP = J
            %FINISH
         %ELSE
            HELP = J %IF ACTIVITY(NREG) = 0
         %FINISH
      %REPEAT
      %RESULT = NEXT(BEST) %IF BEST # 0
      HELP = 2 %IF HELP = 0
      REG = PAIRS(HELP);  NREG = NEXT(HELP)
      HAZARD(REG);  HAZARD(NREG)
      %RESULT = NREG
   %END
   %INTEGERFN FPR
      %RECORD(USEFM)%NAME UR, US
      %INTEGER R, BESTR, BESTCA, BOOTR, BOOTCA, MAXCA, BOOTA
      BESTR = -1;  BESTCA = CA
      BOOTR = -1;  BOOTCA = CA;  BOOTA = CA
      %CYCLE R = FPR0, 1, FPR14
         UR == USE(R);  US == USE(R+STORE)
         %IF ACTIVITY(R) = 0 %START
            MAXCA = UR_CA;  MAXCA = US_CA %IF US_CA > MAXCA
            %RESULT = R %IF MAXCA <= LIMEN
            %IF MAXCA < BESTCA %START
               BESTR = R;  BESTCA = MAXCA
            %FINISH
         %ELSE %IF 0 < ACTIVITY(R) < 2 %AND USED(R) < BOOTCA
            BOOTCA = USED(R);  BOOTR = R
         %FINISH
      %REPEAT
      %RESULT = BESTR %UNLESS BESTR < 0
      BOOTR = FPR0 %IF BOOTR < 0
      HAZARD(BOOTR)
      %RESULT = BOOTR
   %END
   %ROUTINE CHECK RELEASED
      %INTEGER J
      %FOR J = 1, 1, 20 %CYCLE
         ABORT(2) %IF ACTIVITY(J) > 0
      %REPEAT
   %END


! OBJECT FILE HANDLING ROUTINES

   %ROUTINE COUNT DIAGS
      %OWNINTEGER HERE = 0
      LINE SIZE = LINE SIZE+4 %IF HERE # CURRENT LINE
      HERE = CURRENT LINE
   %END

   %ROUTINE  PUT(%SHORTINTEGER  N)
      PRINT SYMBOL(N>>8);  PRINT SYMBOL(N&255)
   %END
   %ROUTINE  DUMP(%SHORTINTEGER  N)
      PRINT SYMBOL(LOAD CODE);  PUT(N)
      DECODE(N) %IF CONTROL < 0
      CA = CA+2
   %END
   %ROUTINE  GHALF(%SHORTINTEGER  N)
      PRINT SYMBOL(LOAD GLA);  PUT(N)
      GA = GA+2
   %END
   %ROUTINE  GWORD(%INTEGER  N)
      GHALF(N>>16);  GHALF(N&X'FFFF')
   %END
   %ROUTINE  GBYTE(%SHORTINTEGER  N)
   %OWNINTEGER  V=0, F=0
      F = \F
      %IF F=0 %START
         PRINT SYMBOL(LOAD GLA);  PUT(V<<8+N)
      %ELSE
         V = N
      %finish
      GA = GA+1
   %END
   %ROUTINE  PATCH(%INTEGER  WHAT, WHERE)
      SELECT OUTPUT(DIRECT)
      PRINT SYMBOL(PATCH CODE);  PUT(WHAT);  PUT(WHERE)
      SELECT OUTPUT(OBJECT)
   %END
   %ROUTINE  GPATCH(%INTEGER  WHAT, WHERE)
      SELECT OUTPUT(DIRECT)
      PRINT SYMBOL(PATCH GLA);  PUT(WHAT);  PUT(WHERE)
      SELECT OUTPUT(OBJECT)
   %END
   %ROUTINE  GFIX(%INTEGER  ALIGNMENT)
      GBYTE(0) %WHILE GA&(ALIGNMENT-1) # 0
   %END
   %ROUTINE  SF(%SHORTINTEGER OP, R, L)
      DUMP(OP + ACTUAL(R)<<4 + L)
   %END
   %ROUTINE  RR(%SHORTINTEGER  OP, R1, R2)
      DUMP(OP + ACTUAL(R1)<<4 + ACTUAL(R2))
      RELEASE(R2)
   %END
   %ROUTINE  RX(%INTEGER  OP, R, X, D)
      ABORT(5) %IF X=R0 %OR D<0 %OR D>X'3FFF'
      RELEASE(X)
      DUMP(OP + ACTUAL(R)<<4 + ACTUAL(X));  DUMP(D)
      COUNT DIAGS %IF OP = BAL
      %IF CONTROL&UNASS DIAG # 0 %START
         %RETURN %IF OP # LW %AND OP # LE
         %RETURN %IF X = LOCAL %AND D >= MIN TEMP
         %IF OP = LW %THEN OP = CL %ELSE OP = CE
         DUMP(OP+ACTUAL(R)<<4+ACTUAL(CODE))
         DUMP(UNASS PAT)
         PRINTSYMBOL(DLINE);          ! INFORM DIAGS OF 'BALR'
         DUMP(ENTER UNASS)
         COUNT DIAGS
      %FINISH
   %END
   %ROUTINE  RI2(%INTEGER  OP, R, X, D)
      ABORT(5) %IF X=R0
      RELEASE(X)
      DUMP(OP + ACTUAL(R)<<4 + ACTUAL(X));  DUMP(D)
      COUNT DIAGS %IF OP = BAL;     ! IF PERM REFERENCE
   %END
   %ROUTINE  RI3(%INTEGER  OP, R, X, D)
      ABORT(5) %IF X=R0
      RELEASE(X)
      DUMP(OP + ACTUAL(R)<<4 + ACTUAL(X)); DUMP(D>>16); DUMP(D&X'FFFF')
   %END
   %ROUTINE  DEFINE TAG(%SHORTINTEGER  REF)
      SELECT OUTPUT(DIRECT)
      PRINT SYMBOL(TAG DEF);  PUT(REF);  PUT(CA)
      SELECT OUTPUT(OBJECT)
   %END
   %ROUTINE  DEFINE REFERENCE(%INTEGER  REF, TYPE)
      SELECT OUTPUT(DIRECT)
      PRINT SYMBOL(TYPE);  PUT(REF);  PUT(CA)
      SELECT OUTPUT(OBJECT)
   %END
   %ROUTINE  SET LINE
   %OWNINTEGER  HERE = 0
      CURRENT LINE = TAG
      %WHILE CURRENT LINE > HERE %CYCLE
         HERE = HERE+1;  PRINT SYMBOL(LINE FLAG)
      %REPEAT
   %END

! ENVIRONMENT CONTROL

   %RECORD(ENVFM)%MAP ENVIRONMENT(%SHORTINTEGER LABEL)
      %INTEGER J
      %RECORD(ENVFM)%NAME E
      %RESULT == NULL ENV %IF LABEL <= 0
      %FOR J = MAX ENVIRS, -1, 0 %CYCLE
         E == ENVIR(J)
         %RESULT == E %IF E_LABEL = LABEL
      %REPEAT
      %RESULT == NULL ENV
   %END
   %ROUTINE REMEMBER ENVIRONMENT(%SHORTINTEGER LABEL)
      %INTEGER K
      %RECORD(ENVFM)%NAME E
      %RETURN %IF LABEL <= 0
      E == ENVIRONMENT(LABEL)
      E_LABEL = 0
      ENVP = ENVP+1;  ENVP = 0 %IF ENVP > MAX ENVIRS
      E == ENVIR(ENVP)
      E_LABEL = LABEL
      E_LIMEN = LIMEN
      E_E(K) = USE(K) %FOR K = 1, 1, 40
   %END
   %ROUTINE MERGE ENVIRONMENT(%SHORTINTEGER LABEL)
      %INTEGER J
      %RECORD(ENVFM)%NAME E
      %RECORD(USEFM)%NAME U, V
      E == ENVIRONMENT(LABEL)
      %UNLESS E == NULL ENV %START
         %FOR J = 1, 1, 40 %CYCLE
            U == USE(J)
            V == E_E(J)
            V_CA = E_LIMEN %UNLESS U_BASE = V_BASE %C
                              %AND U_DISP = V_DISP %C
                              %AND U_FORM = V_FORM %C
                              %AND U_TYPE = V_TYPE %C
                              %AND U_CA   > LIMEN
         %REPEAT
      %FINISH
   %END
   %ROUTINE RESTORE ENVIRONMENT(%SHORTINTEGER LABEL)
      %INTEGER J
      %RECORD(ENVFM)%NAME E
      E == ENVIRONMENT(LABEL)
      %IF E == NULL ENV %START
         LIMEN = CA
      %ELSE
         E_LABEL = 0
         LIMEN = E_LIMEN
         USE(J) = E_E(J) %FOR J = 1, 1, 40
      %FINISH
   %END

   %ROUTINE PERM(%INTEGER N)
      %INTEGER MASK, J, R
      %CONSTBYTEINTEGERARRAY REG(1:15) =
         R0, R1, R2, R3, R4, P2, P1, FPR0, FPR2,15,16,17,18,19,20
      MASK = X'80'
      N = N!X'FFFF0000'
      %CYCLE J = 1, 1, 15
         MASK = MASK<<1
         %IF N&MASK # 0 %START
            R = REG(J)
            HAZARD(R);  FORGET(R)
         %FINISH
      %REPEAT
      HAZARD(LINK);  FORGET(LINK)
      DEFINE REFERENCE(N&255, P REF)
      RI2(BAL, LINK, CODE, N&255)
   %END
   %ROUTINE SET DIAG(%INTEGER BASE, DISP, TYPE, FORM)
      !! PROC<1><1>LEVEL<3>NAME<1>BASE<3>TYPE<3>DISP<20>
      %INTEGER V1, V2, P, MARK
      %ROUTINE FILL(%INTEGERNAME V)
         %INTEGER SHIFT
         SHIFT = 0;  V = 0
         %CYCLE
            %RETURN %IF P = VP %OR SHIFT = 30
            P = P+1
            V = V+(VBUF(P)-32)<<SHIFT
            SHIFT = SHIFT+6
         %REPEAT
      %END
      P = 0;  MARK = 0
      FILL(V1);  FILL(V2)
      %IF FORM = 0 %START;          ! NON-VARIABLE
         PRINT SYMBOL(DLINE)
         MARK = 16;  FORM = 1
         %IF BASE = 0 %START;       ! %BEGIN
            V2 = 0;  V1 = BLOCK WORD;! 'BLOCK'
         %FINISH
      %FINISH
      BASE = ACTUAL(BASE)
      BASE = BASE-8 %IF BASE >= 8
      PRINTSYMBOL(DIAGS)
      %IF FORM = -1 %START;                ! END OF BLOCK
         PUT(-1);  PUT(-1);  DA = DA+4;  %RETURN
      %FINISH
      PUT(((((MARK+XLEVEL)<<1+FORM-1)<<3+BASE)<<3+TYPE)<<4)
      PUT(DISP)
      PUT(V1>>16);  PUT(V1&X'FFFF')
      PUT(V2>>16);  PUT(V2&X'FFFF')
      DA = DA+12
   %END
   %ROUTINE ASSEMBLE(%SHORTINTEGER AMODE, LABS, NAMES)
      %OWNINTEGER ASS LEVEL = 0
      %SWITCH Z(33:126)
      %RECORD(VARFM)%NAME V, GVAR, FP, AP
      %RECORD(STACKFM)%NAME LHS, RHS, X
      %INTEGER SYM;            ! CURRENT CODE ITEM
      %INTEGER VLB, VUB
      %INTEGER DATA SIZE, OLD FRAME, GSTART, WDISP, NEW DISP, SDISP
      %INTEGER OPR, N
      %INTEGER SIZE PATCH, WARNING
      %OWNINTEGER GG = 0
      %INTEGER J,K, LEN, VAL, APARM, SPS
      %INTEGER LABEL START;! FIRST LABEL FOR THIS LEVEL
      %INTEGER RT LAB;     ! ROUTINE JUMP ADDRESS

      %CONSTBYTEINTEGERARRAY COMM(1:17)= 0, 0, 1, 0, 1, 1, 0,
                                         1, 1, 1, 0, 0, 0, 0, 1, 0, 0

   %ROUTINESPEC AMAP(%RECORD(STACKFM)%NAME V)
   %ROUTINESPEC LOAD(%RECORD(STACKFM)%NAME V, %INTEGER REG)
   %INTEGERFNSPEC NEW TAG
   %ROUTINESPEC JOIN(%RECORD(STACKFM)%NAME W)
   %ROUTINESPEC OPERATE(%INTEGER N)
   %ROUTINESPEC COMPARE(%RECORD(STACKFM)%NAME L, R)
   %ROUTINESPEC HEADER(%RECORD(VARFM)%NAME V)

   ABORT(-1) %IF FREE SPACE < MIN FREE;  !  ...STACK OVERFLOW?

   XLEVEL = XLEVEL+1
   RT LAB = 0;  LABEL START = LABS; OLD FRAME = FRAME
   WDISP = 0;  WARNING = 0
   GVAR == DECVAR;  GSTART = NAMES
   %IF AMODE > 0 %START
      %IF AMODE = 1 %THEN FRAME = REGLEN %ELSE FRAME = 11*REGLEN
      ABORT(-3) %IF ASS LEVEL = 5
      ASS LEVEL = ASS LEVEL+1;  LOCAL = BASE REG(ASS LEVEL)
      ACTIVITY(LOCAL) = -1
      %IF AMODE = 2 %START
         SET DIAG(R15, 0, 0, 0)
      %FINISH
      %IF OTYPE = PERMRT %START
         PERMS = PERMS-1;  GVAR_DISP = PERMS
      %FINISH
      SET DIAG(LOCAL, 0, 0, 0) %IF GG = PROCEDURE
   %ELSE %IF AMODE < 0
      FRAME = 0
   %ELSE
      SET DIAG(0, 0, 0 ,0);      ! BLOCK
   %FINISH

   ! DESCRIPTOR PROCESSING

   %INTEGERFN LOOKUP(%INTEGER NAME)
      %INTEGER P, P1, P2
      %RECORD(VARFM)%NAME V
      P1 = 1;  P2 = NAMES
      %WHILE P2 >= P1 %CYCLE
         P = (P1+P2)>>1
         V == VAR(P)
         %RESULT = P %IF V_ID = NAME
         %IF V_ID > NAME %THEN P2 = P-1 %ELSE P1 = P+1
      %REPEAT
      ABORT(6)
      %STOP
   %END
   %ROUTINE DEFINE VAR
      %CONSTBYTEINTEGERARRAY VSIZE(0:7) = 0, 4, 1, 2, 0, 4, 4, 0
      %CONSTBYTEINTEGERARRAY ROUND(0:7) = 3,3,0,1,1,3,3,3
      %INTEGER TYPE, FORM, TF, F, SIZE, FORMAT, S
      %OWNINTEGER PERM NO = -1

      NAMES = NAMES+1;  ABORT(-4) %IF NAMES >= PARMS
      DECVAR == VAR(NAMES);  DECVAR = 0
      DECVAR_ID = TAG
      VP = 0
      %CYCLE
         READSYMBOL(S);  %EXIT %IF S = COMMA
         %IF VP # 10 %START
            VP = VP+1;  VBUF(VP) = S
         %FINISH
      %REPEAT

      TF = TAG;  TYPE = TF>>4;  FORM = TF&15;  SKIPSYMBOL
      %IF TYPE = LONG %START
         TYPE = REALS
      %FINISH
      SIZE = TAG
      DECVAR_TYPE = TYPE
      DECVAR_FORM = FORM
      SKIPSYMBOL
      OTYPE = TAG
      %IF NEXTSYMBOL = COMMA %START
         SKIPSYMBOL
         FORMAT = TAG;  F = LOOKUP(FORMAT)
         DECVAR_FORMAT = F;  SIZE = VAR(F)_LENGTH;! IN BYTES
         DECVAR_LENGTH = SIZE
      %ELSE %IF TYPE = STRING
         DECVAR_SIZE = SIZE
         SIZE = SIZE+1
         SIZE = (SIZE+1)&(\1) %IF FORM = ARRAY
      %ELSE
         SIZE = VSIZE(TYPE)
      %FINISH
      %IF 7 <= FORM <= 10 %START;! PROCEDURE
         GTYPE = 1
         F = LOOKUP(DECVAR_ID)
         %IF F # NAMES %START;! SPEC GIVEN
            NAMES = NAMES-1;  DECVAR == VAR(F);  %RETURN
         %FINISH
         %IF OTYPE # 0 %AND OTYPE # 7 %START;! TREAT AS INTRINSIC
            PERMNO = PERMNO+1
            DECVAR_DISP = PERMNO;  DECVAR_BASE = LINK
            %RETURN
         %FINISH
         DECVAR_DISP = NEW TAG!X'4000'
         DECVAR_BASE = CODE
         DECVAR_TYPE=INTEGER %IF FORM=8 %AND (TYPE=BYTE %OR TYPE=SHORT)
         %RETURN %UNLESS AMODE = 1 %AND GMODE # 0;! PARAMETER
         OTYPE = 0;  TYPE = 0;  FORM = 1;  SIZE = 2*REGLEN
      %FINISH

      DATA SIZE = SIZE
      DECVAR_LENGTH = DATA SIZE

      %IF FORM # 1 %START
         %IF TYPE = 0 %START
            TYPE = 10;  SIZE = 2*REGLEN;  DECVAR_TYPE = 10
         %ELSE %IF FORM = ARRAYNAME
            SIZE = 2*REGLEN;  DECVAR_EXTRA = -1
         %ELSE %IF FORM = ARRAY
            SIZE = 0
         %ELSE
            SIZE = REGLEN
         %FINISH
      %FINISH
      %IF OTYPE # 0 %START;! OWN DATA
         %IF OTYPE = CON %START;! CONSTINTEGER ETC.
            DATA SIZE = 0 %IF TF = X'41';! CONSTSTRING
            OTYPE = 0 %IF (TYPE<=SHORT %AND (FORM<=2 %OR FORM = 5)) %C
                      %OR TF = X'52' %OR FORM = ARRAYNAME
         %FINISH
         OWNTYPE = TYPE;  OWNFORM = FORM
         %IF FORM = ARRAY %START
            GFIX(4)
            DECVAR_EXTRA=GA;  GWORD(VLB);  GWORD(VUB);  GWORD(DATASIZE)
            DECVAR_BASE = GLA;  DECVAR_DISP = GA-VLB*DATASIZE
         %ELSE
            OWNTYPE = INTEGER %AND DATA SIZE = REGLEN %IF FORM # 1
            %IF OTYPE # 0 %START
               %IF TF # X'21' %START
                  %IF TF = X'31' %OR TF = X'41' %THEN GFIX(2) %C
                                                %ELSE GFIX(4)
               %FINISH
               %IF OWNFORM <= 2 %AND TYPE # RECORD %START
                  SET DIAG(GLA, GA+DIAG GLA, TYPE, FORM)
                  DIAG GLA = DIAG GLA+DATA SIZE
               %FINISH
            %FINISH
         %FINISH
         %RETURN
      %FINISH

      %IF FORM = SWITCH %START
         GFIX(2)
         DECVAR_BASE = GLA;  DECVAR_DISP = GA
         GHALF(VLB);  GHALF(VUB)
         DECVAR_EXTRA = GA-VLB*2
         GHALF(0) %FOR F = VLB, 1, VUB
         %RETURN
      %FINISH

      %IF FORM = 4 %START
         GTYPE = -1;  %RETURN
      %FINISH

      %IF FORM = 1 %THEN F = ROUND(TYPE) %ELSE F = REGLEN-1
      FRAME = (FRAME+F)&(\F)
      %IF FRAME <= REGLEN %START;!  SPECIAL PARAMETER ?
         %IF AMODE = 1 %AND GMODE # 0 %START;!  IN FP LIST
            %IF (FORM = 2 %AND TYPE # 10) %OR TF = X'11' %C
                                          %OR TF = X'31' %START;! TO A REG
               DECVAR_BASE = PARAM;  DECVAR_DISP = FRAME
               DECVAR_DISP = DECVAR_DISP+(REGLEN-2) %IF TF = X'31'
               FRAME = FRAME-REGLEN;  FRAME = 11*REGLEN %IF FRAME < 0
               -> DECD;   ! ...GO DUMP DIAG. ENTRY
            %FINISH
         %FINISH
         FRAME = 11*REGLEN %IF AMODE >= 0
      %FINISH
      DECVAR_BASE = LOCAL;  DECVAR_DISP = FRAME
      FRAME = FRAME+SIZE
DECD: %IF AMODE = 0 %OR (AMODE = 1 %AND GG # SPEC) %START
         %IF TYPE # RECORD %AND TYPE # 10 %START
            %IF FORM = 1 %OR FORM = 2 %START
               SET DIAG(LOCAL, DECVAR_DISP, TYPE, FORM)
            %FINISH
         %FINISH
      %FINISH
   %END
   %RECORD(STACKFM)%MAP DESCRIPTOR
      %RECORD(STACKFM)%NAME V;  %RECORD(DFM)%NAME D
      V == DESC ASL;  ABORT(17) %IF V == NULL
      D == DASL;      ABORT(17) %IF D == NULL
      DESC ASL == V_LINK;  V = 0
      DASL == D_LINK;  D_LINK == USING_LINK;  USING_LINK == D
      D_D == V
      V_LINK ==NULL
      %RESULT == V
   %END
   %ROUTINE DROP(%RECORD(STACKFM)%NAME D)
      %RECORD(DFM)%NAME P, Q
      P == USING
      %CYCLE
         Q == P_LINK
         ABORT(18) %IF Q == NULL
         %EXIT %IF Q_D == D
         P == Q
      %REPEAT
      P_LINK == Q_LINK
      Q_LINK == DASL;  DASL == Q
      D_LINK == DESC ASL;  DESC ASL == D
   %END
   %ROUTINE STACK(%INTEGER DISP, BASE, TYPE, FORM, FORMAT, EXTRA, LENGTH)
      %CONSTBYTEINTEGERARRAY FMAP(0:15) = CONSTANT, V IN S, A IN S,0(4),
                                      16,17,19,19,
                                      !0, V IN R, V IN S, V IN S,
                                      V IN S, A IN S,
                                      0(3)
      %RECORD(STACKFM)%NAME V
      STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
      V == DESCRIPTOR
      V_BASE = BASE
      V_DISP = DISP
      V_FORMAT = FORMAT
      V_EXTRA = EXTRA;  V_DV = EXTRA
      V_TYPE = TYPE
      V_LENGTH = LENGTH
      V_FORM = FMAP(FORM)
      STACKED(STP)_V == V
      LHS == V
      SHOW(V) %IF CONTROL < 0
   %END
   %ROUTINE VSTACK(%RECORD(VARFM)%NAME V)
      STACK(V_DISP, V_BASE, V_TYPE, V_FORM, V_FORMAT, V_EXTRA, V_LENGTH)
   %END
   %ROUTINE SSTACK(%RECORD(STACKFM)%NAME V)
      %RECORD(STACKFM)%NAME T
      STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
      T == DESCRIPTOR;  T = V
      STACKED(STP)_V == T;  CLAIM(T_BASE)
      SHOW(T) %IF CONTROL < 0
   %END
   %ROUTINE C STACK(%INTEGER N)
      RHS == DESCRIPTOR
      RHS_BASE = 0
      RHS_DISP = N
      RHS_TYPE = INTEGER
      RHS_FORM = CONSTANT
      STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
      STACKED(STP)_V == RHS
      SHOW(RHS) %IF CONTROL < 0
   %END
   %ROUTINE  FP CSTACK(%REAL X, %RECORD(STACK FM)%NAME  R)
      %RECORDFORMAT  F(%INTEGER  VAL, GDISP)
      %CONSTINTEGER  L=31;    ! ... MUST BE 2\\N - 1
      %OWNRECORD(F)%ARRAY CONST LIST(0:L)
      %OWNSHORTINTEGER  LAST PNTR = 0, NEXT PNTR = 0
      %INTEGER  N;  %SHORTINTEGER I
!!!      %RECORDFORMAT  FI(%INTEGER X)
!!!      %RECORDFORMAT  FR(%REAL X)
!!!      %RECORD(FR) RV;  %RECORD(FI)%NAME  IV
!!!      RV_X = X;  IV == RV;  N = IV_X

      %recordformat  convfm(%integer  n %or %real x)
      %record(convfm)  conv
      conv_x = x;  n = conv_n

      OWNVAL = N;  REALGA = GA
!
      I = NEXT PNTR
      %WHILE  I # LAST PNTR %CYCLE
         I = (I-1)&L
         -> FOUND IT %IF CONST LIST(I)_VAL = N
      %REPEAT
      GFIX(4);  I = GA;    ! FULLWORD ALIGN AND REMEMBER ADDR.
      GWORD(N)
      CONST LIST(NEXT PNTR)_VAL = N
      CONST LIST(NEXT PNTR)_GDISP = I
      I = NEXT PNTR;   ! ...FOR USE AT 'FOUND IT:'
      NEXT PNTR = (NEXT PNTR+1)&L
      LAST PNTR = (LAST PNTR+1)&L %IF LAST PNTR = NEXT PNTR
FOUND IT:
      R_BASE = GLA
      R_DISP = CONST LIST(I)_GDISP
      R_TYPE = REALS
      R_FORM = V IN S
      STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
      STACKED(STP)_V == R
   %END
   %ROUTINE SSET(%INTEGER BASE, DISP, FORM, EXTRA)
      RHS == DESCRIPTOR
      RHS_BASE = BASE
      RHS_DISP = DISP
      RHS_TYPE = INTEGER
      RHS_FORM = FORM
      RHS_EXTRA = EXTRA
      STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
      STACKED(STP)_V == RHS
   %END
   %ROUTINE SET LHS
      LHS == STACKED(STP)_V
   %END
   %ROUTINE SET BOTH
      ABORT(8) %IF STP <= 1
      LHS == STACKED(STP-1)_V
      RHS == STACKED(STP)_V
   %END
   %ROUTINE POP LHS
      ABORT(8) %IF STP <= 0
      LHS == STACKED(STP)_V
      STP = STP-1
   %END

 ! STRING PROCESSING

   %ROUTINE DUMP STRING(%INTEGER MAX)
      %INTEGER J
      GFIX(2)
      %IF MAX <= 0 %START
         ->OUT %IF ACTIVE STRING == NULL %OR (MAX < 0 %AND CSLEN = 0)
         ACTIVE STRING_BASE = GLA;  ACTIVE STRING_DISP = GA
         ACTIVE STRING_FORM = V IN S
         MAX = CSLEN
      %ELSE
         MAX = MAX-1
         ABORT(-13) %IF MAX < CSLEN
      %FINISH
      GBYTE(CURRENT STRING(J)) %FOR J = 0, 1, MAX
      CSLEN = 0
OUT:  ACTIVE STRING == NULL
   %END
   %ROUTINE GET STRING
      %INTEGER L, S
      DUMP STRING(0) %UNLESS ACTIVE STRING == NULL
      L = TAG;  SKIPSYMBOL %IF L # 0
      CSLEN = 0
      %WHILE L > 0 %CYCLE
         L = L-1
         READSYMBOL(S)
         CSLEN = CSLEN+1;  CURRENT STRING(CSLEN) = S
      %REPEAT
      STACK(0, 0, STRING, 0, 0, 0, 0)
      ACTIVE STRING == STACKED(STP)_V
   %END

! LABEL PROCESSING

      %INTEGERFN NEW TAG
         %OWNINTEGER TAG = 0
         TAG = TAG+1
         %RESULT = TAG
      %END
      %RECORD(LABELFM)%MAP NEW LABEL
         LABS = LABS+1;  ABORT(-5) %IF LABS > MAX LABELS
         FLAB == LABELS(LABS)
         %RESULT == FLAB
      %END
      %RECORD(LABELFM)%MAP FIND(%INTEGER LABEL)
         %INTEGER LP
         LP = LABS
         %WHILE LP # LABEL START %CYCLE
            FLAB == LABELS(LP)
            %RESULT == FLAB %IF FLAB_ID = LABEL
            LP = LP-1
         %REPEAT
         %RESULT == NULL
      %END
      %ROUTINE DEFINE LABEL(%INTEGER LABEL)
         %RECORD(ENVFM)%NAME E
         %RECORD(LABELFM)%NAME L
         L == FIND(LABEL)
         %IF L == NULL %START
            %IF CONTROL < 0 %START
               SELECTOUTPUT(REPORT)
               PRINTSTRING(" DEF:");  WRITE(LABEL, 2)
               PRINTSTRING("  LABS =");  WRITE(LABS, 2);  NEWLINE
               SELECTOUTPUT(OBJECT)
            %FINISH
            L == NEW LABEL
            L_ID = LABEL;  L_TAG = NEW TAG;  L_REG = 0
            LIMEN = CA
            E == ENVIRONMENT(LABEL);  E_LABEL = 0
         %ELSE %IF L_TAG < 0 %AND LABEL >= 0
            L_TAG = NEW TAG;  L_REG = 0
            E == ENVIRONMENT(LABEL);  E_LABEL = 0
         %FINISH
         L_TAG = L_TAG!X'8000'
         DEFINE TAG(L_TAG&X'7FFF')
         MERGE ENVIRONMENT(LABEL) %IF UNCOND JUMP # CA
         RESTORE ENVIRONMENT(LABEL)
         RT LAB = CA %IF LABEL = 0
         CCCA = 0
         UNCOND JUMP = 0;! YOU CAN GET HERE!
      %END
      %ROUTINE JUMP TO(%INTEGER LABEL, COND, DEF)
         %INTEGER REF, LTAG
         %RECORD(LABELFM)%NAME LAB
         %RECORD(USEFM)%NAME U
         INVERT = 0;! EXPEND CONDITION INVERSION
         LAB == FIND(LABEL)
         %IF LABEL = 0 %AND RT LAB = CA %START;! JUMP ROUND ROUTINE
            LAB_TAG = LAB_TAG&X'7FFF';  %RETURN
         %FINISH
         %IF LAB == NULL %START
            LAB == NEW LABEL
            LAB_ID = LABEL;  LAB_REG = 0
            LAB_TAG = NEW TAG
            REMEMBER ENVIRONMENT(LABEL)
         %ELSE %IF LAB_REG # 0 %AND SYM # 'B'
            LAB_BASE = LAB_BASE!128
            JUMP TO(LABEL+3, COND, DEF)
            %RETURN
         %ELSE %IF LAB_TAG < 0 %AND DEF = REDEFINE
            LAB_REG = 0;  LAB_TAG = NEW TAG
            REMEMBER ENVIRONMENT(LABEL)
         %ELSE
            MERGE ENVIRONMENT(LABEL) %IF LAB_TAG >= 0
         %FINISH
         LTAG = LAB_TAG&X'7FFF'
         %IF LAB_REG # 0 %START
            DEFINE LABEL(LABEL+3) %IF LAB_BASE&128 # 0
            SSET(LAB_BASE&127, LAB_DISP, V IN S, 0)
            LHS == RHS;  LOAD(LHS, LAB_REG)
            SSET(0, LAB_LIMIT, CONSTANT, 0)
            COMPARE(LHS, RHS);  COND = 1
            STP = STP-2;  DROP(LHS);  DROP(RHS)
         %FINISH
         %IF COND = JUMP %THEN REF = J REF %ELSE REF = C REF
         DEFINE REFERENCE(LTAG, REF)
         DUMP(COND+X'8000');  CCCA = CCCA+2
         UNCOND JUMP = CA %IF COND = JUMP;! NO WAY PAST HERE
         %IF KNOWN_CA = 0 %START;! SOMETHING TO LEARN
            KNOWN_CA = 1
            U == USE(KNOWN_BASE)
            U_TYPE = KNOWN_TYPE;  U_FORM = CONSTANT
            U_BASE = 0;  U_DISP = KNOWN_DISP
            U_CA = CA
         %FINISH
      %END
   %ROUTINE FLOAT(%RECORD(STACKFM)%NAME V, %INTEGER REG)
      %INTEGER  D
      %IF V_FORM = CONSTANT %START
      !  FLOAT CONSTANTS AT COMPILE-TIME
         D = V_DISP
         %IF D = 0 %START
            REG = FPR %IF REG = ANYF
            CLAIM(REG)
            RR(SER, REG, REG);  CLAIM (REG)
            V_BASE = REG;  V_DISP = 0;  V_TYPE = REALS;  V_FORM = V IN R
         %ELSE
            FP CSTACK(D,V);  ! ...N.B. 'D' FLOATED BY PARAMETER PASSING
            STP = STP-1;      ! ...WE DON'T WANT A NEW STACK ITEM
         %FINISH
         %RETURN
      %FINISH
      LOAD(V, REG) %AND %RETURN %IF V_LOP # 0
      LOAD(V, ANY)
      REG = FPR %IF REG = ANYF
      RR(FLR, REG, V_BASE)
      CLAIM(REG)
      V_TYPE = REALS;  V_FORM = V IN R
      V_BASE = REG;  V_DISP = 0
   %END
   %ROUTINE LRD(%RECORD(STACKFM)%NAME V, %INTEGER REG)
      LOAD(V, REG)
      RELEASE(V_BASE)
      DROP(V)
   %END
   %ROUTINE REDUCE(%RECORD(STACKFM)%NAME V)
      %INTEGER TYPE, FORM, DISP
      TYPE = V_TYPE;  FORM = V_FORM - 2
      FORM = AV IN S  %IF FORM = AV IN REC-2
      DISP = V_DISP
      V_DISP = V_EXTRA;  V_TYPE = INTEGER;  V_FORM = V IN S
      LOAD(V, ANY0)
      V_TYPE = TYPE;  V_FORM = FORM
      V_DISP = DISP
   %END
   %ROUTINE VMAP(%RECORD(STACKFM)%NAME V)
      %INTEGER N
      %CONSTBYTEINTEGERARRAY MAP(0:15) =
         V IN S, V IN S, V IN S, A IN S, V IN S,
         A IN REC, V IN S, V IN REC, 0(8)
      LOAD(V, ANY0) %IF V_FORM = AINS %OR V_FORM = AINREC
      %IF V_LOP # 0 %START
         %IF V_LOP = ADD %AND CONST(V_LINK) %START
            N = V_LINK_DISP
            V_LOP = 0;  DROP(V_LINK)
            %IF V_FORM = AVINS %OR V_FORM = AVINREC %START
               V_DISP = V_DISP+N
            %ELSE
               LOAD(V, ANY0);  V_DISP = N
            %FINISH
         %ELSE
            LOAD(V, ANY0)
         %FINISH
      %FINISH
      V_FORM = MAP(V_FORM)
   %END
   %ROUTINE AMAP(%RECORD(STACKFM)%NAME V)
      %CONSTSHORTINTEGERARRAY MAP(0:7) =
            -1, -1, V IN S, AV IN S, V IN REC, AV IN REC, -1, -1
      V_FORM = MAP(V_FORM)
      %IF  V_FORM = AV IN S %START
         %IF  V_BASE = 0 %THEN  V_FORM = CONSTANT  %ELSE %START
            V_FORM = V IN R %IF V_DISP = 0
         %FINISH
      %FINISH
      ABORT(9) %IF V_FORM < 0
      V_TYPE = INTEGER
   %END
   %ROUTINE OPTIMISE(%RECORD(STACKFM)%NAME V)
      %INTEGER R
      %RETURN %IF V_FORM = V IN R %OR V_LOP # 0
      REDUCE(V) %IF V_FORM >= A IN REC %AND V_FORM # AV IN S
      R = FIND USE(V_TYPE, V_FORM, V_BASE, V_DISP)
      %IF R # 0 %START
         V_BASE = R;  V_DISP = 0;  V_FORM = V IN R
      %ELSE %IF V_FORM = A IN S
         R = FIND USE(INTEGER, V IN S, V_BASE, V_DISP)
         %RETURN %IF R = 0
         V_BASE = R;  V_DISP = 0;  V_FORM = V IN S
         OPTIMISE(V)
      %FINISH
   %END
   %ROUTINE RANGE(%SHORTINTEGERNAME BASE, %INTEGERNAME DISP)
      %RECORD(STACKFM) V
      %RETURN %IF 0 <= DISP <= X'3FFF'
      V_TYPE = INTEGER;  V_FORM = AV IN S
      V_BASE = BASE;  V_DISP = DISP&(\X'3FFF')
      DISP = DISP-V_DISP
      V_LOP = 0
      LOAD(V, ANY0)
      BASE = V_BASE
   %END
   %ROUTINE ADDRESS(%RECORD(STACKFM)%NAME V)
      %INTEGER TYPE, FORM
      FORM = V_FORM;  TYPE = V_TYPE
      %IF FORM = V IN REC %OR FORM = A IN REC %START
         REDUCE(V);  FORM = V_FORM
      %FINISH
      %UNLESS FORM = V IN S %OR FORM = V IN R %START
         %IF FORM = A IN S %START
            FORM = V IN S;  V_FORM = FORM
            V_TYPE = INTEGER
            LOAD(V, ANY0)
         %ELSE
            LOAD(V, ANY)
            FORM = V IN R;  TYPE = INTEGER
         %FINISH
      %FINISH
      RANGE(V_BASE, V_DISP)
      V_TYPE = TYPE;  V_FORM = FORM
   %END
   %ROUTINE LOAD(%RECORD(STACKFM)%NAME V, %INTEGER R)
      %RECORD(STACKFM) H
      %CONSTSHORTINTEGERARRAY OP KEY(1:17) = -1, 0, 0, 6, 4, 2, 0,
                                              0, 5,10, 0, 2, 0, 0, 0,0 ,0
      %CONSTSHORTINTEGERARRAY PM(0:11) =
                      AR, AIS, AHI, AW, AH, AI,
                      SR, SIS, SHI, SW, SH, SI
      %CONSTSHORTINTEGERARRAY MULDIV(0:5) = DR, DW,
                                            MR, MW,
                                            MR, MW
      %CONSTSHORTINTEGERARRAY LOGICAL(0:14) =
                                           NR, NHI, NW, NH, NI,
                                           OR, OHI, OW, OH, OI,
                                           XR, XHI, XW, XH, XI

      %CONSTSHORTINTEGERARRAY SHIFT(0:3) = SLLS, SLL, SRLS, SRL

      %CONSTSHORTINTEGERARRAY REAL OP(3:14) = AER, SER, 0,
                                              MER, DER, 0, 0,
                                              AE, SE, 0,
                                              ME, DE
      %INTEGERFN PRED(%INTEGER R)
         %CONSTBYTEINTEGERARRAY INV(0:15) = R0, R1, R2, R3,
                                            R4, P2, P1, WSP,
                                            LINK, R9, R10, R11,
                                            R12, GLA, CODE, R15
         %RESULT = INV(ACTUAL(R)!!1)
      %END
      %RECORD(STACKFM)%NAME W
      %SWITCH F(0:8), IOP(1:17), ROP(1:17)
      %INTEGER OP, T, D, TYPE, FORM, KEY, TEMP, N
      %OWNINTEGER  ADDXCA=0, ADDXD=0, ADDXS=0, ADDXKEY=0

      ABORT(-2) %IF FREE SPACE < MIN FREE;   ! ...STACK OVERFLOW?
      ->REALZ %IF FLOATING(V) %OR FPR0 <= R <= FPR14 %OR R = ANYF
      OP = V_LOP;  V_LOP = 0
      %IF OP # 0 %START
         W == V_LINK
         OPTIMISE(V);  OPTIMISE(W) %UNLESS W == NULL
         %IF OP = SUB %AND W_FORM = CONSTANT %START
            OP = ADD;  W_DISP = -W_DISP
         %FINISH
         %IF COMM(OP) # 0 %START;! SWOP OPERANDS ?
            T = 0
            T = 1 %IF W_BASE = R %OR (W_FORM = V IN R %AND V_FORM # V IN R)
            T = 1 %IF V_TYPE # BYTE %AND W_TYPE = BYTE %AND V_BASE # R
            T = 1 %IF W_FORM = CONSTANT %AND R < ANY %AND R # V_BASE %C
                                        %AND V_TYPE # BYTE
            T = 0 %IF V_BASE = R %C
                  %OR (W_FORM = V IN R %AND ACTIVITY(W_BASE) < 0)
            %IF T # 0 %START
               H = W;  W = V;  V = H
            %FINISH
         %FINISH
         %IF CONTROL&UNASS DIAG # 0 %START
            LOAD(W, ANY0) %UNLESS W_FORM = CONSTANT %C
                              %OR (W_TYPE # INTEGER %AND W_TYPE # REALS)
         %FINISH
         KEY = OP KEY(OP)
         ->IOP(OP)
      %FINISH
      %IF V_TYPE = STRING %OR V_TYPE = 0 %START
         AMAP(V)
      %FINISH
      %IF  V_FORM > V IN S  %AND  V_FORM # AV IN S  %THEN REDUCE(V)
      OPTIMISE(V)
      %IF R >= ANY %START
         %RETURN %IF V_FORM = V IN R %AND (R = ANY %OR V_BASE # R0) %C
                                     %AND ACTIVITY(V_BASE) >= 0
         R = GPR(R-ANY)
      %ELSE
         HAZARD(R) %UNLESS V_BASE = R %AND ACTIVITY(R) = 1
      %FINISH
      ->F(V_FORM)
F(AV IN REC):
F(A IN REC):
F(V IN REC):
      CLAIM(R);  REDUCE(V);  RELEASE(R)
      ->F(V_FORM)
F(AV IN S):
      ABORT(10) %IF V_TYPE = REALS
      %IF V_BASE # R0 %START
         %IF -X'8000' <= V_DISP <= X'7FFF' %START
            %IF V_DISP # 0 %START
               RI2(LHI, R, V_BASE, V_DISP)
            %ELSE
               RR(LR,R,V_BASE)
            %FINISH
         %ELSE
            RI3(LI, R, V_BASE, V_DISP)
         %FINISH
         CLAIM(R)
         REMEMBER(R, V)
         V_BASE = R;  V_DISP = 0
         V_TYPE = INTEGER;  V_FORM = V IN R
         %RETURN
      %FINISH
F(CONSTANT):
      ABORT(16) %IF V_TYPE = REALS
      D = V_DISP
      %IF -15 <= D <= 15 %START
         %IF D >= 0 %START
            SF(LIS, R, D)
         %ELSE
            SF(LCS, R, -D)
         %FINISH
      %ELSE
         %IF -X'8000' <= D <= X'7FFF' %START
            RI2(LHI, R, 0, D)
         %ELSE
            RI3(LI, R, 0, D)
         %FINISH
      %FINISH
      CLAIM(R);  REMEMBER(R, V)
      V_BASE = R;  V_DISP = 0
      V_TYPE = INTEGER;  V_FORM = V IN R
      %RETURN
F(V IN R):
      OP = LR
      %RETURN %IF V_BASE = R
      OP = LER %IF V_TYPE = REALS
      RR(OP, R, V_BASE);  CLAIM(R)
      CCREG = R;  CCCA = CA
      FORGET(R)
      USE(R) = USE(V_BASE)
      V_BASE = R
      %RETURN
F(A IN S):
      TYPE = V_TYPE
      V_TYPE = INTEGER;  V_FORM = V IN S
      CLAIM(R);  LOAD(V, ANY0);  RELEASE(R)
      V_TYPE = TYPE;  V_FORM = V IN S
F(V IN S):
      RANGE(V_BASE, V_DISP)
      CCREG = R;  CCCA = CA+4
      %IF V_TYPE = INTEGER %START
         OP = LW
      %ELSE %IF V_TYPE = SHORT
         OP = LH
      %ELSE %IF V_TYPE = BYTE
         OP = LB;  CCCA = 0
      %ELSE %IF V_TYPE = REALS
         OP = LE
      %ELSE
         OP = LHL;        ! INTERNALLY GENERATED 'UNSIGNED HALFWORD'
      %FINISH
      RX(OP, R, V_BASE, V_DISP)
      CLAIM(R);  REMEMBER(R, V)
      V_BASE = R;  V_DISP = 0
      V_FORM = V IN R
      %RETURN
IOP(ADD):
      %IF W_FORM = V IN R %AND W_BASE # R %AND V_FORM = CONSTANT %START
         D = V_DISP
         %IF (USE(W_BASE)_CA > LIMEN %OR USE(W_BASE+STORE)_CA > LIMEN %C
               %OR D < -15 %OR D > 15) %AND CA # ADDXCA %START
            %IF R >= ANY %START
               R = GPR(R-ANY)
            %ELSE %IF W_BASE # R %OR ACTIVITY(R) # 1
               HAZARD(R)
            %FINISH
            %IF -X'8000'<=D<=X'7FFF' %THEN RI2(LHI,R,W_BASE,D) %C
               %ELSE RI3(LI,R,W_BASE,D)
            CCREG = R;  CCCA = CA
            V_DISP = 0;  V_FORM = V IN R
            V_BASE = R;  CLAIM(R)
            ->END OP
         %FINISH
      %FINISH
IOP(SADD):
IOP(SUB):
      LOAD(V, R);  R = V_BASE
      LOAD(W, ANY) %IF W_TYPE = BYTE %OR W_TYPE = UNSIGNED HALFWORD
      %IF W_FORM = CONSTANT %START
         D = W_DISP
         %IF -15 <= D <= 15 %START
            D = -D %AND KEY = 6-KEY %IF D < 0
            SF(PM(KEY+1), R, D)
         %ELSE
            %IF -X'8000' <= D <= X'7FFF' %START
               %IF CA = ADDXCA %AND R = ADDXD %START
                  D = -D %IF ADDXKEY # KEY
                  DUMP(D)
                  PATCH(PM(ADDXKEY+2)+ACTUAL(R)<<4+ACTUAL(ADDXS),   %C
                                                               ADDXCA-2)
               %FINISH %ELSE RI2(PM(KEY+2), R, 0, D)
            %ELSE
               RI3(PM(KEY+5), R, 0, D)
            %FINISH
         %FINISH
      %ELSE %IF W_FORM = V IN R
         RR(PM(KEY), R, W_BASE)
         ADDXCA = CA;  ADDXD = R;  ADDXKEY = KEY;  ADDXS = W_BASE
      %ELSE %IF W_FORM = AV IN S
         RI2(PM(KEY+2), R, W_BASE, W_DISP)
      %ELSE
         ADDRESS(W)
         KEY = KEY-1 %IF W_FORM = V IN R
         KEY = KEY+1 %IF W_TYPE = SHORT
         RX(PM(KEY+3), R, W_BASE, W_DISP)
      %FINISH
      ->SET CC
IOP(MUL):
IOP(DIV):
IOP(REM):
      %IF R >= ANY %START
         %IF KEY = 0 %THEN N = 0 %ELSE N = 1
         %IF V_FORM = V IN R %AND ACTUAL(V_BASE)&1 = N %C
                             %AND ACTIVITY(PRED(V_BASE)) = 0 %START
            TEMP = V_BASE
            TEMP = PRED(TEMP) %IF KEY = 0
         %ELSE
            TEMP = EVEN ODD PAIR
         %FINISH
      %ELSE %IF ACTUAL(R)&1 = 0 %OR ACTIVITY(PRED(R)) # 0
         TEMP = EVEN ODD PAIR
      %ELSE
         TEMP = R
      %FINISH
      N = PRED(TEMP);  HAZARD(N)
      %IF KEY # 0 %START
         CLAIM(N);  LOAD(V, TEMP)
      %ELSE
         CLAIM(TEMP);  LOAD(V, N)
         RR(LR, TEMP, N)
         USE(TEMP) = USE(N);  USE(TEMP+STORE) = USE(N)
         CLAIM(N)
         RX(SRA, N, 0, 31);  FORGET(N)
      %FINISH
      LOAD(W,ANY) %IF W_FORM = CONSTANT %OR W_TYPE # INTEGER
      ADDRESS(W)
      %IF W_FORM = V IN R %START
         RR(MULDIV(KEY), N, W_BASE)
      %ELSE
         RX(MULDIV(KEY+1), N, W_BASE, W_DISP)
      %FINISH
      %IF OP = REM %START
         D = TEMP;  TEMP = N;  N = D
      %FINISH
      RELEASE(N)
      FORGET(N);  FORGET(TEMP)
      V_BASE = TEMP;  V_DISP = 0;  V_FORM = V IN R
      LOAD(V, R) %IF TEMP # R
      ->END OP
IOP(AND):
      %IF V_FORM = CONSTANT %AND V_DISP = 255 %START
         %IF W_FORM = V IN R %START
            %IF R >= ANY %START
               %IF ACTIVITY(W_BASE) = 1 %THEN R = W_BASE %C
                                        %ELSE R = GPR(R-ANY)
            %ELSE %IF R # W_BASE %OR ACTIVITY(R) # 1
               HAZARD(R)
            %FINISH
         %ELSE
            LOAD(W,R);  R = W_BASE
         %FINISH
         CLAIM(R)
         RR(LBR,R,W_BASE)
         V_BASE = R;  V_DISP = 0;  V_FORM = V IN R
         -> FEND
      %FINISH
IOP(IOR):
IOP(XOR):
      %IF W_FORM = CONSTANT %AND -15 <= W_DISP <= 15 %START
         %IF V_FORM # V IN R %OR (R < ANY %AND V_BASE # R) %START
            H = W;  W = V;  V = H
         %FINISH
      %FINISH
      LOAD(V, R);  R = V_BASE
      LOAD(W, ANY) %IF W_TYPE = BYTE
      %IF W_FORM = CONSTANT %START
         %IF KEY = 0 %AND W_DISP = 255 %START;!  N&255
            CLAIM(R)
            RR(LBR, R, R);  -> FEND
         %FINISH
         %IF -X'8000' <= W_DISP <= X'7FFF' %START
            RI2(LOGICAL(KEY+1), R, 0, W_DISP)
         %ELSE
            RI3(LOGICAL(KEY+4), R, 0, W_DISP)
         %FINISH
      %ELSE %IF W_FORM = V IN R
         RR(LOGICAL(KEY), R, W_BASE)
      %ELSE
         ADDRESS(W)
         KEY = KEY+1 %IF W_TYPE = SHORT %OR W_TYPE = UNSIGNED HALFWORD
         RX(LOGICAL(KEY+2), R, W_BASE, W_DISP)
      %FINISH
      ->SET CC
IOP(RSH):
IOP(LSH):
      LOAD(V, R);  R = V_BASE
      !  IGNORE ANY VALUE IN A REGISTER WHICH HAPPENS TO BE THE
      !  SAME AS A CONSTANT SHIFT COUNT <=15 AS OTHERWISE THE LONG FORM
      !  OF SHIFT INSTRUCTION WILL BE GENERATED NEEDLESSLY.
      %IF W_FORM = V IN R %AND USE(W_BASE)_CA > LIMEN  %C
                          %AND USE(W_BASE)_FORM = CONSTANT  %C
                          %AND 0 <= USE(W_BASE)_DISP <= 15  %START
         W_DISP = USE(W_BASE)_DISP
         W_FORM = CONSTANT
         RELEASE(W_BASE)
      %FINISH
      %IF W_FORM = CONSTANT %START
         %IF KEY = 0 %AND W_DISP = 1 %START
            CLAIM(R)
            RR(AR, R, R)
         %ELSE %IF W_DISP > 15
            RX(SHIFT(KEY+1), R, 0, W_DISP)
         %ELSE
            SF(SHIFT(KEY), R, W_DISP&15)
         %FINISH
      %ELSE
         LOAD(W, ANY0)
         RX(SHIFT(KEY+1), R, W_BASE, 0)
      %FINISH
      ->SET CC
IOP(NEG):
IOP(NOT):
      %IF V_BASE = R %START
         LOAD(V, R)
         RI2(XHI, V_BASE, 0, -1)
         SF(AIS, V_BASE, 1) %IF KEY = 0
      %ELSE
         W == RHS;  CSTACK(KEY);  RHS == W
         SSTACK(V);  RELEASE(V_BASE);  V_BASE = 0
         OPERATE(SUB);  STP = STP-1
         V = STACKED(STP+1)_V;  DROP(STACKED(STP+1)_V)
         LOAD(V, R)
      %FINISH
      FORGET(V_BASE)
      CCREG = V_BASE;  CCCA = CA
      %RETURN
IOP(EXP):
      LOAD(V, R2);  LOAD(W, R3)
      RELEASE(R2);  RELEASE(R3)
      PERM(IEXP)
      CLAIM(R1);  V_BASE = R1
      ->END OP
IOP(CONC):
      %IF V_TYPE # 0 %START
         LOAD(V, R1);  RELEASE(R1)
         HAZARD(R2)
         %IF WDISP = 0 %START
            RR(LR , R2, WSP)
         %ELSE
            RI2(LHI, R2, WSP, WDISP)
         %FINISH
         FORGET(R2)
         WDISP = WDISP+256
         PERM(CONC1)
      %ELSE
         LOAD(V, R2);  RELEASE(R2)
      %FINISH
      JOIN(W)
      CLAIM(R2)
      V_TYPE = 0;  V_FORM = V IN S
      V_BASE = R2;  V_DISP = 0
      %IF R # ANY %START;! NOT FROM OPERATE
         LOAD(V, R);  V_TYPE = 0;  V_FORM = V IN S
      %FINISH
      %RETURN
REALZ:ABORT(11) %IF R = ANY;     ! ...SHOULD BE FLOATING REGISTER!!!
      OP = V_LOP;  V_LOP = 0
      %IF OP # 0 %START
         -> ROP NEG %IF OP = NEG
         W == V_LINK
IOP(RDIV):
         FLOAT(W, ANYF) %IF W_TYPE # REALS %AND OP # EXP
         FLOAT(V, R) %IF V_TYPE # REALS
         %IF OP = ADD %OR OP = MUL %START
            OPTIMISE(V);  OPTIMISE(W) %UNLESS W == NULL
            %IF W_BASE=R %OR (V_FORM # V IN R %AND W_FORM = V IN R) %START
               H = W;  W = V;  V = H
            %FINISH
         %FINISH
         ADDRESS(W) %UNLESS W == NULL
         ->ROP(OP)
ROP(NOT):ROP(LSH):  ROP(RSH):
ROP(AND):ROP(IOR):    ROP(XOR):
         REAL ERROR(OP)
ROP(RDIV):OP = DIV
ROP(ADD):
ROP(SUB):
ROP(MUL):
         LOAD(V, R);  R = V_BASE
         %IF W_FORM = V IN R %START
            RR(REALOP(OP), R, W_BASE)
         %ELSE
            RX(REALOP(OP+7), R, W_BASE, W_DISP)
         %FINISH
         ->SET CC
ROP NEG:
ROP(NEG):LOAD(V, ANYF) %IF V_BASE = R
         R = FPR %IF R = ANYF
         HAZARD(R)
         CLAIM(R);  RR(SER, R, R);  CLAIM(R)
         ADDRESS(V)
         %IF V_FORM = V IN R %START
            RR(SER, R, V_BASE)
         %ELSE
            RX(SE, R, V_BASE, V_DISP)
         %FINISH
         CCREG = R;  CCCA = CA
         FORGET(R)
         V_BASE = R;  V_DISP = 0
         V_FORM = V IN R
         %RETURN
      %FINISH
      FLOAT(V, R) %IF V_TYPE # REALS
      OPTIMISE(V)
      %IF V_FORM = V IN R %START
         %RETURN %IF R = ANYF %OR V_BASE = R
         RR(LER, R, V_BASE);  USE(R) = USE(V_BASE)
         V_BASE = R;  CLAIM(V_BASE)
         CCREG = R;  CCCA = CA
         %RETURN
      %FINISH
      R = FPR %IF R = ANYF
      ABORT(12) %UNLESS FPR0 <= R <= FPR14
      ->F(V_FORM)
ROP(EXP):
      REAL ERROR(1) %AND W_TYPE = INTEGER %IF W_TYPE = REALS
      LOAD(V, FPR2);  LOAD(W, R1)
      RELEASE(FPR2);  RELEASE(R1)
      PERM(REXP)
      CLAIM(FPR0);  V_BASE = FPR0
      ->ENDOP
SET CC:
      CCCA = CA;  CCREG = R
FEND: FORGET(R)
END OP:DROP(W)
   %END
      %ROUTINE COP(%INTEGER OP, %INTEGERNAME L, %INTEGER R)
         %SWITCH S(1:17)
         ->S(OP)
S(SADD):
S(RDIV):
S(NEG):
S(NOT):
S(CONC):    ABORT(13)
S(ADD):     L = L+R;    %RETURN
S(SUB):     L = L-R;    %RETURN
S(IOR):     L = L!R;    %RETURN
S(AND):     L = L&R;    %RETURN
S(XOR):     L = L!!R;   %RETURN
S(LSH):     L = L<<R;   %RETURN
S(MUL):     L = L*R;    %RETURN
S(RSH):     L = L>>R;   %RETURN
S(EXP):     L = L\\R;   %RETURN
S(DIV):     ABORT(-6) %AND R = 1 %IF R = 0
            L = L//R;   %RETURN
S(REM):     ABORT(-6) %AND R = 1 %IF R = 0
            L = L-L//R*R
      %END
      %ROUTINE JOIN(%RECORD(STACKFM)%NAME W)
         %RECORD(STACKFM)%NAME QW
         %CYCLE
            QW == W_LINK;  W_LOP = 0
            LRD(W, R1);  PERM(CONC2)
            %EXIT %IF QW == NULL
            W == QW
         %REPEAT
      %END
      %ROUTINE OPERATE(%INTEGER OPER)
         %CONSTINTEGERARRAY NULL OP(3:17) = 0,0,1,1,1,-1,0(4),1,0,0,1,1
         %INTEGER RCON, LCON, WCON, LOP
         %INTEGER KEY, D, S
         %RECORD(STACKFM)%NAME WITH, LH, RH
         %CONSTBYTEINTEGERARRAY TRANS(1:17) = 2,2,0,0,1(6),2(4),0,15,15

         %ROUTINE  SWOP
            WCON = LCON;  LCON = RCON;  RCON = WCON
            WITH == LH;  LH == RH;  RH == WITH
            STACKED(STP)_V == LH
         %END
         %ROUTINE  PICKUP(%RECORD(STACKFM)%NAME  V)
            %IF FLOATING(V) %THEN LOAD(V,ANYF) %ELSE LOAD(V,ANY)
         %END

         %IF OPER <= NEG %START;! UNARY
            LH == STACKED(STP)_V
            %IF CONST(LH) %START
               LH_DISP = \LH_DISP+OPER-1
            %ELSE
               PICKUP(LH) %IF LH_LOP # 0
               LH_LOP = OPER;  LH_LINK == NULL
            %FINISH
            %RETURN
         %FINISH
         STP = STP-1
         LCON = 0;  RCON = 0;  WCON = 0
         LH == STACKED(STP)_V
         RH == STACKED(STP+1)_V
         LCON = 1 %IF CONST(LH)
         RCON = 1 %IF CONST(RH)
         %IF OPER = SUB %AND RCON # 0 %START
            OPER = ADD;  RH_DISP = -RH_DISP
         %FINISH
         %IF LH_LOP # 0 %START
            LOP = LH_LOP
            %IF OPER = CONC %START
               WITH == LH
               WITH == WITH_LINK %WHILE WITH_LOP # 0
               WITH_LINK == RH
               WITH_LOP = CONC
               %RETURN
            %FINISH
            WITH == LH_LINK
            WCON = 1 %IF OPER > NEG %AND CONST(WITH)
            %IF LOP = NEG %AND OPER = ADD %START
               RH_LOP = SUB;  RH_LINK == LH
               LH_LOP = 0
               STACKED(STP)_V == RH
               %RETURN
            %FINISH
            DUMP STRING(0) %IF WITH_TYPE = STRING
            %IF WCON&RCON # 0 %START
               KEY = TRANS(OPER)!TRANS(LOP)
               %IF KEY = 0 %OR (KEY = 1 %AND OPER = LOP) %START
                  COP(OPER, WITH_DISP, RH_DISP);  DROP(RH)
                  %IF WITH_DISP = NULL OP(OPER) %START
                     LH_LOP = 0;  DROP(WITH)
                  %FINISH
                  %RETURN
               %FINISH
            %FINISH
            PICKUP(LH)
         %FINISH
         %IF LCON&RCON # 0 %AND OPER # RDIV %START
            COP(OPER, LH_DISP, RH_DISP);  DROP(RH);  %RETURN
         %FINISH
         %IF LCON # 0 %AND COMM(OPER) # 0 %START
            SWOP
            PICKUP(LH) %IF LH_LOP # 0
         %FINISH
         %IF RCON # 0 %AND (OPER = AND %OR OPER = RSH) %C
                %AND (CONTROL&UNASS DIAG = 0 %OR LH_TYPE = SHORT) %START
            OPTIMISE(LH)
            %IF LH_FORM # V IN R %AND (LH_TYPE = INTEGER %OR  %C
                                           LH_TYPE = SHORT) %START
               ADDRESS(LH)
               %IF OPER = AND %START
                  S = LH_TYPE;  D = 0
                  D = REGLEN//2 %IF LH_TYPE = INTEGER
                  %IF RH_DISP = 255 %START
                     S = BYTE;  D = D + REGLEN//4
                  %ELSE %IF RH_DISP>>16 = 0
                     RH_DISP = RH_DISP!X'FFFF0000' %IF RH_DISP>>15#0
                     LH_TYPE = UNSIGNED HALFWORD
                     LH_DISP = LH_DISP+D
                     D = -1
                  %ELSE
                     D = -1
                  %finish
                  %IF D >= 0 %START
                     LH_TYPE = S;  LH_DISP = LH_DISP + D
                     DROP(RH);  %RETURN
                  %FINISH
               %ELSE;                !...'OPER' MUST BE RSH
                  %IF RH_DISP = (8*REGLEN)//2 %C
                     %AND LH_TYPE # SHORT %START
                     S = UNSIGNED HALFWORD
                  %ELSE %IF RH_DISP = 8*(REGLEN-1)
                     S = BYTE
                  %ELSE
                     S = -1
                  %finish
                  %IF  S >= 0 %START
                     LH_TYPE = S;  DROP(RH);  %RETURN
                  %FINISH
               %FINISH
            %FINISH
         %FINISH
         PICKUP(RH) %IF RH_LOP # 0
         %IF LCON!RCON # 0 %AND OPER = MUL %START
            SWOP %IF LCON # 0
            %IF FLOATING(LH) %THEN KEY = -1 %C
                              %ELSE KEY = POWER(RH_DISP)
            %IF KEY >= 0 %START
               RH_DISP = KEY;  OPER = LSH
            %ELSE
               SWOP
            %FINISH
         %FINISH
         DROP(RH) %AND %RETURN %IF RCON # 0 %AND RH_DISP = NULL OP(OPER)
         LH_LOP = OPER;  LH_LINK == RH
      %END
      %PREDICATE DIFFERENT(%RECORD(STACKFM)%NAME A, B)
         %WHILE %NOT B == NULL %CYCLE
            %FALSE %IF SAME(A, B)
            B == B_LINK
         %REPEAT
         %TRUE
      %END
      %ROUTINE ASSIGN(%INTEGER ASSOP)
         %RECORD(STACKFM)%NAME LHS, RHS, W
         %RECORD(STACKFM) TEMP, HOLD
         %INTEGER N, P, T, OP, VAL, SIZE
         ABORT(8) %IF STP < 2
         RHS == STACKED(STP)_V
         LHS == STACKED(STP-1)_V
         %IF ASSOP < 0 %START
            %IF LHS_BASE = LINK %START;! INTRINSIC
               TEMP = LHS;  LHS = RHS;  RHS = TEMP
               NEW DISP = 0
               %RETURN
            %FINISH
            LHS_EXTRA = LHS_EXTRA-1
            V == VAR(LHS_EXTRA)
            DISPLAY VAR(V) %IF CONTROL < 0
            VSTACK(V);  LHS == STACKED(STP)_V
            ASSOP = 0 %IF V_FORM > 1
            NEW DISP = LHS_DISP+LHS_LENGTH
            %IF LHS_FORM&16 # 0 %START;! PROCEDURE PARAMETER
               FORGET(LINK);  HAZARD(R0)
               NEW DISP = LHS_DISP+2*REGLEN
               %IF RHS_DISP&X'4000' # 0 %START
                  RX(ST, WSP, WSP, LHS_DISP);! ENVIRONMENT REF
                  DEFINE REFERENCE(RHS_DISP&X'FFF', R REF)
                  RX(LA, LINK, CODE, 0);       !  ADDRESS OF ROUTINE
                  RX(ST, LINK, WSP, LHS_DISP+REGLEN);  ! ENVIRONMENT
               %ELSE
                  RX(LW, LINK, RHS_BASE, RHS_DISP)
                  RX(ST, LINK, WSP, LHS_DISP)
                  RX(LW, LINK, RHS_BASE, RHS_BASE+REGLEN)
                  RX(ST, LINK, WSP, LHS_DISP+REGLEN)
               %FINISH
               DROP(RHS);  DROP(LHS)
               STP = STP-2
               %RETURN
            %FINISH
         %FINISH
         %IF LHS_DV < 0 %AND CONTROL&ARRAYDIAG # 0 %START;! ARRAYNAME
            LHS_DV = 0
            HOLD = LHS;  TEMP = RHS
            HOLD_DISP = HOLD_DISP+4
            %IF TEMP_DV < 0 %START
               TEMP_DISP = TEMP_DISP+4;  TEMP_FORM = A IN S
            %ELSE
               TEMP_BASE = GLA;  TEMP_DISP = TEMP_DV
               TEMP_FORM = V IN S
            %FINISH
            SSTACK(HOLD);  SSTACK(TEMP)
            ASSIGN(0)
         %FINISH
         STP = STP-2
         %IF LHS_TYPE = 10 %START;! NAME PARAMETER
            ABORT(15) %UNLESS ASSOP = 0
            T = RHS_TYPE<<13!(RHS_LENGTH&X'1FFF')
            AMAP(RHS);  LRD(RHS, ANY)
            RX(ST, RHS_BASE, LHS_BASE, LHS_DISP)
            RI2(LHI, RHS_BASE, 0, T)
            CLAIM(LHS_BASE); RX(ST, RHS_BASE, LHS_BASE, LHS_DISP+REGLEN)
            FORGET(RHS_BASE)
            DROP(LHS)
            %RETURN
         %FINISH
         %IF ASSOP = 0 %START
            DUMP STRING(0) %IF RHS_TYPE = STRING %AND RHS_FORM = CONSTANT
            AMAP(LHS);  AMAP(RHS)
         %FINISH
         %IF LHS_TYPE = RECORD %START
            AMAP(LHS);  LOAD(LHS, R2)
            N = LHS_LENGTH>>1
            %IF RHS_TYPE = RECORD %START
               AMAP(RHS);  LOAD(RHS, R1);  RELEASE(R1)
               P = R COPY
            %ELSE
               P = R CLEAR
            %FINISH
            DROP(RHS);  DROP(LHS)
            CSTACK(N);  STP = STP-1;  LRD(STACKED(STP+1)_V, R0)
            RELEASE(R2)
            PERM(P)
            %RETURN
         %FINISH
         %IF LHS_TYPE = 15 %START;        ! STRING PARAM (FINAL)
            %IF RHS == ACTIVE STRING %START
               HAZARD(R1)
               RHS_BASE = 17;  REMEMBER(R1, RHS);  ! DISCRIMINATE
               ACTIVE STRING == NULL
               T = NEW TAG;  DEFINE REFERENCE(T, R REF)
               RX(BAL, R1, CODE, T)
               N = 0
               %CYCLE
                  DUMP(CURRENTSTRING(N)<<8+CURRENTSTRING(N+1))
                  N = N+2
                  %EXIT %IF N > CSLEN
               %REPEAT
               CSLEN = 0
               DEFINE TAG(T)
               RHS_FORM = V IN S;  RHS_BASE = R1;  RHS_DISP = 0
               CLAIM(R1)
            %FINISH
            DUMP STRING(0)
            WDISP = 44 %IF WDISP = 0
            LRD(RHS, R1)
            DROP(LHS)
            %RETURN
         %FINISH
         %IF LHS_TYPE = STRING %START
            SIZE = LHS_LENGTH-1
            SIZE = 0 %IF SIZE < 0 %OR SIZE = 255 %OR CONTROL&ASSDIAG=0
            DUMP STRING(-1)
            %IF RHS_FORM = CONSTANT %START;! NULL STRING!!
               RHS_TYPE = INTEGER;  LHS_TYPE = BYTE
            %ELSE
               WDISP = WDISP-256 %IF RHS_TYPE = 0
               %IF RHS_LOP # 0 %AND SIZE = 0 %START
                  W == RHS_LINK;  RHS_LOP = 0
                  %IF SAME(LHS, RHS) %AND DIFFERENT(LHS, W) %START;! S = S.T
                     RELEASE(LHS_BASE)
                     LOAD(LHS, R2);  RELEASE(R2)
                     DROP(RHS);  JOIN(W)
                     DROP(LHS)
                     %RETURN
                  %FINISH
                  %IF DIFFERENT(LHS, W) %START;  ! S = P.Q
                     LRD(RHS, R1);  LRD(LHS, R2);  PERM(CONC1)
                     JOIN(W)
                     %RETURN
                  %FINISH
                  RHS_LOP = CONC
               %FINISH
               WDISP = 44 %IF WDISP = 0 %AND LHS_BASE = WSP
               LRD(RHS, R1);  LRD(LHS, R2)
               %IF SIZE # 0 %START
                  CSTACK(SIZE);  STP = STP-1;  LRD(STACKED(STP+1)_V, R0)
                  PERM(STRING ASS)
               %FINISH
               PERM(SMOVE)
               %RETURN
            %FINISH
         %FINISH
         ADDRESS(LHS)
         %IF (LHS_TYPE = INTEGER %AND CONTROL&UNASS DIAG = 0) %C
         %OR LHS_TYPE = SHORT %START
            %IF RHS_LOP = ADD %START
               T = ADD;  T = SADD %IF SAME(LHS, RHS)
               RHS_LOP = 0;  OPTIMISE(RHS);  RHS_LOP = T
               %IF SAME(LHS, RHS) %START
                  W == RHS_LINK
                  LOAD(W, ANY)
                  RELEASE(LHS_BASE)
                  CCV = LHS;  CCREG = -2
                  %IF LHS_TYPE = SHORT %THEN P = AHM %C
                                       %ELSE P = AM
                  RX(P, W_BASE, LHS_BASE, LHS_DISP)
                  PERM(ASSTH) %IF CONTROL&ASSDIAG # 0 %C
                                   %AND P = AHM
                  FORGET DEST(LHS)
                  RELEASE(W_BASE)
                  DROP(RHS);  DROP(W);  DROP(LHS)
                  CCCA = CA
                  %RETURN
               %FINISH
            %FINISH
         %FINISH
         %IF LHS_BASE = PARAM %START
            NEW DISP = 0
            P = LHS_DISP
            LOAD(RHS, P) %IF RHS_LOP # 0;  DROP(LHS)
            LHS == STACKED(STP)_V
            RHS_LINK == LHS_LINK;  RHS_LOP = LHS_LOP
            LHS_LINK == RHS;  LHS_LOP = P
         %ELSE
            P = ANY;  VAL = 0
            %IF LHS_TYPE = INTEGER %START
               OP = ST
            %ELSE %IF LHS_TYPE = SHORT
               OP = STH;  VAL = X'FFFF';  T = ASSTH
            %ELSE %IF LHS_TYPE = BYTE
               OP = STB;  VAL = 255;      T = ASSTB
            %ELSE
               OP = STE;  P = ANYF
            %FINISH
            %IF VAL # 0 %START;          ! POSSIBLE TEST REQUIRED
               %IF RHS_LOP = 0 %START
                  VAL = 0 %IF (VAL = X'FFFF' %AND RHS_TYPE # INTEGER) %C
                        %OR RHS_TYPE = BYTE
               %ELSE %IF RHS_LOP = AND
                  %IF RHS_LINK_FORM=CONSTANT %AND RHS_LINK_DISP=VAL %START
                     DROP(RHS_LINK)
                     RHS_LOP = 0;  VAL = 0;   ! DISPENSE WITH TEST
                  %FINISH
               %FINISH
            %FINISH
            %IF CONTROL&ASSDIAG # 0 %AND RHS_FORM = CONSTANT %START
               VAL = 0 %IF VAL = 255 %AND RHS_DISP>>8 = 0
               VAL = 0 %IF VAL = X'FFFF' %C
                              %AND X'FFFF8000'<=RHS_DISP<=X'10000'
            %FINISH
            LOAD(RHS, P)
            FORGET DEST(LHS)
            RX(OP, RHS_BASE, LHS_BASE, LHS_DISP);  CCCA = CCCA+4
            REMEMBER(RHS_BASE+STORE, LHS);            !MOVED ONE LINE DOWN??
            %IF VAL = 0 %OR CONTROL&ASSDIAG = 0 %START;! NO STORE TEST
               RELEASE(RHS_BASE)
            %ELSE
               %IF T = ASSTH %START
                  RR(CHVR, RHS_BASE, RHS_BASE)
               %ELSE
                  HAZARD(R0)
                  RR(LBR, R0, RHS_BASE)
                  CLAIM(RHS_BASE);  RR(CR, R0, RHS_BASE)
               %FINISH
               PERM(T)
            %FINISH
            DROP(RHS);  DROP(LHS)
         %FINISH
      %END
      %ROUTINE ARRAY REF
         %RECORD(STACKFM)%NAME A
         %ownRECORD(STACKFM) T=0   {to prevent unassigned problems}
         %INTEGER R, D
         SET BOTH
         T_BASE = CODE
         A == LHS
         REDUCE(A) %IF A_FORM > V IN S %AND A_FORM # AV IN S
         D = 0
         %IF RHS_LOP=ADD %AND CONST(RHS_LINK) %START
            D = RHS_LINK_DISP*A_LENGTH
            RHS_LOP = 0
            DROP(RHS_LINK)
         %FINISH
         %IF A_FORM = V IN S %START
            %IF RHS_LOP = 0 %AND A_LENGTH <= 256 %START
               ADDRESS(RHS) %UNLESS RHS_FORM = CONSTANT
               T_BASE = RHS_BASE+A_BASE<<8
               T_DISP = RHS_DISP
               T_TYPE = A_LENGTH
               T_FORM = RHS_FORM ! 128
               R = FIND USE(T_TYPE, T_FORM, T_BASE, T_DISP)
               %IF R # 0 %START
                  STP = STP-1
                  A_BASE = R;  A_DISP = A_DISP+D;  A_FORM = V IN S
                  DROP(RHS)
                  %RETURN
               %FINISH
            %FINISH
         %FINISH
         CSTACK(A_LENGTH)
         OPERATE(MUL);  LHS == STACKED(STP)_V
         SSET(A_BASE, A_DISP, V IN S, 0)
         %IF A_FORM = V IN S %START;! ARRAY
            D = D+RHS_DISP;  RHS_DISP = 0
            RHS_FORM = V IN R
         %FINISH
         %IF CONST(LHS) %START
            LOAD(RHS, ANY0) %IF RHS_FORM = V IN S
            D = D+LHS_DISP;  LHS_BASE = RHS_BASE
            STP = STP-1
         %ELSE %IF RHS_BASE = 0 %AND RHS_FORM = V IN R
            LOAD(LHS, ANY0)
            STP = STP-1
         %ELSE
            OPERATE(ADD);  LHS == STACKED(STP)_V;  RHS == LHS
         %FINISH
         LOAD(LHS, ANY0) %IF LHS_LOP # 0
         STP = STP-1
         REMEMBER(LHS_BASE, T) %IF LHS_FORM = V IN R
         A_FORM = V IN S;  A_BASE = LHS_BASE;  A_DISP = D
         %IF D < 0 %START
            R = A_TYPE;  AMAP(A);  LOAD(A, ANY0)
            A_TYPE = R;  A_FORM = V IN S
         %FINISH
         DROP(RHS) %UNLESS RHS == LHS
         DROP(LHS)
      %END
      %ROUTINE CHECKED ARRAY REF
         %INTEGER D, FLAG
         SET BOTH;  STP = STP-2
         REDUCE(LHS) %IF LHS_FORM > V IN S %AND LHS_FORM # AV IN S
         LRD(RHS, R1)
         HAZARD(R2);  FORGET(R2)
         %IF LHS_DV < 0 %START
            FLAG = 0;  D = 0;  RX(LW, R2, LHS_BASE, LHS_DISP+REGLEN)
            CLAIM(LHS_BASE)
         %ELSE
            FLAG = 1;  D = LHS_DISP;  RI2(LHI, R2, GLA, LHS_DV)
         %FINISH
         PERM(A REF);  FORGET(R1)
         %IF FLAG # 0 %START
            RR(AR, R1, LHS_BASE)
         %ELSE
            RX(AW, R1, LHS_BASE, LHS_DISP)
         %FINISH
         LHS_BASE = R1;  LHS_DISP = D;  LHS_FORM = V IN S;  LHS_DV = 0
         SSTACK(LHS)
         DROP(LHS)
      %END
      %ROUTINE KNOW(%INTEGER REG, VALUE, TYPE)
         KNOWN_BASE = REG+STORE;  KNOWN_DISP = VALUE
         KNOWN_TYPE = TYPE
         KNOWN_CA = 0 %IF USE(KNOWN_BASE)_CA < LIMEN %C
                      %OR USE(KNOWN_BASE)_CA = USE(KNOWN_BASE-STORE)_CA
      %END
      %ROUTINE TEST ZERO(%RECORD(STACKFM)%NAME V)
         %RECORD(STACKFM)%NAME W
         %INTEGER OP, COP, CR, CT, NOT
         NOT = NEXTSYMBOL-'#'
         OP = V_LOP
         COP = LR ;  CR = ANY;  CT = INTEGER
         %IF FLOATING(V) %START
            COP = LER;  CR = ANYF;  CT = REALS
         %ELSE %IF OP # 0 %AND SYM = '?'
            W == V_LINK;  V_LOP = 0
            %IF OP = AND %AND (W_FORM = CONSTANT %OR W_FORM = V IN R) %C
                                             %START
               %IF V_FORM # V IN R # W_FORM %AND V_TYPE = INTEGER %START
                  %IF W_DISP&X'FFFF' = 0 %OR W_DISP>>16 = 0 %START
                     ADDRESS(V)
                     V_TYPE = UNSIGNED HALFWORD
                     W_TYPE = UNSIGNED HALFWORD
                     %IF W_DISP&X'FFFF' = 0 %START
                        W_DISP = W_DISP>>16
                     %ELSE
                        V_DISP = V_DISP+2
                     %FINISH
                  %FINISH
               %FINISH
               LOAD(V, ANY)
               W_DISP = 0 %AND W_TYPE = 0 %IF W_FORM = V IN R
               %IF -X'8000' <= W_DISP <= X'7FFF' %C
                  %OR W_TYPE = UNSIGNED HALFWORD %START
                  RI2(THI,V_BASE,W_BASE,W_DISP)
               %ELSE
                  RI3(TI,V_BASE,W_BASE,W_DISP)
               %FINISH
               RELEASE(V_BASE);  DROP(W)
               %RETURN
            %FINISH
            %IF W_FORM = CONSTANT %AND OP = ADD %C
                           %AND (W_DISP < -15 %OR W_DISP > 15) %START
               W_DISP = -W_DISP
               COMPARE(V, W);  DROP(W)
               %RETURN
            %FINISH
            V_LOP = OP
         %FINISH
         %IF OP = 0 %AND CCCA = CA %AND LIMEN # CA %START
            %IF CCREG < 0 %AND SAME(CCV, V) %START
               RELEASE(V_BASE);  %RETURN
            %FINISH
            OPTIMISE(V)
            %IF V_FORM = V IN R %AND V_BASE = CCREG %START
               RELEASE(V_BASE)
               KNOW(V_BASE, 0, CT) %IF NOT = 0
               %RETURN
            %FINISH
         %FINISH
         LOAD(V, CR)
         %UNLESS CCREG = V_BASE %AND CCCA = CA %START
            RR(COP, V_BASE, V_BASE)
         %ELSE
            RELEASE(V_BASE)
         %FINISH
         KNOW(V_BASE, 0, CT) %IF NOT = 0
      %END
      %ROUTINE COMPARE REALS(%RECORD(STACKFM)%NAME L, R)
         %RECORD(STACKFM) H
         FLOAT(L, ANYF) %UNLESS L_TYPE = REALS
         FLOAT(R, ANYF) %UNLESS R_TYPE = REALS
         LOAD(L,ANYF) %IF L_LOP # 0
         LOAD(R,ANYF) %IF R_LOP # 0
         %IF L_FORM # V IN R %AND R_FORM = V IN R %START
            H = L;  L = R;  R = H
            INVERT = INVERT!!6;  SWOPPED = SWOPPED!!1
         %FINISH
         LOAD(L, ANYF)
         LOAD(R, ANYF) %IF CONTROL&UNASS DIAG # 0
         ADDRESS(R)
         %IF R_FORM = V IN R %START
            RR(CER, L_BASE, R_BASE)
         %ELSE
            RX(CE, L_BASE, R_BASE, R_DISP)
         %FINISH
         RELEASE(L_BASE)
      %END
   %ROUTINE COMPARE STRINGS(%RECORD(STACKFM)%NAME L, R)
      %ROUTINE TEST NULL(%RECORD(STACKFM)%NAME R)
         ACTIVE STRING == NULL
         LOAD(R, ANY) %IF R_LOP # 0
         R_TYPE = BYTE
         TEST ZERO(R)
      %END
      SDISP = 256 %IF L_TYPE = 0 %OR R_TYPE = 0 %C
                  %OR L_LOP # 0 %OR R_LOP # 0
      %IF CSLEN = 0 %START
         %IF R_FORM = CONSTANT %START
            TEST NULL(L);  L_TYPE = STRING;  L_FORM = V IN S;  %RETURN
         %FINISH
         %IF L_FORM = CONSTANT %START
            TEST NULL(R);  INVERT = INVERT!!6;  %RETURN
         %FINISH
      %FINISH
      DUMP STRING(0)
      LOAD(R, R1);  LOAD(L, R2);  LOAD(R, R1);! IN CASE OF HAZARD!
      RELEASE(R1);  RELEASE(R2)
      PERM(SCOMP)
      L_TYPE = STRING;  L_FORM = V IN S
      WDISP = 0
   %END
      %ROUTINE COMPARE(%RECORD(STACKFM)%NAME L, R)
         %RECORD(STACKFM) T
         %INTEGER OP, ARITH
         %PREDICATE CHANCED
            %FALSE %UNLESS L_LOP = ADD %AND SYM # 126
            %FALSE %UNLESS L_LINK_FORM = CONSTANT %AND L_BASE # 0
            %FALSE %UNLESS -X'8000' <= L_LINK_DISP <= X'7FFF'
            %FALSE %IF L_TYPE = REALS
            INVERT = INVERT!!6;  SWOPPED = SWOPPED!!1
            T = L;  L = R;  R = T
            R_LOP = 0
            LOAD(L, ANY)
            LOAD(R, ANY0)
            %IF -X'8000' <= R_LINK_DISP <= X'7FFF' %START
               %IF ARITH # 0 %THEN OP = CLHI %ELSE OP = CHI
               RI2(OP,L_BASE,R_BASE,R_LINK_DISP)
            %ELSE
               %IF ARITH # 0 %THEN OP = CLI %ELSE OP = CI
               RI3(OP,L_BASE,R_BASE,R_LINK_DISP)
            %FINISH
            RELEASE(L_BASE)
            DROP(R_LINK)
            %TRUE
         %END
         SWOPPED = 0;  SDISP = 0
         %IF LHS_TYPE = 0 %OR LHS_TYPE = STRING %START
            COMPARE STRINGS(L, R);  %RETURN
         %FINISH
         %IF ZERO(R) %START
            TEST ZERO(L);  %RETURN
         %FINISH
         %IF ZERO(L) %START
            TEST ZERO(R);  INVERT = INVERT!!6;  %RETURN
         %FINISH
         ARITH = NEXTSYMBOL
         ARITH = 0 %IF ARITH # '#' %AND ARITH # '=' %AND SYM # 'F'+32
         %RETURN %IF CHANCED
         OPTIMISE(R);  OPTIMISE(L)
         COMPARE REALS(L ,R) %AND %RETURN %IF FLOATING(L) %OR FLOATING(R)
         %IF CONST(L) %OR R_FORM = V IN R %OR L_TYPE = BYTE %C
                      %OR R_LOP # 0 %START
            T = L;  L = R;  R = T
            INVERT = INVERT!!6;  SWOPPED = SWOPPED!!1
            %RETURN %IF CHANCED
         %FINISH
         LOAD(L, ANY)
         %IF R_LOP # 0 %OR R_TYPE = BYTE %OR R_TYPE = UNSIGNED HALFWORD %C
            %OR (CONTROL&UNASS DIAG # 0 %AND (R_FORM=VINS %OR %C
                  R_FORM=AVINS)) %START
            LOAD(R, ANY)
         %FINISH
         REDUCE(R) %IF R_FORM = AV IN REC
         %IF (R_FORM = CONSTANT %OR R_FORM = AV IN S) %START
            %IF -X'8000' <= R_DISP <= X'7FFF' %START
               %IF ARITH # 0 %THEN OP = CLHI %ELSE OP = CHI
               RI2(OP,L_BASE,R_BASE,R_DISP)
            %ELSE
               %IF ARITH # 0 %THEN OP = CLI %ELSE OP = CI
               RI3(OP,L_BASE,R_BASE,R_DISP)
            %FINISH
            KNOW(L_BASE, R_DISP, INTEGER) %IF R_FORM = CONSTANT %C
                                        %AND ARITH = '#'
         %ELSE
            ADDRESS(R)
            %IF R_FORM = V IN R %START
               %IF ARITH # 0 %THEN OP = CLR  %ELSE OP = CR
               RR(OP, L_BASE, R_BASE)
            %ELSE
               %IF R_TYPE = BYTE %START
                  OP = CLB
               %ELSE %IF ARITH # 0
                  %IF R_TYPE = SHORT %THEN OP = CLH %ELSE OP = CL
               %ELSE
                  %IF R_TYPE = SHORT %THEN OP = CH %ELSE OP = C
               %FINISH
               RX(OP, L_BASE, R_BASE, R_DISP)
            %FINISH
         %FINISH
         RELEASE(L_BASE)
      %END
      %ROUTINE CLAIM WSP(%INTEGERNAME SIZE)
         SIZE = (WDISP+(REGLEN-1))&(\(REGLEN-1));  %RETURN %IF SIZE = 0
         WDISP = 0
         RI2(AHI, WSP, 0, SIZE) %IF SIZE > 15
      %END
      %ROUTINE RELEASE WSP(%INTEGER SIZE)
         WDISP = SIZE
         RI2(SHI, WSP, 0, WDISP) %IF WDISP > 15
      %END
      %ROUTINE HEADER(%RECORD(VARFM)%NAME V)
         LIMEN = CA-2
         FRAME = 11*REGLEN %IF FRAME < 11*REGLEN
         DEFINE TAG(V_DISP&X'FFF') %UNLESS V == BEGIN
         RX(STM, P2, WSP, 0)
         RR(LR , LOCAL, WSP)
         %IF CONTROL&(UNASS DIAG!STKDIAG) # 0 %START
            %IF CONTROL&UNASS DIAG # 0 %START
               PERM(EXBUNASS);  DUMP(FRAME)
            %ELSE
               PERM(EXB)
            %FINISH
         %ELSE
            DUMP(AHI+ACTUAL(WSP)<<4)
         %FINISH
         SIZE PATCH = CA
         DUMP(0)
      %END
      %ROUTINE RETURN
         %RETURN %IF UNCOND JUMP = CA
         RX(LM, WSP, LOCAL, 2*REGLEN)
         CLAIM(LINK);  RR(BFCR, 0, LINK)
         UNCOND JUMP = CA
      %END
      %ROUTINE CALL(%RECORD(STACKFM)%NAME V)
         %SWITCH B(0:15)
         %OWNINTEGER INT G = 0, FRACPT G = 0
         %INTEGER WORK, AWORK, REG, AREG
         %INTEGER ADDR, T, L
         %INTEGERFN SET(%INTEGER H, L)
            GFIX(4)
            GHALF(H);  GHALF(L)
            %RESULT = GA-4
         %END
         ADDR = V_DISP
         %IF ADDR < 0 %START
            PERM(X'1EF00'-ADDR)
         %ELSE
            %IF V_BASE = LINK %START;      ! INTRINSIC
               V_DV = 0;  DROP(V)
               SET LHS
               L = 0;  T = V_DISP;  SYM = 0
               ->B(T)
B(12):! FRACPT
               LOAD(LHS, ANYF)
               REG = LHS_BASE;  AREG = ACTUAL(REG)
               WORK = FPR;      AWORK = ACTUAL(WORK)
               DUMP(LER+AWORK<<4+AREG)
               %IF FRACPT G = 0 %START
                  FRACPT G = SET(X'4600', 0);  ! UNNORM. ZERO
                  ADDR = SET(X'4110', 0);! 1.0
               %FINISH
               DUMP(AE+AWORK<<4+ACTUAL(GLA));  DUMP(FRACPT G)
               DUMP(LER+AWORK<<4+AWORK)
               DUMP(SER+AREG<<4+AWORK)
               DUMP(X'2313');     ! BNMFS .+3
               DUMP(AE+AREG<<4+ACTUAL(GLA));  DUMP(FRACPT G+4)
               FORGET(REG);  FORGET(WORK)
               %RETURN
B(11):! INT
               INT G = SET(X'4080', 0) %IF INT G = 0;!  =0.5
               STACK(INT G, GLA, REALS, 1, 0, 0, 0);  OPERATE(ADD)
               SET LHS
B(10):! INTPT
               LOAD(LHS, ANYF)
               L = GPR(0);   RR(FXR, L, LHS_BASE)
               CLAIM(L);  LHS_BASE = L;  LHS_TYPE = INTEGER
               %RETURN
B(0):! ADDR
               AMAP(LHS);  %RETURN
B(7):! LENGTH
               CSTACK(0)
B(8):! CHARNO
               SET BOTH
               LHS_TYPE = BYTE;  LHS_LENGTH = 1;  ARRAY REF
               %RETURN
B(4):! STRING
               L = 255
B(1):! INTEGER
B(2):! BYTEINTEGER
B(3):! SHORTINTEGER
B(5):! RECORD
B(6):! REAL
               VMAP(LHS);  LHS_TYPE = T;  LHS_LENGTH = L
               %RETURN
B(9):! REM
               SET BOTH
               OPERATE(REM);  %RETURN
B(13):! READSYMBOL
               LIMEN = CA;            !SPECIALLY HERE
               PERM(RSYM);  CLAIM(R1)
               SSET(R1, 0, V IN R, 0)
               ASSIGN(1);  %RETURN
B(14):! TOSTRING
               CSTACK(255);  OPERATE(AND)
               CSTACK(256);  OPERATE(ADD)
               SET LHS
               %IF CONST(LHS) %START
                  GFIX(2);  ADDR = GA;  GHALF(LHS_DISP)
                  LHS_TYPE = STRING;  LHS_FORM = V IN S
                  LHS_BASE = GLA;  LHS_DISP = ADDR
               %ELSE
                  SSTACK(LHS);  SET BOTH
                  LHS_LOP = 0;  RELEASE(LHS_BASE)
                  FRAME = (FRAME+1)&(\1)
                  LHS_TYPE = SHORT;  LHS_FORM = V IN S
                  LHS_BASE = LOCAL;  LHS_DISP = FRAME
                  ASSIGN(1)
                  SSET(LOCAL, FRAME, V IN S, 0);  RHS_TYPE = STRING
                  FRAME = FRAME+2
               %FINISH
               %RETURN
B(15):! SVC(N, P)
               SET BOTH;  STP = STP-2
               REG = 0;  WORK = LHS_DISP
               %UNLESS CONST(LHS) %START
                  LOAD(LHS, ANY0);  WORK = 0;  REG = LHS_BASE
               %FINISH
               ADDRESS(RHS)
               RX(LME, FPR0, RHS_BASE, RHS_DISP)
               RX(SVC, 0, REG, WORK)
               CLAIM(RHS_BASE)
               RX(STME, FPR0, RHS_BASE, RHS_DISP)
               DROP(RHS);  DROP(LHS)
               LIMEN = CA;   !FORGET EVERYTHING
               %RETURN
            %FINISH
            HAZARD ALL
            %IF ADDR&X'4000' = 0 %START;   ! PARAMETER
               ADDR = NEW TAG;  DEFINE REFERENCE(ADDR, R REF)
               RX(LA, LINK, CODE, 0);! RETURN ADDRESS
               RX(STM, P2, WSP, 0)
               RX(LW, R2, V_BASE, V_DISP)
               RX(LW, R3, V_BASE, V_DISP+REGLEN)
               CLAIM(R2);  RX(LM, R9, R2, 4*REGLEN)
               CLAIM(R3);  RX(BAL, LINK, R3, 4)
               DEFINE TAG(ADDR)
            %ELSE
               DEFINE REFERENCE(ADDR&X'FFF', R REF)
               RX(BAL, LINK, CODE, ADDR&X'FFF')
            %FINISH
            LIMEN = CA-1
         %FINISH
         DROP(V) %IF V_TYPE = 0
      %END
      %ROUTINE FOR
         %RECORD(STACKFM)%NAME CV, IV, INC, FV
         %INTEGER LAB, REG, SPECIAL
         %ROUTINE  STAB(%RECORD(STACKFM)%NAME  V,  %INTEGER  TYPE)
            %INTEGER T, R
            %RETURN %IF CONST(V)
            LOAD(V, ANY);  R = V_BASE
            T = TEMP;  RX(ST, R, LOCAL, T)
            RELEASE(R)
            V_BASE = LOCAL;  V_DISP = T
            V_TYPE = TYPE;  V_FORM = V IN S
            REMEMBER(R, V)
         %END
         %PREDICATE  CHECK REQD
         %INTEGER I
            %TRUE %UNLESS CONST(FV) %AND CONST(IV) %AND CONST(INC)
            %IF INC_DISP # 0 %START
               I = (FV_DISP - IV_DISP)//INC_DISP + 1
               %FALSE %IF I >= 0 %AND IV_DISP + (I-1)*INC_DISP = FV_DISP
            %FINISH
            ABORT(-12);    ! ...FAULTY, CONSTANT, %FOR PARAMETERS
            %TRUE;         ! ...INCLUDE RUN-TIME CHECK FOR SAFETY
         %END
         %ROUTINE  SET(%RECORD(STACKFM)%NAME  V, %INTEGER  REG)
         %RECORD(STACKFM)%NAME  R
            SSTACK(V);  R == STACKED(STP)_V
            LRD(R, REG)
            STP = STP-1
         %END

         SPECIAL = 0
         CV == STACKED(STP-3)_V
         IV == STACKED(STP-2)_V
         INC== STACKED(STP-1)_V
         FV == STACKED(STP  )_V
         SKIPSYMBOL;  LAB = TAG
         STAB(INC,INTEGER);  STAB(FV,INTEGER)
         %IF CONTROL&FORDIAG # 0 %AND CHECK REQD %START
            STAB(IV,INTEGER)
            SET(IV,R0);  SET(FV,R1);  SET(INC,R2)
            PERM(FORTEST)
         %FINISH
         %IF CV_FORM # V IN S %OR ACTIVITY(CV_BASE) >= 0 %START
            AMAP(CV)
            STAB(CV, CV_TYPE)
            CV_FORM = A IN S
         %FINISH
         SPECIAL = CONTROL&512 %IF CONST(FV) %AND CONST(INC) %C
                              %AND CONST(IV) %AND FV_DISP+INC_DISP # IV_DISP
         STP = STP-4
         SSTACK(CV);  SSTACK(IV);  RELEASE(IV_BASE);  SSTACK(INC)
         DROP(IV)
         OPERATE(SUB)
         %IF SPECIAL # 0 %START
            REG = GPR(0);  SET LHS;  LOAD(LHS, REG)
         %ELSE
            ASSIGN(1);    ! CV = CV-INC
         %FINISH
         DEFINE LABEL(LAB)
         %IF SPECIAL # 0 %START
            FLAB_BASE = CV_BASE;  FLAB_DISP = CV_DISP
            FLAB_REG = REG
            FLAB_LIMIT = FV_DISP
            SSTACK(INC);  OPERATE(ADD);  ASSIGN(1)
            USE(REG) = USE(REG+STORE);   ! REMEMBER CONTROL VAR
         %ELSE
            SSTACK(CV);  SSTACK(CV)
            COMPARE(CV, FV)
            JUMP TO(LAB-2, 0, REDEFINE)
            SSTACK(INC);  OPERATE(ADD);  ASSIGN(1)
         %FINISH
         DROP(CV);  DROP(FV);  DROP(INC)
      %END;        ! ... OF 'FOR'
      %ROUTINE  ADUMP
      %IF OWNTYPE = INTEGER  %START
         GWORD(OWNVAL)
      %ELSE %IF OWNTYPE = SHORT
         GHALF(OWNVAL)
      %ELSE %IF OWNTYPE = BYTE
         GBYTE(OWNVAL)
      %ELSE %IF OWNTYPE = STRING
         DUMP STRING(DATA SIZE)
      %ELSE %IF OWNTYPE = REALS
         GWORD(OWNVAL) %IF REALGA = GA
         REALGA = GA
      %ELSE
         GHALF(0) %FOR VAL = 1,1,DATA SIZE >> 1
      %FINISH
   %END

NEXT: READSYMBOL(SYM);  ->Z(SYM)
Z('O'):ABORT(14) %IF STP # 0
       ABORT(19) %UNLESS USING_LINK == NULL
       CHECK RELEASED
       SET LINE
       MIN TEMP = FRAME
       DIAG GLA = 0;  WDISP = 0
       %IF FRAME >= X'4000' %AND WARNING = 0 %START
WARN:     WARNING = -15;  ABORT(-15)
       %FINISH
       ->NEXT
Z('$'):DEFINE VAR;  ->NEXT
Z(98):APARM = TAG;    ! LOWER CASE 'B'
Z(119):STP = STP-2;    !  LOWER CASE 'W'
       VLB = STACKED(STP+1)_V_DISP
       VUB = STACKED(STP+2)_V_DISP
       DROP(STACKED(STP+1)_V);  DROP(STACKED(STP+2)_V)
      ! IMP SWITCH BOUNDS MUST BE AS BELOW -- POTENTIAL ALGOL PROBLEM???
       %IF VLB < -32768 %OR VUB > 32767 %START
          ABORT(-10);  VUB = 0;  VLB = 0
       %FINISH
       ->NEXT
Z('I'):VAL = (VUB-VLB+1)*DATA SIZE
       VAL = DATA SIZE %AND ABORT(-8) %IF VAL <= 0
       GBYTE(0) %FOR J = 1, 1, VAL
       ->NEXT
Z('A'):APARM = 1
       SKIPSYMBOL %AND APARM = TAG %IF NEXTSYMBOL = COMMA
       %IF OWNFORM = ARRAY %START
          OWNVAL = 0
          %IF STP # 0 %START
             POP LHS;  OWN VAL = LHS_DISP;  DROP(LHS)
          %FINISH
          %IF STP # 0 %START
             APARM = OWN VAL
             POP LHS;  OWNVAL = LHS_DISP;  DROP(LHS)
          %FINISH
          %IF OWNTYPE = REALS %START
             %IF LHS_TYPE = INTEGER %START
                REAL(ADDR(OWNVAL)) = OWNVAL
             %ELSE
                DECVAR_DISP = DECVAR_DISP-4
             %FINISH
          %FINISH
          APARM = VUB-VLB+1 %IF APARM = 0
          %IF APARM <= 0 %START
             VUB = VLB;  APARM = 1;  ABORT(-8)
          %FINISH
          %FOR J = 1, 1, APARM %CYCLE
             VLB = VLB+1
             ADUMP
          %REPEAT
       %ELSE
          OWNVAL = 0
          %IF STP # 0 %START
             POP LHS;  OWN VAL = LHS_DISP;  DROP(LHS)
          %FINISH
          NAMES = NAMES-APARM
          ->NEXT %IF OWNFORM = 5
          %FOR J = 1, 1, APARM %CYCLE
             NAMES = NAMES+1;  DEC VAR == VAR(NAMES)
             %IF OTYPE = 0 %START
                DECVAR_DISP = OWNVAL;  DECVAR_BASE = 0
                DECVAR_FORM = DECVAR_FORM-1
             %ELSE
                DECVAR_DISP = GA;  DECVAR_BASE = GLA
                %IF OWNTYPE = REALS %AND LHS_TYPE = REALS %START
                   DECVAR_DISP = DECVAR_DISP-4
                %FINISH
                ADUMP
             %FINISH
          %REPEAT
       %FINISH
       ->WARN %IF GA > X'4000' %AND WARNING = 0
       ->NEXT
Z(''''):GET STRING;  ->NEXT
Z('N'):LEN = TAG;  SKIPSYMBOL
       CSTACK(EVAL(LEN));  ->NEXT
Z('D'): RHS == DESCRIPTOR; FP CSTACK(REAL CONSTANT,RHS); -> NEXT

Z('@'):%IF NEXTSYMBOL = MINUS %START
          SKIPSYMBOL;  LEN = TAG;  SET LHS
          V == VAR(VAR(LHS_FORMAT)_EXTRA+LEN-1)
          DISPLAY VAR(V) %IF CONTROL < 0
          VSTACK(V);  SET BOTH
          STP = STP-1
          %IF LHS_FORM = V IN S %OR LHS_FORM = V IN REC %START
             RHS_DISP = LHS_DISP+RHS_DISP
             LHS_FORM = LHS_FORM-V IN S+RHS_FORM
          %ELSE %IF LHS_FORM = A IN REC
            LHS_FORM = V IN REC;  LHS_TYPE = INTEGER
            LOAD(LHS, ANY0)
            LHS_FORM = RHS_FORM
          %ELSE %IF LHS_FORM <= V IN R
             LHS_FORM = RHS_FORM
          %ELSE
             LHS_EXTRA = LHS_DISP
             LHS_FORM = RHS_FORM+2
          %FINISH
          LHS_DISP = RHS_DISP
          LHS_TYPE = RHS_TYPE;  LHS_LENGTH = RHS_LENGTH
          LHS_FORMAT = RHS_FORMAT;  LHS_DV = RHS_DV
          DROP(RHS)
       %ELSE
          V == VAR(LOOKUP(TAG))
          VSTACK(V)
          CLAIM WSP(LHS_DV) %IF LHS_FORM&16 # 0 %AND  %C
                            LHS_BASE # LINK %AND NEXTSYMBOL # 'P'+32
       %FINISH
       ->NEXT
Z('E'):POP LHS
       OPR = LHS_LOP;  LHS_LOP = 0;  J = 0
       %WHILE OPR # 0 %CYCLE
          X == LHS_LINK;  LHS_LINK == X_LINK
          N = X_LOP;  X_LOP = 0
          LOAD(X, OPR)
          DROP(X);  J = J<<8!OPR
          OPR = N
       %REPEAT
       RELEASE(J&255);  RELEASE(J>>8)
       X == LHS;  CALL(X);  DOPE = X_DV
       %IF X_TYPE # 0 %AND SYM # 0 %START;! FN/MAP
         SSTACK(X);  DROP(X);  SET LHS;  RELEASE(LHS_BASE)
          %IF LHS_TYPE = REALS %THEN OPR = FPR0 %ELSE OPR = R1
          LHS_BASE = OPR;  LHS_DISP = 0;  LHS_FORM = LHS_FORM&15
          CLAIM(OPR)
          %IF LHS_TYPE = STRING %AND LHS_FORM = V IN R %START
             LHS_FORM = V IN S
             SYM = NEXTSYMBOL
             %IF SYM # 'S' %AND SYM # 'P'+32 %AND SYM # '?' %START
                N = X_LENGTH;  N = 256 %IF N = 0
                FRAME = (FRAME+1)&(\1)
                LHS_FORM = V IN S;  LHS_BASE = LOCAL;  LHS_DISP = FRAME
                FRAME = FRAME+N
                SSET(LOCAL, LHS_DISP, V IN S, 0)
                RHS_TYPE = STRING;  RHS_LENGTH = N
                SSET(R1, 0, V IN S, 0);  RHS_TYPE = STRING
                ASSIGN(1)
             %FINISH
          %FINISH
       %FINISH
       RELEASE WSP(DOPE) %IF SYM # 0;  !NOT IF BUILT-IN
       ->NEXT
Z('R'):RETURN;  ->NEXT
Z('V'):POP LHS
      DUMP STRING(0)
       %IF GVAR_TYPE = REALS %THEN OPR = FPR0 %ELSE OPR = R1
       LRD(LHS, OPR);  RETURN;  ->NEXT
Z('M'):POP LHS;  AMAP(LHS);  LRD(LHS, R1);  RETURN;  ->NEXT
Z('T'):DUMP(X'2411');  RETURN;     !  *LIS R1, 1
       ->NEXT
Z('K'):DUMP(X'2410');  RETURN;     !  *LIS R1, 0
       ->NEXT
Z(97):%IF CONTROL&ARRAY DIAG # 0 %THEN CHECKED ARRAY REF %C
                                 %ELSE ARRAY REF
       ->NEXT
Z('.'):OPR = CONC;  ->ARITH
Z('+'):OPR = ADD;   ->ARITH
Z('-'):OPR = SUB;   ->ARITH
Z('!'):OPR = IOR;   ->ARITH
Z('%'):OPR = XOR;   ->ARITH
Z('&'):OPR = AND;   ->ARITH
Z('['):OPR = LSH;   ->ARITH
Z(']'):OPR = RSH;   ->ARITH
Z('*'):OPR = MUL;   ->ARITH
Z('/'):OPR = DIV;   ->ARITH
Z('Q'):OPR = RDIV;  ->ARITH
Z('U'):OPR = NEG;   ->ARITH
Z('\'):OPR = NOT;   ->ARITH
Z('X'):
Z(120):OPR = EXP;   ! LOWER CASE 'X'

ARITH: OPERATE(OPR);  ->NEXT

Z(118):SET LHS;    ! LOWER CASE 'V'
       CCREG = 0 %IF CCREG < 0
       %IF FLOATING(LHS) %THEN K = ANYF %ELSE K = ANY
       LOAD(LHS,K)
       TEST ZERO(LHS)
       K = LHS_BASE
       JUMP TO(3, 5, REDEFINE)
       CLAIM(LHS_BASE)
       OPERATE(NEG);  SET LHS
       LOAD(LHS,K)
       DEFINE LABEL(3)
       FORGET(LHS_BASE)
       ->NEXT

Z('S'):ASSIGN(1);  ->NEXT
Z('Z'):ASSIGN(0);  ->NEXT
Z(112):ASSIGN(-1);  WDISP = NEW DISP; ->NEXT;      ! LOWER CASE 'P'

Z(107):KNOW(R1, 1, INTEGER)
Z('='):OPR = 0;  ->COND;     !  LOWER CASE  'K'
Z(116):KNOW(R1, 0, INTEGER)
Z('#'):OPR = 1;  ->COND;       ! LOWER CASE 'T'
Z('<'):OPR = 2;  ->COND
Z('>'):OPR = 3;  ->COND
Z('('):OPR = 4;  ->COND
Z(')'):OPR = 5

COND:  VAL = TAG
       JUMP TO(VAL, OPR+INVERT, REDEFINE)
       ->NEXT
Z('C'):SET BOTH
       AMAP(LHS);  AMAP(RHS)
Z(126):! FIRST OF DOUBLE SIDED
Z('?'):SET BOTH
       COMPARE(LHS, RHS);  STP = STP-2
       DROP(RHS);  DROP(LHS)
       ->NEXT
Z('"'):ST WORK = STACKED(STP+SWOPPED+1)_V
       SSTACK(ST WORK)
       WDISP = SDISP
       ->NEXT
Z('_'):LIMEN = CA
       UNCONDJUMP = 0
       V == VAR(LOOKUP(TAG));  POP LHS;  DROP(LHS)
       GPATCH(CA, V_EXTRA+LHS_DISP*2)
       ->NEXT
Z('W'):V == VAR(LOOKUP(TAG))
       %IF CONTROL&TEST SWITCH # 0 %START
          HALF = GLA;  K = V_DISP
          RANGE(HALF, K)
          POP LHS;  LRD(LHS, R1)
          RI2(LHI, R2, HALF, K)
          PERM(SWJUMP)
       %ELSE
          CSTACK(1);  OPERATE(LSH)
          POP LHS;  LRD(LHS, ANY0)
          J = ACTUAL(LHS_BASE)
          DUMP(LHL+J<<4+ACTUAL(GLA))
          K = V_EXTRA
          DUMP(X'4000'+J<<8+K>>16&255)
          DUMP(K&X'FFFF')
          DUMP(AR+J<<4+ACTUAL(CODE))
          DUMP(BFCR+J)
          LIMEN = CA;  UNCOND JUMP = CA
       %FINISH
       ->NEXT
Z('B'):
Z(113):       ! LOWER CASE 'Q'
      JUMP TO(TAG, JUMP, DEFINE);  ->NEXT
Z('F'):
Z(117):      ! LOWER CASE 'U'
      JUMP TO(TAG, JUMP, REDEFINE);  ->NEXT
Z('J'):JUMP TO(-TAG, JUMP, DEFINE);  ->NEXT
Z('L'):DEFINE LABEL(-TAG);  ->NEXT
Z(':'):DEFINE LABEL(TAG);  ->NEXT
Z(102):FOR;  ->NEXT;      !  LOWER CASE 'F'

Z('P'):POP LHS;  DROP(LHS);    DUMP(LHS_DISP);  LIMEN = CA;  ->NEXT
Z(122):POP LHS;  DROP(LHS);  CONTROL = LHS_DISP
       %IF CONTROL&UNASS DIAG # 0 %START
          ACTIVITY(R4) = -1
          ABORT(-14) %IF ENTER UNASS = 0
       %FINISH %ELSE ACTIVITY(R4) = 0
       ->NEXT

Z(100):ABORT(-9) %IF TAG # 1;    ! LOWER CASE 'D'
       SET BOTH
       DOPE = 0
       %UNLESS CONST(LHS) %AND CONST(RHS) %START
          LOAD(LHS, P2);  LOAD(RHS, R3)
          DOPE = -FRAME;  FRAME = FRAME+12
          DYNAMIC = -1
       %ELSE
          DYNAMIC = 0
          VLB = LHS_DISP;  VUB = RHS_DISP
          ABORT(-7) %AND VUB = VLB %UNLESS VLB <= VUB
       %FINISH
       STP = STP-2
       DROP(RHS);  DROP(LHS)
       ->NEXT
Z(104):%IF DYNAMIC # 0 %START;   ! LOWER CASE 'H'
          %IF DYNAMIC < 0 %START
             RI2(LHI, P1, LOCAL, -DOPE)
BIG STATIC:  CSTACK(DATA SIZE);  POP LHS;  LRD(LHS, R1)
             RELEASE(P2);  RELEASE(R3)
             PERM(ASET)
             DYNAMIC = 1
          %FINISH
          DECVAR_FORM = ARRAYNAME;  DECVAR_DISP = FRAME
          FRAME = FRAME+8
          RI2(LHI, R3, LOCAL, DECVAR_DISP);  PERM(ALLOC)
       %ELSE
          %IF DOPE = 0 %START
             GFIX(4);  DOPE = GA
             GWORD(VLB);  GWORD(VUB);  GWORD(DATA SIZE)
          %FINISH
          K = (VUB-VLB+1)*DATA SIZE + FRAME
          %IF K > MAX STATIC %AND GMODE = 0 %START;    ! TOO BIG FOR LOCALS
             CSTACK(VLB);  CSTACK(VUB);  SET BOTH
             LOAD(LHS, P2);  LOAD(RHS, R3)
             DROP(RHS);  DROP(LHS);  STP = STP-2
             RI2(LHI, P1, GLA, DOPE);  FORGET(P1)
             DOPE = -DOPE
             -> BIG STATIC
          %FINISH
          DECVAR_DISP = FRAME-VLB*DATA SIZE
          FRAME = K
       %FINISH
       DECVAR_EXTRA = DOPE
Z(99):->NEXT;    ! LOWER CASE 'C'
Z('G'):READSYMBOL(GG)
       GMODE = \GMODE
       %IF GMODE # 0 %START
          ASSEMBLE(GTYPE, LABS, NAMES)
       %ELSE
          SPS = 0;  N = P1
          GVAR_LENGTH = (FRAME+(REGLEN-1))&(\(REGLEN-1)) %IF GG=FORMATS
          LEN = NAMES-GSTART
          J = 0;  J = LEN %IF GG = FORMATS
          %IF LEN > 0 %START
             LEN = 0
             GVAR_EXTRA = PARMS-J
             %FOR J = GSTART+1, 1, NAMES %CYCLE
                PARMS = PARMS-1
                FP == VAR(PARMS);  AP == VAR(J)
                FP = AP
                %IF GG # FORMATS %START
                   %IF FP_BASE = PARAM %START
                      AP_BASE = LOCAL;  FP_DISP = N
                      %IF GG = PROCEDURE %START
                         VSTACK(AP);  POP LHS;  DROP(LHS)
                         %IF LHS_FORM # V IN S %START
                            LHS_TYPE = INTEGER;  LHS_FORM = V IN S
                         %FINISH
                         REMEMBER(N, LHS)
                      %FINISH
                   %ELSE
                      FP_BASE = WSP;  N = P2
                   %FINISH
                %FINISH
                %IF CONTROL < 0 %START
                   DISPLAY VAR(FP);  DISPLAY VAR(AP)
                %FINISH
                N = N-1
             %REPEAT
             ABORT(-4) %IF PARMS <= NAMES
             %IF GG # FORMATS %START
                %IF FP_TYPE = STRING %AND FP_FORM = 1 %START
                   FP_TYPE = 15;  N = 0
                %FINISH
             %FINISH
          %FINISH
          ->OUT %IF GG # PROCEDURE
          HEADER(GVAR)
          %IF N = 0 %START
             RX(LHI, R2, LOCAL, AP_DISP)
             %IF CONTROL&ASSDIAG # 0 %AND AP_SIZE # 255 %START
                CSTACK(AP_SIZE);  POP LHS;  LRD(LHS, R0)
                PERM(STRING ASS)
             %FINISH
             PERM(SMOVE)
          %FINISH
       %FINISH
       ->NEXT
Z('H'):
       %IF CA = 0 %START;           ! INITIAL BEGIN
          ENTER UNASS = 0
          %IF CONTROL&UNASS DIAG # 0 %START
             ENTER UNASS = X'0140'+ACTUAL(CODE)
             DUMP(X'0234');  DUMP(X'0884');  DUMP(X'2401')
             DUMP(X'2410');  DUMP(X'2440')
             DUMP(X'583D');  DUMP(SIGNAL EP)
             DUMP(X'0303')
             DUMP(X'8080');  DUMP(X'8080')
             DUMP(X'8080');  DUMP(X'8080')
          %FINISH
          HEADER(BEGIN)
       %FINISH
       N = TEMP
       HALF = LOCAL;  K = N;  RANGE(HALF, K)
       RX(ST, WSP, HALF, K)
       DECVAR == BEGIN
       ASSEMBLE(0, LABS, NAMES)
       HALF = LOCAL;  K = N;  RANGE(HALF, K)
       RX(LW, WSP, HALF, K)
       ->NEXT

Z(115):                     ! LOWER CASE 'S'  -  %STOP
       CSTACK(0);  CSTACK(0)
Z(101):     !  LOWER CASE 'E' -- %SIGNAL EVENT,SUBEVENT,EXTRA
       N = STP+R0-1
       %WHILE STP # 0 %CYCLE
          POP LHS;  LRD(LHS, N-STP)
       %REPEAT
       PERM(MONITOR)
       UNCOND JUMP = CA;  STP = 0
       -> NEXT

Z(';'):%IF AMODE = 0 %START
          OLD FRAME = FRAME
       %ELSE
          PATCH((FRAME+(REGLEN-1))&(\(REGLEN-1)), SIZE PATCH)
          %IF UNCOND JUMP # CA %START
             %IF GVAR_TYPE # 0 %START
                ABORT(-11);       ! ...%RESULT MISSING
             %ELSE
                RETURN
             %FINISH
          %FINISH
       %FINISH
       SET DIAG(0, 0, 0, -1)
OUT:   FRAME = OLD FRAME
       %IF AMODE > 0 %START
          ACTIVITY(LOCAL) = 0
          ASS LEVEL = ASS LEVEL-1;  LOCAL = BASE REG(ASS LEVEL)
       %FINISH
       XLEVEL = XLEVEL-1
   %END;! OF ASSEMBLE


   FAULTY = 0

   ABORT(0) %IF MAX VARS = 1;    ! ----COMPILER CAN'T RUN AT ALL----

   SELECT INPUT(INSTREAM)
   SELECT OUTPUT(DIRECT);  PRINT SYMBOL(INIT GLA)
   SELECT OUTPUT(OBJECT);  PRINT SYMBOL(START)
   BLOCK WORD = 'B'-32+('L'-32)<<6+('O'-32)<<12 %C
                      +('C'-32)<<18+('K'-32)<<24
   CA = 0;  LIMEN = 0;  GA = INIT GLA;  DA = 0;  LINE SIZE = 0
   STP = 0;  STACK ASL = 0;  ENVP = 0;  GMODE = 0
   UNCOND JUMP = 0;  CURRENT LINE = 0
   INVERT = 0;  SWOPPED = 0
   PARMS = MAX VARS
   CSLEN == CURRENT STRING(0);  CSLEN = 0;  ACTIVE STRING == NULL
   ACTIVITY(J) = 0 %FOR J = 0, 1, 44
   USED(J) = 0 %FOR J = 0, 1,  20
   ACTIVITY(WSP) = -1;  ACTIVITY(GLA) = -1;  ACTIVITY(CODE) = -1
   ACTIVITY(0) = -1;  KNOWN_CA = -1
   ACTIVITY(R4) = -1 %IF CONTROL&UNASS DIAG # 0
   ENTER UNASS = -1
   ENVIR(J) = 0 %FOR J = 0, 1, MAX ENVIRS
   %for j = 1,1,44 %cycle
      use(j) = 0
      USE(J)_CA = -8
   %repeat
   %FOR J = 0, 1, MAX STACK-1 %CYCLE
      STAK(J)_LINK == STAK(J+1)
      DLIST(J)_LINK == DLIST(J+1)
   %REPEAT
   STAK(MAX STACK)_LINK == NULL;  DLIST(MAX STACK)_LINK == NULL
   DESC ASL == STAK(0);  DASL == DLIST(0)
   USING_LINK == NULL
   DECVAR == BEGIN

   ASSEMBLE(2, 0, 0);           ! ASSEMBLE THE OUTER BLOCK (+REST)

   GFIX(4)
   PRINTSYMBOL(CEND)
   SELECTOUTPUT(DIRECT);  PRINTSYMBOL(DEND)
   PUT(CA);  PUT((GA+1)&(\1));  PUT(LINE SIZE);  PUT(DA)

   %SIGNAL 15,3 %IF FAULTY # 0

%ENDOFPROGRAM
