         Edinburgh IMP77 Compiler - Version 8.4

    1  !! %option stack=40
    2  !!!!!!  19-Feb-82!!!! 26/6/78 - IMPASEMS412
    3  {Modified to run on new subsystem so that old supervisor can be supported}
    4  
    5  %own %integer FREE SPACE = 65536
    6  
    7  %OWNSTRING(4) P2VERSION = "4.13"
    8  
    9  
   10  !!!!!!%CONTROL 3;                     ! CHECK SWITCHES AND STACK LIMIT
   11  %BEGIN;                         ! INTERDATA 7/32 IMP ASSEMBLER !
   12  
   13  ! SIZE CONSTANTS
   14  
   15     %CONSTINTEGER MAX ENVIRS = 13
   16  !  %CONSTINTEGER MAX VARS   = 490
   17     %CONSTINTEGER MAX LABELS = 80
   18     %CONSTINTEGER MAX DEPTH  = 16
   19     %CONSTINTEGER MAX STACK  = 31
   20     %CONSTINTEGER INIT GLA   = 32;    !  **USED LOCALLY AND IN PASS 3**
   21     %CONSTINTEGER LAST PERM  = -24;   ! MUST MATCH PERM TABLE IN PASS 3
   22  
   23  !  STATIC GLA LAYOUT
   24  !
   25  !     0:  STACK LIMIT
   26  !     4:  @diag tables (zero if missing)
   27  !     8:  IOCP switch base
   28  !    12:  IOCP gla base
   29  !    16:  IOCP code base
   30  !    20:  IOCP base level locals
   31  !    24:  -spare-
   32  !    28:  -spare-
   33  !
   34  
   35  
   36     %CONSTINTEGER INITIAL FREE = 5120;  ! INITIAL FREE STACK(BYTES)
   37     %CONSTINTEGER MIN FREE = 600;   ! LOWER LIMIT ON FREE STACK SPACE
   38  
   39  ! ON THE 32-BIT SERIES, EFFICIENT(RX1) BASE+DISPLACEMENT ADDRESSING
   40  ! IS ONLY AVAILABLE FOR VALUES OF DISPLACEMENT < 16*1024.
   41  ! ARRAYS WITH FIXED BOUNDS ARE PUT INTO THE STATIC STACK FRAME
   42  ! UNTIL THE FRAME SIZE > 'MAX STATIC' LEAVING [16*1024 - MAX STATIC]
   43  ! BYTES AVAILABLE FOR SCALARS.  THERE MAY STILL BE PROBLEMS WITH
   44  ! LARGE RECORDS (WHICH CAN CONTAIN ARRAYS).
   45  
   46     %CONSTINTEGER  MAX STATIC = 13000
   47  
   48  
   49  
   50  ! WORDLENGTH DEPENDENT VALUES:
   51  
   52     %CONSTINTEGER  REGLEN=4;     ! REGISTER LENGTH(IN 8-BIT BYTES)
   53  
   54  
   55  
   56  !  COMPILER CONTROL OPTIONS (DEFAULT MARKED *)
   57     %CONSTINTEGER TEST SWITCH = 1;   !* CHECK SWITCH JUMPS
   58     %CONSTINTEGER STKDIAG     = 2;   !* CHECK EXTENT OF STACK
   59     %CONSTINTEGER ARRAY DIAG  = 4;   !* CHECK ARRAY BOUNDS
   60     %CONSTINTEGER FORDIAG     = 8;   !* VALIDATE %FOR PARAMETERS
   61     %CONSTINTEGER ASS DIAG    =16;   !* TEST FOR TRUNCATION
   62     %CONSTINTEGER UNASS DIAG  =32;   !* CHECK FOR UNASSIGNED VARIABLES
   63     !
   64     %CONSTINTEGER TRUSTED     =4096; !  ENABLE DIRTY OPTIMISATIONS
   65  
   66  ! %CONTROL 0 GIVES TIGHTEST CODE (NO CHECKING AT ALL!)
   67  
   68  
   69  
   70  
   71  !  COMPILER ERROR CODES
   72  !  --------------------
   73  !  CODE      ROUTINE                    MEANING
   74  !  ----      -------                    -------
   75  !    1       RELEASE                    TOO MANY CALLS ON 'RELEASE'
   76  !    2       CHECK RELEASED             TOO FEW CALLS ON 'RELEASE'
   77  !    3       HAZARD                     FAULTY PARAM. SUPPLIED TO HAZARD??
   78  !    4       ""                         "" ????
   79  !    5       RX, RI2, RI3               ILLEGAL ADDRESS FIELD GENERATE
   80  !    6       LOOKUP                     UNDEFINED NAME IN INTERMEDIATE COD
   81  !    7       STACK, SSTACK ETC          DESCRIPTOR STACK OVERFLO
   82  !    8       SET BOTH, POP LHS, ASSIGN  DESCRIPTOR STACK UNDERFLO
   83  !    9       AMAP                       FAULTY PARAM. SUPPLIED TO 'AMAP'
   84  !    10      LOAD                       'REAL' AS ADDRESS?
   85  !    11      LOAD                       FLOATING REG. REQ'D
   86  !    12      "                          "
   87  !    13      COP                        FAULTY PARAM. SUPPLIED TO 'COP'
   88  !    14      ASSEMBLE                   DESCRIPTOR STACK NON-EMPTY AT 'O
   89  !    15      ASSIGN                     FAULTY PARAM. SUPPLIED TO 'ASSIGN'
   90  !    16      LOAD                       'REAL', INTEGER REQ''D
   91  !    17      DESCRIPTOR                 NO FREE DESCRIPTORS
   92  !    18      DROP                       DESCRIPTOR NOT IN USE
   93  !    19      ASSEMBLE                   DANGLING DESCRIPTOR
   94  
   95  ! REGISTERS
   96  
   97     %CONSTINTEGER R0   = 1
   98     %CONSTINTEGER R1   = 2
   99     %CONSTINTEGER R2   = 3
  100     %CONSTINTEGER R3   = 4
  101     %CONSTINTEGER R4   = 5
  102     %CONSTINTEGER P2   = 6
  103     %CONSTINTEGER P1   = 7
  104     %CONSTINTEGER R9   = 8
  105     %CONSTINTEGER R10  = 9
  106     %CONSTINTEGER R11  = 10
  107     %CONSTINTEGER R12  = 11
  108     %CONSTINTEGER LINK = 12
  109     %CONSTINTEGER FPR0 = 13
  110     %CONSTINTEGER FPR2 = 14
  111     !             FPR4 = 15
  112     !             FPR6 = 16
  113     !             FPR8 = 17
  114     !             FPR10= 18
  115     !             FPR12= 19
  116     %CONSTINTEGER FPR14= 20
  117  
  118     !   21 - 40 ARE STORE EQUIVALENTS OF ABOVE
  119  
  120     %CONSTINTEGER R15  = 41
  121     %CONSTINTEGER GLA  = 42
  122     %CONSTINTEGER WSP  = 43
  123     %CONSTINTEGER CODE = 44
  124  
  125     %CONSTINTEGER ANY  = 45
  126     %CONSTINTEGER ANY0 = 46
  127     %CONSTINTEGER ANYF = 47
  128     %CONSTINTEGER PARAM= 48
  129  
  130     %CONSTINTEGER STORE= 20
  131  
  132     %CONSTBYTEINTEGERARRAY BASE REG(0:5) = R0, R15, R9, R10, R11, R12
  133     %CONSTBYTEINTEGERARRAY ACTUAL(0:44) = 0,
  134+                                      0, 1, 2, 3, 4, 5, 6, 9,
  135+                                     10,11,12, 8,
  136+                                      0, 2, 4, 6, 8,10,12,14,
  137+                                      0(20), 15, 13, 7, 14
  138  
  139  
  140  ! DATA FORMS
  141  
  142     !  EXTERNAL
  143  
  144     %CONSTINTEGER SWITCH    = 6
  145     %CONSTINTEGER ARRAY     = 11
  146     %CONSTINTEGER ARRAYNAME = 12
  147  
  148     !  INTERNAL
  149  
  150     %CONSTINTEGER CONSTANT = 0
  151     %CONSTINTEGER V IN R   = 1
  152     %CONSTINTEGER A IN S   = 2
  153     %CONSTINTEGER V IN S   = 3
  154     %CONSTINTEGER A IN REC = 4
  155     %CONSTINTEGER V IN REC = 5
  156     %CONSTINTEGER AV IN S  = 6
  157     %CONSTINTEGER AV IN REC= 7
  158  
  159  !  LABEL CONSTANTS
  160  
  161     %CONSTINTEGER DEFINE   = 0
  162     %CONSTINTEGER REDEFINE = 1
  163  
  164  ! DATA TYPES
  165  
  166     %CONSTINTEGER INTEGER = 1
  167     %CONSTINTEGER BYTE    = 2
  168     %CONSTINTEGER SHORT   = 3
  169     %CONSTINTEGER STRING  = 4
  170     %CONSTINTEGER RECORD  = 5
  171     %CONSTINTEGER REALS   = 6
  172     %CONSTINTEGER LONG    = 7
  173  
  174     %CONSTINTEGER UNSIGNED HALFWORD = 255;   ! INTERNAL TO PASS 2
  175  
  176  ! OWN INFO
  177  
  178  !  %CONSTINTEGER OWN    = 1
  179     %CONSTINTEGER CON    = 2
  180     %CONSTINTEGER PERMRT = 7
  181  
  182  ! PROC INFO
  183  
  184     %CONSTINTEGER FORMATS   = '2'
  185     %CONSTINTEGER PROCEDURE = '1'
  186     %CONSTINTEGER SPEC      = '0'
  187  
  188  !  OBJECT FILE DIRECTIVES
  189  
  190     %CONSTINTEGER START     = 1
  191     %CONSTINTEGER LOAD CODE = 2
  192     %CONSTINTEGER LOAD GLA  = 3
  193     %CONSTINTEGER LINE FLAG = 4
  194     %CONSTINTEGER C END     = 5
  195  !  %CONSTINTEGER L DATA    = 6
  196     %CONSTINTEGER DLINE     = 10
  197     %CONSTINTEGER DIAGS     = 11
  198  
  199  ! DIRECTIVE FILE COMMANDS
  200  
  201     %CONSTINTEGER TAG DEF   = 1
  202     %CONSTINTEGER C REF     = 2;  ! CONDITIONAL JUMP REF.
  203     %CONSTINTEGER J REF     = 3;  ! UNCONDITIONAL JUMP REF.
  204     %CONSTINTEGER R REF     = 4;  ! ROUTINE REF. (UNCONDITIONAL)
  205     %CONSTINTEGER P REF     = 5;  ! PERM REF. (UNCONDITIONAL)
  206     %CONSTINTEGER PATCH GLA = 6
  207     %CONSTINTEGER PATCHCODE = 7
  208     %CONSTINTEGER D END     = 8;  ! END OF DIRECTIVES FILE
  209  
  210  ! FILE DEFINITION
  211  
  212     %CONSTINTEGER INSTREAM = 2
  213     %CONSTINTEGER REPORT   = 0;    ! ...ERROR MESSAGE STREAM
  214     %CONSTINTEGER LIST     = 1
  215     %CONSTINTEGER OBJECT   = 2
  216     %CONSTINTEGER DIRECT   = 3
  217  
  218  
  219  ! SYMBOLS
  220  
  221     %CONSTINTEGER COMMA = ','
  222     %CONSTINTEGER MINUS = '-'
  223  
  224  ! PERM ROUTINES (FPR4,  FPR2,P1,P2,R4,  R3,R2,R1,R0)
  225  
  226     %CONSTINTEGER MONITOR    = X'1EF01'
  227     %CONSTINTEGER R COPY     = X'00902'
  228     %CONSTINTEGER R CLEAR    = X'00903'
  229     %CONSTINTEGER SWJUMP     = X'1EF04'
  230     %CONSTINTEGER ASET       = X'06F05'
  231     %CONSTINTEGER IEXP       = X'00B07'
  232     %CONSTINTEGER REXP       = X'18108'
  233     %CONSTINTEGER ALLOC      = X'02E09'
  234     %CONSTINTEGER SMOVE      = X'0090B', CONC1 = X'0090B'
  235     %CONSTINTEGER CONC2      = X'0630C'
  236     %CONSTINTEGER SCOMP      = X'06B0D'
  237     %CONSTINTEGER RSYM       = X'1EF0E'
  238  ! PERM ITEMS TO PERFORM VARIOUS RUN-TIME CHECKS
  239     %CONSTINTEGER EXBUNASS   = X'01112'
  240     %CONSTINTEGER EXB        = X'00113'
  241     %CONSTINTEGER A REF      = X'00314'
  242     %CONSTINTEGER STRINGASS  = X'00015';      ! ASSIGN TEST FOR STRINGS
  243     %CONSTINTEGER ASSTH      = X'00016';      ! ASSIGN TEST FOR SHORTS
  244     %CONSTINTEGER ASSTB      = X'00017';      ! ASSIGN TEST FOR BYTES
  245     %CONSTINTEGER FORTEST    = X'1EF18'
  246  
  247  !   FIXED GLA WORDS
  248  
  249     !    (WORD 0 IS STACK LIMIT POINTER)
  250     %CONSTINTEGER SIGNAL EP = 4;       ! ADDRESS OF %SIGNAL
  251  
  252  
  253  !   NOTEWORTHY CODE BLOCK DISPLACEMENTS
  254  
  255     %CONSTINTEGER UNASS PAT = 16;       ! UNASSIGNED VARIABLE PATTERN (80808080)
  256  
  257  ! OPERATIONS
  258  
  259     %CONSTINTEGER NOT = 1
  260     %CONSTINTEGER NEG = 2
  261     %CONSTINTEGER ADD = 3
  262     %CONSTINTEGER SUB = 4
  263     %CONSTINTEGER MUL = 6
  264     %CONSTINTEGER DIV = 7
  265     %CONSTINTEGER AND = 8
  266     %CONSTINTEGER IOR = 9
  267     %CONSTINTEGER XOR = 10
  268     %CONSTINTEGER LSH = 11
  269     %CONSTINTEGER RSH = 12
  270     %CONSTINTEGER EXP = 13
  271     %CONSTINTEGER CONC= 14
  272     %CONSTINTEGER SADD= 15;                !  SPECIAL ADD (V=V+??)
  273     %CONSTINTEGER RDIV= 16
  274     %CONSTINTEGER REM = 17
  275  
  276  ! OPCODES
  277  
  278     %CONSTINTEGER LIS = X'2400', LCS = X'2500'
  279     %CONSTINTEGER LR  = X'0800'
  280     %CONSTINTEGER LH  = X'4800', STH = X'4000'
  281     %CONSTINTEGER LHI = X'C800'
  282     %CONSTINTEGER LM  = X'D100', STM = X'D000'
  283     %CONSTINTEGER LHL = X'7300'
  284  
  285  
  286     %CONSTINTEGER AIS=X'2600', AHI=X'CA00', AH=X'4A00', AR=X'0A00'
  287     %CONSTINTEGER SIS=X'2700', SHI=X'CB00', SH=X'4B00', SR=X'0B00'
  288     %CONSTINTEGER AM  = X'5100'
  289     %CONSTINTEGER AHM = X'6100'
  290  
  291     %CONSTINTEGER C   = X'5900',  CH =X'4900', CI =X'F900', CR =X'0900'
  292     %CONSTINTEGER CL  = X'5500',  CLH=X'4500', CLI=X'F500', CLR=X'0500'
  293     %CONSTINTEGER                 CHI=X'C900'
  294     %CONSTINTEGER                CLHI=X'C500'
  295     %CONSTINTEGER CHVR = X'1200'
  296  
  297  
  298  
  299  
  300     %CONSTINTEGER TI  = X'F300', THI = X'C300'
  301  
  302     %CONSTINTEGER LBR = X'9300', LB  = X'D300', STB = X'D200'
  303     %CONSTINTEGER CLB = X'D400'
  304  
  305     %CONSTINTEGER SRA = X'EE00'
  306  
  307     %CONSTINTEGER BAL = X'4100'
  308     %CONSTINTEGER JUMP= 12
  309     %CONSTINTEGER BFCR= X'0300'
  310  
  311     %CONSTINTEGER SVC = X'E100'
  312     %CONSTINTEGER LME = X'7200', STME= X'7100'
  313     %CONSTINTEGER LER = X'2800'
  314     %CONSTINTEGER LE  = X'6800', STE = X'6000'
  315     %CONSTINTEGER CER = X'2900'
  316     %CONSTINTEGER CE  = X'6900'
  317     %CONSTINTEGER AER=X'2A00', SER=X'2B00', MER=X'2C00', DER=X'2D00'
  318     %CONSTINTEGER AE =X'6A00', SE =X'6B00', ME =X'6C00', DE =X'6D00'
  319     %CONSTINTEGER FXR = X'2E00', FLR = X'2F00'
  320  
  321  !   FULLWORD OPCODES
  322     %CONSTINTEGER LW  = X'5800', ST = X'5000'
  323     %CONSTINTEGER LI  = X'F800'
  324     %CONSTINTEGER LA  = X'E600'
  325  
  326     %CONSTINTEGER SLLS= X'1100'
  327     %CONSTINTEGER SRLS= X'1000'
  328     %CONSTINTEGER SLL = X'ED00'
  329     %CONSTINTEGER SRL = X'EC00'
  330  
  331     %CONSTINTEGER AW  = X'5A00'
  332     %CONSTINTEGER SW  = X'5B00'
  333     %CONSTINTEGER AI  = X'FA00'
  334     %CONSTINTEGER SI  = X'FB00'
  335  
  336     %CONSTINTEGER MW  = X'5C00'
  337     %CONSTINTEGER MR  = X'1C00'
  338     %CONSTINTEGER DW  = X'5D00'
  339     %CONSTINTEGER DR  = X'1D00'
  340  
  341     %CONSTINTEGER OR=X'0600', OW=X'5600', OH=X'4600', OI=X'F600'
  342     %CONSTINTEGER XR=X'0700', XW=X'5700', XH=X'4700', XI=X'F700'
  343     %CONSTINTEGER NR=X'0400', NW=X'5400', NH=X'4400', NI=X'F400'
  344     %CONSTINTEGER OHI = X'C600', XHI = X'C700', NHI = X'C400'
  345  
  346  
  347     %RECORDFORMAT VARFM(%INTEGER DISP, %SHORTINTEGER FORMAT, EXTRA,  %C
  348+                    ID, LENGTH,  %BYTEINTEGER BASE, TYPE, FORM, SIZE)
  349     %RECORDFORMAT  STACKFM(%INTEGER  DISP, FORMAT, EXTRA, LENGTH, DV,  %C
  350+                           %SHORTINTEGER  BASE, LOP,TYPE, FORM,  %C
  351+                         %RECORD(STACKFM)%NAME  LINK)
  352     %RECORDFORMAT SPTFM(%RECORD(STACKFM)%NAME V)
  353     %RECORDFORMAT LABELFM(%SHORTINTEGER ID, TAG, %C
  354+                          %BYTEINTEGER REG, BASE, %C
  355+                          %INTEGER LIMIT, DISP)
  356     %RECORDFORMAT USEFM(%INTEGER  DISP, CA, %C
  357+                        %SHORTINTEGER BASE, %C
  358+                        %BYTEINTEGER TYPE,FORM)
  359     %RECORDFORMAT ENVFM(%INTEGER LABEL, LIMEN, %C
  360+                                  %RECORD(USEFM)%ARRAY E(1:40))
  361  
  362  !  DATA ARRAYS
  363  
  364     %RECORD(USEFM)%ARRAY USE(1 : 44);! REGISTER USAGE
  365     %RECORD(USEFM) KNOWN
  366     %INTEGERARRAY ACTIVITY(0 : 44);! REGISTER ACTIVITY
  367     %RECORD(LABELFM)%ARRAY LABELS(1 : MAX LABELS)
  368     %RECORD(SPTFM)%ARRAY STACKED(1 : MAX DEPTH);! MAIN STACK
  369     %RECORD(STACKFM)%ARRAY STAK(0 : MAX STACK); ! STACK ELEMENTS
  370     %INTEGERARRAY USED(0:20)
  371     %RECORDFORMAT DFM(%RECORD(STACKFM)%NAME D, %RECORD(DFM)%NAME LINK)
  372     %RECORD(STACKFM)%NAME DESC ASL
  373     %RECORD(DFM)%ARRAY DLIST(0:MAX STACK)
  374     %RECORD(DFM)%NAME DASL
  375     %RECORD(DFM) USING
  376  
  377     %OWNBYTEINTEGERARRAY VBUF(1:10)
  378     %OWNINTEGER VP = 0
  379     %OWNINTEGER XLEVEL = 0
  380     %INTEGER BLOCK WORD
  381     %OWNRECORD(VARFM) BEGIN
  382     %RECORD(ENVFM) NULL ENV
  383  {   %constrecord(*)%name null == (0)      {   %OWNRECORD(STACKFM) NULL   }
  384  %ownrecord(*)%name null == 0
  385     %RECORD(VARFM)%NAME DECVAR
  386  
  387     %OWNINTEGER CONTROL = B'11111111'; ! ALL CHECKS ENABLED INITIALLY
  388     %OWNINTEGER PERMS = LAST PERM
  389     %INTEGER DYNAMIC, DOPE
  390     %SHORTINTEGER HALF
  391     %INTEGER J
  392     %INTEGER CA;           !  CODE ADDRESS
  393     %INTEGER GA, DIAG GLA; !  GLA ADDRESS
  394     %INTEGER DA
  395     %INTEGER LINE SIZE
  396     %OWNINTEGER REALGA;   ! FRIG FOR OWNREALARRAY
  397     %INTEGER LIMEN;      !  BACKWARD EXTENT OF KNOWLEDGE
  398     %INTEGER CURRENT LINE
  399     %INTEGER ENVP;       !  LAST ENVIRONMENT USED (CIRCULAR)
  400     %INTEGER STP;        ! STACK POINTER
  401     %INTEGER STACK ASL;  ! STACK DESCRIPTOR POINTER
  402     %ownINTEGER FRAME = 0;      ! LOCAL STACK FRAME EXTENT
  403     %OWNINTEGER  MIN TEMP = 0
  404     %INTEGER PARMS;      ! START OF PARAMETER STACK
  405     %INTEGER LOCAL
  406     %INTEGER INVERT,SWOPPED;!  CONDITION INVERSION FLAG
  407     %INTEGER UNCOND JUMP;      !  ADDRESS OF CODE HOLE
  408     %RECORD(LABELFM)%NAME FLAB;    ! %FOR LABEL
  409     %INTEGER GTYPE,GMODE;      ! PARAMETER FLIP-FLOP
  410     %INTEGER OTYPE=0, OWNTYPE, OWNFORM, OWNVAL
  411     %INTEGER  FAULTY, ENTER UNASS
  412  
  413     %RECORD(STACKFM) ST WORK
  414     %RECORD(STACKFM) CCV
  415     %INTEGER CCREG, CCCA=-1;      !  CONDITION-CODE INFO
  416  
  417     %RECORD(STACKFM)%NAME ACTIVE STRING
  418     %BYTEINTEGERNAME CSLEN
  419     %BYTEINTEGERARRAY CURRENT STRING(0 : 255)
  420  
  421     %RECORD(ENVFM)%ARRAY ENVIR(0:MAX ENVIRS);! WELL AWAY FROM ALL
  422  
  423     %INTEGER  MAX VARS;  MAX VARS = FREE SPACE - INITIAL FREE
  424     %BEGIN
  425        MAX VARS = MAX VARS + INITIAL FREE//4 %IF MAX VARS <= 0
  426        MAX VARS = 16 %IF MAX VARS <= 0
  427        MAX VARS = MAX VARS>>4;  ! BYTE LENGTH OF 'VARFM'
  428  !      SELECT OUTPUT(LIST)
  429  !      PRINTSTRING("PASS 2 VERSION ");!  PRINTSTRING(P2VERSION)
  430  !      WRITE(MAX VARS, 1);!  PRINTSTRING(" VARS");!  NEWLINE
  431     %END
  432  
  433     %RECORD(VARFM)%ARRAY  VAR(1:MAX VARS)
  434  
  435  
  436  %ROUTINESPEC  RX(%INTEGER  OP, R, X, D)
  437  
  438  
  439  %ROUTINE PHEX(%INTEGER N)
  440     %INTEGER J,K
  441     %CYCLE J = 1,1,4
  442        K = (N>>12)&15;  N = N<<4
  443        %IF K > 9 %THEN K = K-10+'A' %ELSE K = K+'0'
  444        PRINTSYMBOL(K)
  445     %REPEAT
  446  %END
  447  
  448  %ROUTINE DECODE(%INTEGER WORD)
  449     %OWNINTEGER LAST,N
  450     SELECTOUTPUT(LIST)
  451     %IF LAST # CURRENT LINE %START
  452        LAST = CURRENT LINE
  453        NEWLINE %UNLESS N = 0
  454        N = 16
  455        WRITE(CURRENT LINE, 4);  SPACE
  456        PHEX(CA);  PRINTSYMBOL(':')
  457     %ELSE
  458        SPACES(11) %IF N = 16
  459     %FINISH
  460     SPACES(2);  PHEX(WORD)
  461     N = N-1
  462     N = 16 %AND NEWLINE %IF N <= 0
  463     SELECTOUTPUT(OBJECT)
  464  %END
  465     %ROUTINE SHOW(%RECORD(STACKFM)%NAME V)
  466        SELECTOUTPUT(REPORT) %IF CONTROL < 0
  467        WRITE(V_TYPE, 1);  WRITE(V_FORM, 2)
  468        WRITE(V_BASE, 2);  WRITE(V_DISP, 5)
  469        WRITE(V_EXTRA, 5);  WRITE(V_LENGTH, 5)
  470        %IF V_LOP # 0 %START
  471           WRITE(V_LOP, 2);  PRINTSYMBOL(':')
  472           SHOW(V_LINK)
  473        %ELSE
  474           NEWLINE
  475        %FINISH
  476        SELECTOUTPUT(OBJECT) %IF CONTROL < 0
  477     %END
  478     %ROUTINE ABORT(%INTEGER CODE)
  479        %INTEGER I,J,L,FATAL
  480        %SWITCH SW(-15:0)
  481        %RECORD(DFM)%NAME DD
  482        I = REPORT;  FATAL = 1
  483        CONTROL = 0
  484        %CYCLE
  485           SELECT OUTPUT(I)
  486           %IF CODE > 0 %START;      ! ... IT'S A COMPILER FAULT
  487              PRINT STRING("*COMPILER ERROR"); WRITE(CODE,1)
  488              PRINT STRING(" AT LINE");  WRITE(CURRENT LINE,1)
  489              NEWLINE
  490              %IF STP > 0 %START
  491                 PRINT STRING("STACK"); NEWLINE
  492                 SHOW(STACKED(J)_V) %FOR J = 1,1,STP
  493              %FINISH
  494              %UNLESS USING_LINK == NULL %START
  495                 PRINTSTRING("USING:");  NEWLINE
  496                 DD == USING_LINK
  497                 %CYCLE
  498                    SHOW(DD_D);  DD == DD_LINK
  499                    %EXIT %IF DD == NULL
  500                 %REPEAT
  501              %FINISH
  502              ->CONT %IF I = REPORT
  503              %SIGNAL 15,1;            ! ... SIGNAL COMPILER FAULT
  504           %FINISH
  505           PRINT SYMBOL('*');  WRITE(CURRENT LINE,1);  PRINT STRING(": ")
  506           -> SW(CODE)
  507  
  508  SW(0):
  509     PRINT STRING("MORE STORE PLEASE!!");  -> CONT
  510  SW(-1):
  511  SW(-2):
  512     PRINT STRING("MORE STORE REQ'D FOR THIS COMPILATION");  -> CONT
  513  SW(-3):
  514     PRINT STRING("BLOCKS TOO DEEPLY NESTED");  -> CONT
  515  SW(-4):
  516     PRINT STRING("TOO MANY NAMES");  -> CONT
  517  SW(-5):
  518     PRINT STRING("TOO MANY LABELS");  -> CONT
  519  SW(-6):
  520     PRINT STRING("DIVISION BY ZERO");  -> NON FATAL
  521  SW(-7):
  522  SW(-8):
  523     PRINT STRING("ARRAY INSIDE OUT");  -> NON FATAL
  524  SW(-9):
  525     PRINT STRING("DECLARATION OUT OF CONTEXT");  -> NON FATAL
  526  SW(-10):
  527     PRINT STRING("FAULTY SWITCH DECLARATION");  -> NON FATAL
  528  SW(-11):
  529     PRINT STRING("%RESULT UNSPECIFIED");  -> NON FATAL
  530  SW(-12):
  531     PRINT STRING("ILLEGAL %FOR PARAMETERS");  ->WARNING
  532  SW(-13):
  533     PRINTSTRING("STRING CONSTANT TOO LONG");  ->WARNING
  534  SW(-14):
  535     PRINTSTRING("UNASSIGNED CHECK INHIBITED")
  536     CONTROL = CONTROL&(\UNASS DIAG);  ->WARNING
  537  SW(-15):
  538     PRINTSTRING("LOCALS > 16K ???")
  539  
  540  WARNING:
  541        L = 0
  542  
  543  NON FATAL:
  544        FATAL = 0
  545  CONT:
  546        NEWLINE
  547        %IF I = LIST %START
  548           %SIGNAL 15,2 %IF FATAL # 0
  549           FAULTY = FAULTY+L;  SELECT OUTPUT(OBJECT); %RETURN
  550        %FINISH
  551        I = LIST
  552  
  553        %REPEAT
  554     %END
  555     %ROUTINE DISPLAY VAR(%RECORD(VARFM)%NAME V)
  556        SELECTOUTPUT(LIST)
  557        WRITE(V_ID, 3);  PRINTSYMBOL(':')
  558        WRITE(V_TYPE, 2);  WRITE(V_FORM, 2)
  559        WRITE(V_BASE, 3);  WRITE(V_DISP, 4)
  560        WRITE(V_EXTRA, 4);  WRITE(V_FORMAT, 4)
  561        NEWLINE
  562        SELECTOUTPUT(OBJECT)
  563     %END
  564     %ROUTINE REAL ERROR(%INTEGER N)
  565        %INTEGER I
  566        %CONSTSHORTINTEGERARRAY SYM(1:14) = '\', '?', '?', '?', '@',
  567+                                           '?', '?', '&', '!',-'!',
  568+                                          -'<', -'>', '?', '.'
  569        I = REPORT
  570        %CYCLE
  571           SELECT OUTPUT(I)
  572           PRINTSYMBOL('*');  WRITE(CURRENT LINE, 4)
  573           PRINTSTRING(" ILLEGAL REAL OPERATION '")
  574           N = SYM(N)
  575           PRINTSYMBOL(-N) %IF N < 0
  576           PRINTSYMBOL(|N|);  PRINTSYMBOL('''');  NEWLINE
  577           %EXIT %IF I = LIST
  578           I = LIST
  579        %REPEAT
  580        FAULTY = FAULTY+1
  581        SELECTOUTPUT(OBJECT)
  582     %END
  583     %PREDICATE FLOATING(%RECORD(STACKFM)%NAME V)
  584        %TRUE %IF V_TYPE = REALS %OR (V_LOP # 0    %C
  585+              %AND (V_LOP = RDIV %OR (v_link ## NULL %and V_LINK_TYPE = REALS)))
  586        %FALSE
  587     %END
  588     %PREDICATE SAME(%RECORD(STACKFM)%NAME L, R)
  589        %FALSE %IF L_BASE # R_BASE %OR L_DISP # R_DISP
  590        %FALSE %IF L_TYPE # R_TYPE %OR L_FORM # R_FORM
  591        %FALSE %IF L_EXTRA # R_EXTRA
  592        %TRUE
  593     %END
  594     %PREDICATE ZERO(%RECORD(STACKFM)%NAME V)
  595        %FALSE %IF V_DISP # 0 %OR V_BASE # 0 %OR V_FORM # CONSTANT
  596        %FALSE %IF V_LOP # 0
  597        %TRUE
  598     %END
  599     %PREDICATE CONST(%RECORD(STACKFM)%NAME V)
  600        %FALSE %UNLESS V_FORM = CONSTANT %AND V_LOP = 0
  601        %FALSE %IF V_TYPE > SHORT
  602        %TRUE
  603     %END
  604     %INTEGERFN POWER(%INTEGER N)
  605        %INTEGER MASK, J
  606        MASK = 1
  607        %FOR J = 0, 1, 14 %CYCLE
  608           %RESULT = J %IF N = MASK
  609           MASK = MASK<<1
  610        %REPEAT
  611        %RESULT = -1
  612     %END
  613     %INTEGERFN TEMP
  614        %INTEGER T
  615        T = (FRAME+(REGLEN-1))&(\(REGLEN-1))
  616        FRAME = T+REGLEN
  617        %RESULT = T
  618     %END
  619     %INTEGERFN TAG
  620        %INTEGER N, S
  621        N = 0
  622        %CYCLE
  623           S = NEXTSYMBOL
  624           %RESULT = N %UNLESS '0' <= S <= '9'
  625           N = N*10+S-'0'
  626           SKIPSYMBOL
  627        %REPEAT
  628     %END
  629     %INTEGERFN EVAL(%INTEGER L)
  630        %INTEGER J, N, B, S, MOD
  631        %CONSTBYTEINTEGERARRAY BASIS('V' : 'Z') = 3, 1, 8, 4, 0
  632        %RESULT = 0 %IF L < 2
  633        READSYMBOL(B);  B = BASIS(B)
  634        N = 0
  635        %IF B = 0 %START
  636           %FOR J = 2,1,L %CYCLE
  637              READ SYMBOL(S)
  638              N = (N*4+N)*2 + S-'A'
  639           %REPEAT
  640        %ELSE
  641           MOD = 'A';  MOD = 0 %IF B = 8
  642           %FOR J = 2,1,L %CYCLE
  643              READ SYMBOL(S)
  644              N = N<<B + (S-MOD)
  645           %REPEAT
  646        %FINISH
  647        %RESULT = N
  648     %END
  649     %REALFN  REAL CONSTANT
  650     %INTEGER  I,L,S,J,M
  651     %REAL  N,FACTOR,TEN,ONE
  652        I = 10;  TEN = I;   ! ...TO PREVENT COMPILE-TIME FLOATING
  653        I = 1;  ONE = I;   ! ... AND AGAIN
  654        M = 0;  N = 0;  L = TAG;  SKIP SYMBOL
  655        %CYCLE  J = 1,1,L
  656           READ SYMBOL(S)
  657           %IF S = '.' %START
  658              FACTOR = 1;  M = 1
  659           %ELSE
  660              I = S-'A'
  661              %IF M = 0 %START
  662                 N = N*TEN + I
  663              %ELSE
  664                 FACTOR = FACTOR/TEN
  665                 N = N + I*FACTOR
  666              %FINISH
  667           %FINISH
  668        %REPEAT
  669        %RESULT = N
  670     %END
  671     %ROUTINE RELEASE(%INTEGER REG)
  672        %RETURN %IF REG = 0 %OR ACTIVITY(REG) < 0;!  LOCKED
  673        ACTIVITY(REG) = ACTIVITY(REG)-1
  674        ABORT(1) %IF ACTIVITY(REG) < 0
  675     %END
  676     %ROUTINE CLAIM(%INTEGER REG)
  677        %RETURN %IF REG = 0 %OR ACTIVITY(REG) < 0
  678        USED(REG) = CA
  679        ACTIVITY(REG) = ACTIVITY(REG)+1
  680     %END
  681     %ROUTINE FORGET(%INTEGER REG)
  682        USE(REG)_CA = LIMEN;  USE(REG+STORE)_CA = LIMEN
  683     %END
  684     %ROUTINE FORGET DEST(%RECORD(STACKFM)%NAME V)
  685        %CONSTBYTEINTEGERARRAY BITS(0:7) = 15,15,8,12,12,12,15,15
  686        %INTEGER R, MASK, ADDR, TYPE
  687        %RECORD(USEFM)%NAME U
  688  
  689        ADDR = V_DISP!3;  MASK = BITS(V_TYPE)>>(V_DISP&3)
  690  
  691        %FOR R = 1, 1, 40 %CYCLE
  692           U == USE(R)
  693           %IF U_CA > LIMEN %START
  694              %IF U_BASE&255 = V_BASE %AND U_FORM # A V IN S %START
  695                 %IF U_DISP!3 = ADDR %START
  696                    TYPE = U_TYPE
  697                    TYPE = 7 %IF U_FORM&128 # 0
  698                    type = 0 %if type = 255      {unsigned halfword}
  699                    %IF BITS(TYPE)>>(U_DISP&3) & MASK # 0 %START
  700                       U_CA = LIMEN;        ! FORGET IT
  701                    %FINISH
  702                 %FINISH
  703              %FINISH
  704           %FINISH
  705        %REPEAT
  706     %END
  707     %ROUTINE HAZARD(%INTEGER REG)
  708        %RECORD(DFM)%NAME P
  709        %INTEGER N, T, OP
  710        %ROUTINE MOD(%RECORD(STACKFM)%NAME V)
  711           %SWITCH S(0:7)
  712                 N = N-1
  713                 ->S(V_FORM)
  714  S(CONSTANT):
  715  S(A IN REC):
  716  S(V IN REC):
  717  S(AV IN REC):  ABORT(3)
  718  S(A IN S):     V_FORM = A IN REC;  V_EXTRA = T;  ->DONE
  719  S(AV IN S):    V_FORM = AV IN REC;  V_EXTRA = T;  ->DONE
  720  S(V IN S):     V_FORM = V IN REC;  V_EXTRA = T;  ->DONE
  721  S(V IN R):     V_FORM = V IN S;  V_DISP = T
  722  DONE:          V_BASE = LOCAL
  723        %END
  724        N = ACTIVITY(REG)
  725        %RETURN %IF N <= 0
  726        ACTIVITY(REG) = 0
  727        T = TEMP
  728        %IF FPR0 <= REG <= FPR14 %THEN OP = STE %ELSE OP = ST
  729        RX(OP, REG, LOCAL, T)
  730        P == USING_LINK
  731        %CYCLE
  732           %EXIT %IF P == NULL
  733           MOD(P_D) %IF P_D_BASE = REG
  734           P == P_LINK
  735        %REPEAT
  736        ABORT(4) %IF N # 0
  737     %END
  738     %ROUTINE HAZARD ALL
  739        %INTEGER J
  740        HAZARD(J) %FOR J = 1, 1, 20
  741     %END
  742     %ROUTINE REMEMBER(%INTEGER REG, %RECORD(STACKFM)%NAME V)
  743        %RECORD(USEFM)%NAME U
  744        REMEMBER(REG+STORE,V) %IF REG <= STORE
  745        U == USE(REG)
  746        U_BASE = V_BASE
  747        U_DISP = V_DISP
  748        U_TYPE = V_TYPE
  749        U_FORM = V_FORM
  750        U_CA   = CA
  751        %IF CONTROL < 0 %START
  752           SELECTOUTPUT(LIST)
  753           PRINTSTRING(" REMEMBER:")
  754           WRITE(U_TYPE, 1);  WRITE(U_FORM, 1);  WRITE(U_BASE, 3)
  755           WRITE(U_DISP,5)
  756           NEWLINE
  757           SELECTOUTPUT(OBJECT)
  758        %FINISH
  759     %END
  760     %INTEGERFN FIND USE(%INTEGER TYPE, FORM, BASE, DISP)
  761        %RECORD(USEFM)%NAME U
  762        %INTEGER J, B, BB, BCA, BBCA
  763        B = BASE&255;  BB = BASE>>8
  764        %IF ACTIVITY(B) < 0 %THEN BCA = LIMEN+1 %ELSE BCA = USE(B)_CA
  765        %IF ACTIVITY(BB)< 0 %THEN BBCA= LIMEN+1 %ELSE BBCA= USE(BB)_CA
  766        %RESULT = 0 %IF BCA <= LIMEN %OR BBCA <= LIMEN
  767        %FOR J = 1, 1, 40 %CYCLE
  768           U == USE(J)
  769           %IF BCA < U_CA %AND BBCA < U_CA %START
  770              %IF U_BASE = BASE  %AND U_DISP = DISP %START
  771                 %IF U_TYPE = TYPE %AND U_FORM = FORM %START
  772                    %IF J > STORE %START
  773                       J = J-STORE
  774                       USE(J) = U %IF USE(J)_CA <= LIMEN
  775                    %FINISH
  776                    CLAIM(J)
  777                    RELEASE(B);  RELEASE(BB)
  778                    %RESULT = J
  779                 %FINISH
  780              %FINISH
  781           %FINISH
  782        %REPEAT
  783        %RESULT = 0
  784     %END
  785     %INTEGERFN GPR(%INTEGER ADDR)
  786        %RECORD(USEFM)%NAME UR, US
  787        %INTEGER R, BESTR, BESTCA, BOOTR, BOOTCA, REG, MAXCA
  788        %CONSTBYTEINTEGERARRAY PREF(0:11) =
  789+                   P1, R11, R9, P2,
  790+                   R10, R12, R4, R3, R1, R2, LINK, R0
  791  
  792        BESTR = -1;  BOOTR = -1
  793        BESTCA = CA;  BOOTCA = CA
  794  
  795        %CYCLE R = 0, 1, 11-ADDR
  796           REG = PREF(R)
  797           %IF ACTIVITY(REG) = 0 %START;! FREE
  798              UR == USE(REG);  US == USE(REG+STORE)
  799              MAXCA = UR_CA
  800              MAXCA = US_CA %IF US_CA > MAXCA
  801              %RESULT = REG %IF MAXCA <= LIMEN;! NOT KNOWN
  802              %IF MAXCA < BESTCA %START
  803                 BESTCA = MAXCA;  BESTR = REG
  804              %FINISH
  805           %ELSE %IF 0 < ACTIVITY(REG) < 2 %AND USED(REG) < BOOTCA
  806              BOOTR = REG;  BOOTCA = USED(REG)
  807           %FINISH
  808        %REPEAT
  809        %RESULT = BESTR %IF BESTR >= 0
  810        !  NONE FREE SO BOOT ONE OUT
  811        BOOTR = R1 %IF BOOTR < 0;! NONE BETTER
  812        HAZARD(BOOTR);  USED(BOOTR) = CA
  813        %RESULT = BOOTR
  814     %END
  815     %INTEGERFN EVEN ODD PAIR
  816        %CONSTBYTEINTEGERARRAY PAIRS(1:5) = R0, R10, R2, R4, LINK
  817        %CONSTBYTEINTEGERARRAY NEXT(1:5)  = R1, R11, R3, P2, R9
  818        %INTEGER J, BEST, BESTCA, MAX, HELP, REG, NREG
  819        %RECORD(USEFM)%NAME U1, U2
  820        BEST = 0;  BESTCA = CA;  HELP = 0
  821        %CYCLE J = 1, 1, 5
  822           REG = PAIRS(J);  NREG = NEXT(J)
  823           U1 == USE(REG);  U2 == USE(NREG)
  824           %IF ACTIVITY(REG) = 0 %START
  825              %IF ACTIVITY(NREG) = 0 %START
  826                 MAX = U1_CA
  827                 MAX = U2_CA %IF U2_CA > MAX
  828                 %IF MAX < BESTCA %START
  829                    BESTCA = MAX;  BEST = J
  830                 %FINISH
  831              %ELSE
  832                 HELP = J
  833              %FINISH
  834           %ELSE
  835              HELP = J %IF ACTIVITY(NREG) = 0
  836           %FINISH
  837        %REPEAT
  838        %RESULT = NEXT(BEST) %IF BEST # 0
  839        HELP = 2 %IF HELP = 0
  840        REG = PAIRS(HELP);  NREG = NEXT(HELP)
  841        HAZARD(REG);  HAZARD(NREG)
  842        %RESULT = NREG
  843     %END
  844     %INTEGERFN FPR
  845        %RECORD(USEFM)%NAME UR, US
  846        %INTEGER R, BESTR, BESTCA, BOOTR, BOOTCA, MAXCA, BOOTA
  847        BESTR = -1;  BESTCA = CA
  848        BOOTR = -1;  BOOTCA = CA;  BOOTA = CA
  849        %CYCLE R = FPR0, 1, FPR14
  850           UR == USE(R);  US == USE(R+STORE)
  851           %IF ACTIVITY(R) = 0 %START
  852              MAXCA = UR_CA;  MAXCA = US_CA %IF US_CA > MAXCA
  853              %RESULT = R %IF MAXCA <= LIMEN
  854              %IF MAXCA < BESTCA %START
  855                 BESTR = R;  BESTCA = MAXCA
  856              %FINISH
  857           %ELSE %IF 0 < ACTIVITY(R) < 2 %AND USED(R) < BOOTCA
  858              BOOTCA = USED(R);  BOOTR = R
  859           %FINISH
  860        %REPEAT
  861        %RESULT = BESTR %UNLESS BESTR < 0
  862        BOOTR = FPR0 %IF BOOTR < 0
  863        HAZARD(BOOTR)
  864        %RESULT = BOOTR
  865     %END
  866     %ROUTINE CHECK RELEASED
  867        %INTEGER J
  868        %FOR J = 1, 1, 20 %CYCLE
  869           ABORT(2) %IF ACTIVITY(J) > 0
  870        %REPEAT
  871     %END
  872  
  873  
  874  ! OBJECT FILE HANDLING ROUTINES
  875  
  876     %ROUTINE COUNT DIAGS
  877        %OWNINTEGER HERE = 0
  878        LINE SIZE = LINE SIZE+4 %IF HERE # CURRENT LINE
  879        HERE = CURRENT LINE
  880     %END
  881  
  882     %ROUTINE  PUT(%SHORTINTEGER  N)
  883        PRINT SYMBOL(N>>8);  PRINT SYMBOL(N&255)
  884     %END
  885     %ROUTINE  DUMP(%SHORTINTEGER  N)
  886        PRINT SYMBOL(LOAD CODE);  PUT(N)
  887        DECODE(N) %IF CONTROL < 0
  888        CA = CA+2
  889     %END
  890     %ROUTINE  GHALF(%SHORTINTEGER  N)
  891        PRINT SYMBOL(LOAD GLA);  PUT(N)
  892        GA = GA+2
  893     %END
  894     %ROUTINE  GWORD(%INTEGER  N)
  895        GHALF(N>>16);  GHALF(N&X'FFFF')
  896     %END
  897     %ROUTINE  GBYTE(%SHORTINTEGER  N)
  898     %OWNINTEGER  V=0, F=0
  899        F = \F
  900        %IF F=0 %START
  901           PRINT SYMBOL(LOAD GLA);  PUT(V<<8+N)
  902        %ELSE
  903           V = N
  904        %finish
  905        GA = GA+1
  906     %END
  907     %ROUTINE  PATCH(%INTEGER  WHAT, WHERE)
  908        SELECT OUTPUT(DIRECT)
  909        PRINT SYMBOL(PATCH CODE);  PUT(WHAT);  PUT(WHERE)
  910        SELECT OUTPUT(OBJECT)
  911     %END
  912     %ROUTINE  GPATCH(%INTEGER  WHAT, WHERE)
  913        SELECT OUTPUT(DIRECT)
  914        PRINT SYMBOL(PATCH GLA);  PUT(WHAT);  PUT(WHERE)
  915        SELECT OUTPUT(OBJECT)
  916     %END
  917     %ROUTINE  GFIX(%INTEGER  ALIGNMENT)
  918        GBYTE(0) %WHILE GA&(ALIGNMENT-1) # 0
  919     %END
  920     %ROUTINE  SF(%SHORTINTEGER OP, R, L)
  921        DUMP(OP + ACTUAL(R)<<4 + L)
  922     %END
  923     %ROUTINE  RR(%SHORTINTEGER  OP, R1, R2)
  924        DUMP(OP + ACTUAL(R1)<<4 + ACTUAL(R2))
  925        RELEASE(R2)
  926     %END
  927     %ROUTINE  RX(%INTEGER  OP, R, X, D)
  928        ABORT(5) %IF X=R0 %OR D<0 %OR D>X'3FFF'
  929        RELEASE(X)
  930        DUMP(OP + ACTUAL(R)<<4 + ACTUAL(X));  DUMP(D)
  931        COUNT DIAGS %IF OP = BAL
  932        %IF CONTROL&UNASS DIAG # 0 %START
  933           %RETURN %IF OP # LW %AND OP # LE
  934           %RETURN %IF X = LOCAL %AND D >= MIN TEMP
  935           %IF OP = LW %THEN OP = CL %ELSE OP = CE
  936           DUMP(OP+ACTUAL(R)<<4+ACTUAL(CODE))
  937           DUMP(UNASS PAT)
  938           PRINTSYMBOL(DLINE);          ! INFORM DIAGS OF 'BALR'
  939           DUMP(ENTER UNASS)
  940           COUNT DIAGS
  941        %FINISH
  942     %END
  943     %ROUTINE  RI2(%INTEGER  OP, R, X, D)
  944        ABORT(5) %IF X=R0
  945        RELEASE(X)
  946        DUMP(OP + ACTUAL(R)<<4 + ACTUAL(X));  DUMP(D)
  947        COUNT DIAGS %IF OP = BAL;     ! IF PERM REFERENCE
  948     %END
  949     %ROUTINE  RI3(%INTEGER  OP, R, X, D)
  950        ABORT(5) %IF X=R0
  951        RELEASE(X)
  952        DUMP(OP + ACTUAL(R)<<4 + ACTUAL(X)); DUMP(D>>16); DUMP(D&X'FFFF')
  953     %END
  954     %ROUTINE  DEFINE TAG(%SHORTINTEGER  REF)
  955        SELECT OUTPUT(DIRECT)
  956        PRINT SYMBOL(TAG DEF);  PUT(REF);  PUT(CA)
  957        SELECT OUTPUT(OBJECT)
  958     %END
  959     %ROUTINE  DEFINE REFERENCE(%INTEGER  REF, TYPE)
  960        SELECT OUTPUT(DIRECT)
  961        PRINT SYMBOL(TYPE);  PUT(REF);  PUT(CA)
  962        SELECT OUTPUT(OBJECT)
  963     %END
  964     %ROUTINE  SET LINE
  965     %OWNINTEGER  HERE = 0
  966        CURRENT LINE = TAG
  967        %WHILE CURRENT LINE > HERE %CYCLE
  968           HERE = HERE+1;  PRINT SYMBOL(LINE FLAG)
  969        %REPEAT
  970     %END
  971  
  972  ! ENVIRONMENT CONTROL
  973  
  974     %RECORD(ENVFM)%MAP ENVIRONMENT(%SHORTINTEGER LABEL)
  975        %INTEGER J
  976        %RECORD(ENVFM)%NAME E
  977        %RESULT == NULL ENV %IF LABEL <= 0
  978        %FOR J = MAX ENVIRS, -1, 0 %CYCLE
  979           E == ENVIR(J)
  980           %RESULT == E %IF E_LABEL = LABEL
  981        %REPEAT
  982        %RESULT == NULL ENV
  983     %END
  984     %ROUTINE REMEMBER ENVIRONMENT(%SHORTINTEGER LABEL)
  985        %INTEGER K
  986        %RECORD(ENVFM)%NAME E
  987        %RETURN %IF LABEL <= 0
  988        E == ENVIRONMENT(LABEL)
  989        E_LABEL = 0
  990        ENVP = ENVP+1;  ENVP = 0 %IF ENVP > MAX ENVIRS
  991        E == ENVIR(ENVP)
  992        E_LABEL = LABEL
  993        E_LIMEN = LIMEN
  994        E_E(K) = USE(K) %FOR K = 1, 1, 40
  995     %END
  996     %ROUTINE MERGE ENVIRONMENT(%SHORTINTEGER LABEL)
  997        %INTEGER J
  998        %RECORD(ENVFM)%NAME E
  999        %RECORD(USEFM)%NAME U, V
 1000        E == ENVIRONMENT(LABEL)
 1001        %UNLESS E == NULL ENV %START
 1002           %FOR J = 1, 1, 40 %CYCLE
 1003              U == USE(J)
 1004              V == E_E(J)
 1005              V_CA = E_LIMEN %UNLESS U_BASE = V_BASE %C
 1006+                               %AND U_DISP = V_DISP %C
 1007+                               %AND U_FORM = V_FORM %C
 1008+                               %AND U_TYPE = V_TYPE %C
 1009+                               %AND U_CA   > LIMEN
 1010           %REPEAT
 1011        %FINISH
 1012     %END
 1013     %ROUTINE RESTORE ENVIRONMENT(%SHORTINTEGER LABEL)
 1014        %INTEGER J
 1015        %RECORD(ENVFM)%NAME E
 1016        E == ENVIRONMENT(LABEL)
 1017        %IF E == NULL ENV %START
 1018           LIMEN = CA
 1019        %ELSE
 1020           E_LABEL = 0
 1021           LIMEN = E_LIMEN
 1022           USE(J) = E_E(J) %FOR J = 1, 1, 40
 1023        %FINISH
 1024     %END
 1025  
 1026     %ROUTINE PERM(%INTEGER N)
 1027        %INTEGER MASK, J, R
 1028        %CONSTBYTEINTEGERARRAY REG(1:15) =
 1029+          R0, R1, R2, R3, R4, P2, P1, FPR0, FPR2,15,16,17,18,19,20
 1030        MASK = X'80'
 1031        N = N!X'FFFF0000'
 1032        %CYCLE J = 1, 1, 15
 1033           MASK = MASK<<1
 1034           %IF N&MASK # 0 %START
 1035              R = REG(J)
 1036              HAZARD(R);  FORGET(R)
 1037           %FINISH
 1038        %REPEAT
 1039        HAZARD(LINK);  FORGET(LINK)
 1040        DEFINE REFERENCE(N&255, P REF)
 1041        RI2(BAL, LINK, CODE, N&255)
 1042     %END
 1043     %ROUTINE SET DIAG(%INTEGER BASE, DISP, TYPE, FORM)
 1044        !! PROC<1><1>LEVEL<3>NAME<1>BASE<3>TYPE<3>DISP<20>
 1045        %INTEGER V1, V2, P, MARK
 1046        %ROUTINE FILL(%INTEGERNAME V)
 1047           %INTEGER SHIFT
 1048           SHIFT = 0;  V = 0
 1049           %CYCLE
 1050              %RETURN %IF P = VP %OR SHIFT = 30
 1051              P = P+1
 1052              V = V+(VBUF(P)-32)<<SHIFT
 1053              SHIFT = SHIFT+6
 1054           %REPEAT
 1055        %END
 1056        P = 0;  MARK = 0
 1057        FILL(V1);  FILL(V2)
 1058        %IF FORM = 0 %START;          ! NON-VARIABLE
 1059           PRINT SYMBOL(DLINE)
 1060           MARK = 16;  FORM = 1
 1061           %IF BASE = 0 %START;       ! %BEGIN
 1062              V2 = 0;  V1 = BLOCK WORD;! 'BLOCK'
 1063           %FINISH
 1064        %FINISH
 1065        BASE = ACTUAL(BASE)
 1066        BASE = BASE-8 %IF BASE >= 8
 1067        PRINTSYMBOL(DIAGS)
 1068        %IF FORM = -1 %START;                ! END OF BLOCK
 1069           PUT(-1);  PUT(-1);  DA = DA+4;  %RETURN
 1070        %FINISH
 1071        PUT(((((MARK+XLEVEL)<<1+FORM-1)<<3+BASE)<<3+TYPE)<<4)
 1072        PUT(DISP)
 1073        PUT(V1>>16);  PUT(V1&X'FFFF')
 1074        PUT(V2>>16);  PUT(V2&X'FFFF')
 1075        DA = DA+12
 1076     %END
 1077     %ROUTINE ASSEMBLE(%SHORTINTEGER AMODE, LABS, NAMES)
 1078        %OWNINTEGER ASS LEVEL = 0
 1079        %SWITCH Z(33:126)
 1080        %RECORD(VARFM)%NAME V, GVAR, FP, AP
 1081        %RECORD(STACKFM)%NAME LHS, RHS, X
 1082        %INTEGER SYM;            ! CURRENT CODE ITEM
 1083        %INTEGER VLB, VUB
 1084        %INTEGER DATA SIZE, OLD FRAME, GSTART, WDISP, NEW DISP, SDISP
 1085        %INTEGER OPR, N
 1086        %INTEGER SIZE PATCH, WARNING
 1087        %OWNINTEGER GG = 0
 1088        %INTEGER J,K, LEN, VAL, APARM, SPS
 1089        %INTEGER LABEL START;! FIRST LABEL FOR THIS LEVEL
 1090        %INTEGER RT LAB;     ! ROUTINE JUMP ADDRESS
 1091  
 1092        %CONSTBYTEINTEGERARRAY COMM(1:17)= 0, 0, 1, 0, 1, 1, 0,
 1093+                                          1, 1, 1, 0, 0, 0, 0, 1, 0, 0
 1094  
 1095     %ROUTINESPEC AMAP(%RECORD(STACKFM)%NAME V)
 1096     %ROUTINESPEC LOAD(%RECORD(STACKFM)%NAME V, %INTEGER REG)
 1097     %INTEGERFNSPEC NEW TAG
 1098     %ROUTINESPEC JOIN(%RECORD(STACKFM)%NAME W)
 1099     %ROUTINESPEC OPERATE(%INTEGER N)
 1100     %ROUTINESPEC COMPARE(%RECORD(STACKFM)%NAME L, R)
 1101     %ROUTINESPEC HEADER(%RECORD(VARFM)%NAME V)
 1102  
 1103     ABORT(-1) %IF FREE SPACE < MIN FREE;  !  ...STACK OVERFLOW?
 1104  
 1105     XLEVEL = XLEVEL+1
 1106     RT LAB = 0;  LABEL START = LABS; OLD FRAME = FRAME
 1107     WDISP = 0;  WARNING = 0
 1108     GVAR == DECVAR;  GSTART = NAMES
 1109     %IF AMODE > 0 %START
 1110        %IF AMODE = 1 %THEN FRAME = REGLEN %ELSE FRAME = 11*REGLEN
 1111        ABORT(-3) %IF ASS LEVEL = 5
 1112        ASS LEVEL = ASS LEVEL+1;  LOCAL = BASE REG(ASS LEVEL)
 1113        ACTIVITY(LOCAL) = -1
 1114        %IF AMODE = 2 %START
 1115           SET DIAG(R15, 0, 0, 0)
 1116        %FINISH
 1117        %IF OTYPE = PERMRT %START
 1118           PERMS = PERMS-1;  GVAR_DISP = PERMS
 1119        %FINISH
 1120        SET DIAG(LOCAL, 0, 0, 0) %IF GG = PROCEDURE
 1121     %ELSE %IF AMODE < 0
 1122        FRAME = 0
 1123     %ELSE
 1124        SET DIAG(0, 0, 0 ,0);      ! BLOCK
 1125     %FINISH
 1126  
 1127     ! DESCRIPTOR PROCESSING
 1128  
 1129     %INTEGERFN LOOKUP(%INTEGER NAME)
 1130        %INTEGER P, P1, P2
 1131        %RECORD(VARFM)%NAME V
 1132        P1 = 1;  P2 = NAMES
 1133        %WHILE P2 >= P1 %CYCLE
 1134           P = (P1+P2)>>1
 1135           V == VAR(P)
 1136           %RESULT = P %IF V_ID = NAME
 1137           %IF V_ID > NAME %THEN P2 = P-1 %ELSE P1 = P+1
 1138        %REPEAT
 1139        ABORT(6)
 1140        %STOP
 1141     %END
 1142     %ROUTINE DEFINE VAR
 1143        %CONSTBYTEINTEGERARRAY VSIZE(0:7) = 0, 4, 1, 2, 0, 4, 4, 0
 1144        %CONSTBYTEINTEGERARRAY ROUND(0:7) = 3,3,0,1,1,3,3,3
 1145        %INTEGER TYPE, FORM, TF, F, SIZE, FORMAT, S
 1146        %OWNINTEGER PERM NO = -1
 1147  
 1148        NAMES = NAMES+1;  ABORT(-4) %IF NAMES >= PARMS
 1149        DECVAR == VAR(NAMES);  DECVAR = 0
 1150        DECVAR_ID = TAG
 1151        VP = 0
 1152        %CYCLE
 1153           READSYMBOL(S);  %EXIT %IF S = COMMA
 1154           %IF VP # 10 %START
 1155              VP = VP+1;  VBUF(VP) = S
 1156           %FINISH
 1157        %REPEAT
 1158  
 1159        TF = TAG;  TYPE = TF>>4;  FORM = TF&15;  SKIPSYMBOL
 1160        %IF TYPE = LONG %START
 1161           TYPE = REALS
 1162        %FINISH
 1163        SIZE = TAG
 1164        DECVAR_TYPE = TYPE
 1165        DECVAR_FORM = FORM
 1166        SKIPSYMBOL
 1167        OTYPE = TAG
 1168        %IF NEXTSYMBOL = COMMA %START
 1169           SKIPSYMBOL
 1170           FORMAT = TAG;  F = LOOKUP(FORMAT)
 1171           DECVAR_FORMAT = F;  SIZE = VAR(F)_LENGTH;! IN BYTES
 1172           DECVAR_LENGTH = SIZE
 1173        %ELSE %IF TYPE = STRING
 1174           DECVAR_SIZE = SIZE
 1175           SIZE = SIZE+1
 1176           SIZE = (SIZE+1)&(\1) %IF FORM = ARRAY
 1177        %ELSE
 1178           SIZE = VSIZE(TYPE)
 1179        %FINISH
 1180        %IF 7 <= FORM <= 10 %START;! PROCEDURE
 1181           GTYPE = 1
 1182           F = LOOKUP(DECVAR_ID)
 1183           %IF F # NAMES %START;! SPEC GIVEN
 1184              NAMES = NAMES-1;  DECVAR == VAR(F);  %RETURN
 1185           %FINISH
 1186           %IF OTYPE # 0 %AND OTYPE # 7 %START;! TREAT AS INTRINSIC
 1187              PERMNO = PERMNO+1
 1188              DECVAR_DISP = PERMNO;  DECVAR_BASE = LINK
 1189              %RETURN
 1190           %FINISH
 1191           DECVAR_DISP = NEW TAG!X'4000'
 1192           DECVAR_BASE = CODE
 1193           DECVAR_TYPE=INTEGER %IF FORM=8 %AND (TYPE=BYTE %OR TYPE=SHORT)
 1194           %RETURN %UNLESS AMODE = 1 %AND GMODE # 0;! PARAMETER
 1195           OTYPE = 0;  TYPE = 0;  FORM = 1;  SIZE = 2*REGLEN
 1196        %FINISH
 1197  
 1198        DATA SIZE = SIZE
 1199        DECVAR_LENGTH = DATA SIZE
 1200  
 1201        %IF FORM # 1 %START
 1202           %IF TYPE = 0 %START
 1203              TYPE = 10;  SIZE = 2*REGLEN;  DECVAR_TYPE = 10
 1204           %ELSE %IF FORM = ARRAYNAME
 1205              SIZE = 2*REGLEN;  DECVAR_EXTRA = -1
 1206           %ELSE %IF FORM = ARRAY
 1207              SIZE = 0
 1208           %ELSE
 1209              SIZE = REGLEN
 1210           %FINISH
 1211        %FINISH
 1212        %IF OTYPE # 0 %START;! OWN DATA
 1213           %IF OTYPE = CON %START;! CONSTINTEGER ETC.
 1214              DATA SIZE = 0 %IF TF = X'41';! CONSTSTRING
 1215              OTYPE = 0 %IF (TYPE<=SHORT %AND (FORM<=2 %OR FORM = 5)) %C
 1216+                       %OR TF = X'52' %OR FORM = ARRAYNAME
 1217           %FINISH
 1218           OWNTYPE = TYPE;  OWNFORM = FORM
 1219           %IF FORM = ARRAY %START
 1220              GFIX(4)
 1221              DECVAR_EXTRA=GA;  GWORD(VLB);  GWORD(VUB);  GWORD(DATASIZE)
 1222              DECVAR_BASE = GLA;  DECVAR_DISP = GA-VLB*DATASIZE
 1223           %ELSE
 1224              OWNTYPE = INTEGER %AND DATA SIZE = REGLEN %IF FORM # 1
 1225              %IF OTYPE # 0 %START
 1226                 %IF TF # X'21' %START
 1227                    %IF TF = X'31' %OR TF = X'41' %THEN GFIX(2) %C
 1228+                                                 %ELSE GFIX(4)
 1229                 %FINISH
 1230                 %IF OWNFORM <= 2 %AND TYPE # RECORD %START
 1231                    SET DIAG(GLA, GA+DIAG GLA, TYPE, FORM)
 1232                    DIAG GLA = DIAG GLA+DATA SIZE
 1233                 %FINISH
 1234              %FINISH
 1235           %FINISH
 1236           %RETURN
 1237        %FINISH
 1238  
 1239        %IF FORM = SWITCH %START
 1240           GFIX(2)
 1241           DECVAR_BASE = GLA;  DECVAR_DISP = GA
 1242           GHALF(VLB);  GHALF(VUB)
 1243           DECVAR_EXTRA = GA-VLB*2
 1244           GHALF(0) %FOR F = VLB, 1, VUB
 1245           %RETURN
 1246        %FINISH
 1247  
 1248        %IF FORM = 4 %START
 1249           GTYPE = -1;  %RETURN
 1250        %FINISH
 1251  
 1252        %IF FORM = 1 %THEN F = ROUND(TYPE) %ELSE F = REGLEN-1
 1253        FRAME = (FRAME+F)&(\F)
 1254        %IF FRAME <= REGLEN %START;!  SPECIAL PARAMETER ?
 1255           %IF AMODE = 1 %AND GMODE # 0 %START;!  IN FP LIST
 1256              %IF (FORM = 2 %AND TYPE # 10) %OR TF = X'11' %C
 1257+                                           %OR TF = X'31' %START;! TO A REG
 1258                 DECVAR_BASE = PARAM;  DECVAR_DISP = FRAME
 1259                 DECVAR_DISP = DECVAR_DISP+(REGLEN-2) %IF TF = X'31'
 1260                 FRAME = FRAME-REGLEN;  FRAME = 11*REGLEN %IF FRAME < 0
 1261                 -> DECD;   ! ...GO DUMP DIAG. ENTRY
 1262              %FINISH
 1263           %FINISH
 1264           FRAME = 11*REGLEN %IF AMODE >= 0
 1265        %FINISH
 1266        DECVAR_BASE = LOCAL;  DECVAR_DISP = FRAME
 1267        FRAME = FRAME+SIZE
 1268  DECD: %IF AMODE = 0 %OR (AMODE = 1 %AND GG # SPEC) %START
 1269           %IF TYPE # RECORD %AND TYPE # 10 %START
 1270              %IF FORM = 1 %OR FORM = 2 %START
 1271                 SET DIAG(LOCAL, DECVAR_DISP, TYPE, FORM)
 1272              %FINISH
 1273           %FINISH
 1274        %FINISH
 1275     %END
 1276     %RECORD(STACKFM)%MAP DESCRIPTOR
 1277        %RECORD(STACKFM)%NAME V;  %RECORD(DFM)%NAME D
 1278        V == DESC ASL;  ABORT(17) %IF V == NULL
 1279        D == DASL;      ABORT(17) %IF D == NULL
 1280        DESC ASL == V_LINK;  V = 0
 1281        DASL == D_LINK;  D_LINK == USING_LINK;  USING_LINK == D
 1282        D_D == V
 1283        V_LINK ==NULL
 1284        %RESULT == V
 1285     %END
 1286     %ROUTINE DROP(%RECORD(STACKFM)%NAME D)
 1287        %RECORD(DFM)%NAME P, Q
 1288        P == USING
 1289        %CYCLE
 1290           Q == P_LINK
 1291           ABORT(18) %IF Q == NULL
 1292           %EXIT %IF Q_D == D
 1293           P == Q
 1294        %REPEAT
 1295        P_LINK == Q_LINK
 1296        Q_LINK == DASL;  DASL == Q
 1297        D_LINK == DESC ASL;  DESC ASL == D
 1298     %END
 1299     %ROUTINE STACK(%INTEGER DISP, BASE, TYPE, FORM, FORMAT, EXTRA, LENGTH)
 1300        %CONSTBYTEINTEGERARRAY FMAP(0:15) = CONSTANT, V IN S, A IN S,0(4),
 1301+                                       16,17,19,19,
 1302+                                       !0, V IN R, V IN S, V IN S,
 1303+                                       V IN S, A IN S,
 1304+                                       0(3)
 1305        %RECORD(STACKFM)%NAME V
 1306        STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
 1307        V == DESCRIPTOR
 1308        V_BASE = BASE
 1309        V_DISP = DISP
 1310        V_FORMAT = FORMAT
 1311        V_EXTRA = EXTRA;  V_DV = EXTRA
 1312        V_TYPE = TYPE
 1313        V_LENGTH = LENGTH
 1314        V_FORM = FMAP(FORM)
 1315        STACKED(STP)_V == V
 1316        LHS == V
 1317        SHOW(V) %IF CONTROL < 0
 1318     %END
 1319     %ROUTINE VSTACK(%RECORD(VARFM)%NAME V)
 1320        STACK(V_DISP, V_BASE, V_TYPE, V_FORM, V_FORMAT, V_EXTRA, V_LENGTH)
 1321     %END
 1322     %ROUTINE SSTACK(%RECORD(STACKFM)%NAME V)
 1323        %RECORD(STACKFM)%NAME T
 1324        STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
 1325        T == DESCRIPTOR;  T = V
 1326        STACKED(STP)_V == T;  CLAIM(T_BASE)
 1327        SHOW(T) %IF CONTROL < 0
 1328     %END
 1329     %ROUTINE C STACK(%INTEGER N)
 1330        RHS == DESCRIPTOR
 1331        RHS_BASE = 0
 1332        RHS_DISP = N
 1333        RHS_TYPE = INTEGER
 1334        RHS_FORM = CONSTANT
 1335        STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
 1336        STACKED(STP)_V == RHS
 1337        SHOW(RHS) %IF CONTROL < 0
 1338     %END
 1339     %ROUTINE  FP CSTACK(%REAL X, %RECORD(STACK FM)%NAME  R)
 1340        %RECORDFORMAT  F(%INTEGER  VAL, GDISP)
 1341        %CONSTINTEGER  L=31;    ! ... MUST BE 2\\N - 1
 1342        %OWNRECORD(F)%ARRAY CONST LIST(0:L)
 1343        %OWNSHORTINTEGER  LAST PNTR = 0, NEXT PNTR = 0
 1344        %INTEGER  N;  %SHORTINTEGER I
 1345  !!!      %RECORDFORMAT  FI(%INTEGER X)
 1346  !!!      %RECORDFORMAT  FR(%REAL X)
 1347  !!!      %RECORD(FR) RV;  %RECORD(FI)%NAME  IV
 1348  !!!      RV_X = X;  IV == RV;  N = IV_X
 1349  
 1350        %recordformat  convfm(%integer  n %or %real x)
 1351        %record(convfm)  conv
 1352        conv_x = x;  n = conv_n
 1353  
 1354        OWNVAL = N;  REALGA = GA
 1355  !
 1356        I = NEXT PNTR
 1357        %WHILE  I # LAST PNTR %CYCLE
 1358           I = (I-1)&L
 1359           -> FOUND IT %IF CONST LIST(I)_VAL = N
 1360        %REPEAT
 1361        GFIX(4);  I = GA;    ! FULLWORD ALIGN AND REMEMBER ADDR.
 1362        GWORD(N)
 1363        CONST LIST(NEXT PNTR)_VAL = N
 1364        CONST LIST(NEXT PNTR)_GDISP = I
 1365        I = NEXT PNTR;   ! ...FOR USE AT 'FOUND IT:'
 1366        NEXT PNTR = (NEXT PNTR+1)&L
 1367        LAST PNTR = (LAST PNTR+1)&L %IF LAST PNTR = NEXT PNTR
 1368  FOUND IT:
 1369        R_BASE = GLA
 1370        R_DISP = CONST LIST(I)_GDISP
 1371        R_TYPE = REALS
 1372        R_FORM = V IN S
 1373        STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
 1374        STACKED(STP)_V == R
 1375     %END
 1376     %ROUTINE SSET(%INTEGER BASE, DISP, FORM, EXTRA)
 1377        RHS == DESCRIPTOR
 1378        RHS_BASE = BASE
 1379        RHS_DISP = DISP
 1380        RHS_TYPE = INTEGER
 1381        RHS_FORM = FORM
 1382        RHS_EXTRA = EXTRA
 1383        STP = STP+1;  ABORT(7) %IF STP > MAX DEPTH
 1384        STACKED(STP)_V == RHS
 1385     %END
 1386     %ROUTINE SET LHS
 1387        LHS == STACKED(STP)_V
 1388     %END
 1389     %ROUTINE SET BOTH
 1390        ABORT(8) %IF STP <= 1
 1391        LHS == STACKED(STP-1)_V
 1392        RHS == STACKED(STP)_V
 1393     %END
 1394     %ROUTINE POP LHS
 1395        ABORT(8) %IF STP <= 0
 1396        LHS == STACKED(STP)_V
 1397        STP = STP-1
 1398     %END
 1399  
 1400   ! STRING PROCESSING
 1401  
 1402     %ROUTINE DUMP STRING(%INTEGER MAX)
 1403        %INTEGER J
 1404        GFIX(2)
 1405        %IF MAX <= 0 %START
 1406           ->OUT %IF ACTIVE STRING == NULL %OR (MAX < 0 %AND CSLEN = 0)
 1407           ACTIVE STRING_BASE = GLA;  ACTIVE STRING_DISP = GA
 1408           ACTIVE STRING_FORM = V IN S
 1409           MAX = CSLEN
 1410        %ELSE
 1411           MAX = MAX-1
 1412           ABORT(-13) %IF MAX < CSLEN
 1413        %FINISH
 1414        GBYTE(CURRENT STRING(J)) %FOR J = 0, 1, MAX
 1415        CSLEN = 0
 1416  OUT:  ACTIVE STRING == NULL
 1417     %END
 1418     %ROUTINE GET STRING
 1419        %INTEGER L, S
 1420        DUMP STRING(0) %UNLESS ACTIVE STRING == NULL
 1421        L = TAG;  SKIPSYMBOL %IF L # 0
 1422        CSLEN = 0
 1423        %WHILE L > 0 %CYCLE
 1424           L = L-1
 1425           READSYMBOL(S)
 1426           CSLEN = CSLEN+1;  CURRENT STRING(CSLEN) = S
 1427        %REPEAT
 1428        STACK(0, 0, STRING, 0, 0, 0, 0)
 1429        ACTIVE STRING == STACKED(STP)_V
 1430     %END
 1431  
 1432  ! LABEL PROCESSING
 1433  
 1434        %INTEGERFN NEW TAG
 1435           %OWNINTEGER TAG = 0
 1436           TAG = TAG+1
 1437           %RESULT = TAG
 1438        %END
 1439        %RECORD(LABELFM)%MAP NEW LABEL
 1440           LABS = LABS+1;  ABORT(-5) %IF LABS > MAX LABELS
 1441           FLAB == LABELS(LABS)
 1442           %RESULT == FLAB
 1443        %END
 1444        %RECORD(LABELFM)%MAP FIND(%INTEGER LABEL)
 1445           %INTEGER LP
 1446           LP = LABS
 1447           %WHILE LP # LABEL START %CYCLE
 1448              FLAB == LABELS(LP)
 1449              %RESULT == FLAB %IF FLAB_ID = LABEL
 1450              LP = LP-1
 1451           %REPEAT
 1452           %RESULT == NULL
 1453        %END
 1454        %ROUTINE DEFINE LABEL(%INTEGER LABEL)
 1455           %RECORD(ENVFM)%NAME E
 1456           %RECORD(LABELFM)%NAME L
 1457           L == FIND(LABEL)
 1458           %IF L == NULL %START
 1459              %IF CONTROL < 0 %START
 1460                 SELECTOUTPUT(REPORT)
 1461                 PRINTSTRING(" DEF:");  WRITE(LABEL, 2)
 1462                 PRINTSTRING("  LABS =");  WRITE(LABS, 2);  NEWLINE
 1463                 SELECTOUTPUT(OBJECT)
 1464              %FINISH
 1465              L == NEW LABEL
 1466              L_ID = LABEL;  L_TAG = NEW TAG;  L_REG = 0
 1467              LIMEN = CA
 1468              E == ENVIRONMENT(LABEL);  E_LABEL = 0
 1469           %ELSE %IF L_TAG < 0 %AND LABEL >= 0
 1470              L_TAG = NEW TAG;  L_REG = 0
 1471              E == ENVIRONMENT(LABEL);  E_LABEL = 0
 1472           %FINISH
 1473           L_TAG = L_TAG!X'8000'
 1474           DEFINE TAG(L_TAG&X'7FFF')
 1475           MERGE ENVIRONMENT(LABEL) %IF UNCOND JUMP # CA
 1476           RESTORE ENVIRONMENT(LABEL)
 1477           RT LAB = CA %IF LABEL = 0
 1478           CCCA = 0
 1479           UNCOND JUMP = 0;! YOU CAN GET HERE!
 1480        %END
 1481        %ROUTINE JUMP TO(%INTEGER LABEL, COND, DEF)
 1482           %INTEGER REF, LTAG
 1483           %RECORD(LABELFM)%NAME LAB
 1484           %RECORD(USEFM)%NAME U
 1485           INVERT = 0;! EXPEND CONDITION INVERSION
 1486           LAB == FIND(LABEL)
 1487           %IF LABEL = 0 %AND RT LAB = CA %START;! JUMP ROUND ROUTINE
 1488              LAB_TAG = LAB_TAG&X'7FFF';  %RETURN
 1489           %FINISH
 1490           %IF LAB == NULL %START
 1491              LAB == NEW LABEL
 1492              LAB_ID = LABEL;  LAB_REG = 0
 1493              LAB_TAG = NEW TAG
 1494              REMEMBER ENVIRONMENT(LABEL)
 1495           %ELSE %IF LAB_REG # 0 %AND SYM # 'B'
 1496              LAB_BASE = LAB_BASE!128
 1497              JUMP TO(LABEL+3, COND, DEF)
 1498              %RETURN
 1499           %ELSE %IF LAB_TAG < 0 %AND DEF = REDEFINE
 1500              LAB_REG = 0;  LAB_TAG = NEW TAG
 1501              REMEMBER ENVIRONMENT(LABEL)
 1502           %ELSE
 1503              MERGE ENVIRONMENT(LABEL) %IF LAB_TAG >= 0
 1504           %FINISH
 1505           LTAG = LAB_TAG&X'7FFF'
 1506           %IF LAB_REG # 0 %START
 1507              DEFINE LABEL(LABEL+3) %IF LAB_BASE&128 # 0
 1508              SSET(LAB_BASE&127, LAB_DISP, V IN S, 0)
 1509              LHS == RHS;  LOAD(LHS, LAB_REG)
 1510              SSET(0, LAB_LIMIT, CONSTANT, 0)
 1511              COMPARE(LHS, RHS);  COND = 1
 1512              STP = STP-2;  DROP(LHS);  DROP(RHS)
 1513           %FINISH
 1514           %IF COND = JUMP %THEN REF = J REF %ELSE REF = C REF
 1515           DEFINE REFERENCE(LTAG, REF)
 1516           DUMP(COND+X'8000');  CCCA = CCCA+2
 1517           UNCOND JUMP = CA %IF COND = JUMP;! NO WAY PAST HERE
 1518           %IF KNOWN_CA = 0 %START;! SOMETHING TO LEARN
 1519              KNOWN_CA = 1
 1520              U == USE(KNOWN_BASE)
 1521              U_TYPE = KNOWN_TYPE;  U_FORM = CONSTANT
 1522              U_BASE = 0;  U_DISP = KNOWN_DISP
 1523              U_CA = CA
 1524           %FINISH
 1525        %END
 1526     %ROUTINE FLOAT(%RECORD(STACKFM)%NAME V, %INTEGER REG)
 1527        %INTEGER  D
 1528        %IF V_FORM = CONSTANT %START
 1529        !  FLOAT CONSTANTS AT COMPILE-TIME
 1530           D = V_DISP
 1531           %IF D = 0 %START
 1532              REG = FPR %IF REG = ANYF
 1533              CLAIM(REG)
 1534              RR(SER, REG, REG);  CLAIM (REG)
 1535              V_BASE = REG;  V_DISP = 0;  V_TYPE = REALS;  V_FORM = V IN R
 1536           %ELSE
 1537              FP CSTACK(D,V);  ! ...N.B. 'D' FLOATED BY PARAMETER PASSING
 1538              STP = STP-1;      ! ...WE DON'T WANT A NEW STACK ITEM
 1539           %FINISH
 1540           %RETURN
 1541        %FINISH
 1542        LOAD(V, REG) %AND %RETURN %IF V_LOP # 0
 1543        LOAD(V, ANY)
 1544        REG = FPR %IF REG = ANYF
 1545        RR(FLR, REG, V_BASE)
 1546        CLAIM(REG)
 1547        V_TYPE = REALS;  V_FORM = V IN R
 1548        V_BASE = REG;  V_DISP = 0
 1549     %END
 1550     %ROUTINE LRD(%RECORD(STACKFM)%NAME V, %INTEGER REG)
 1551        LOAD(V, REG)
 1552        RELEASE(V_BASE)
 1553        DROP(V)
 1554     %END
 1555     %ROUTINE REDUCE(%RECORD(STACKFM)%NAME V)
 1556        %INTEGER TYPE, FORM, DISP
 1557        TYPE = V_TYPE;  FORM = V_FORM - 2
 1558        FORM = AV IN S  %IF FORM = AV IN REC-2
 1559        DISP = V_DISP
 1560        V_DISP = V_EXTRA;  V_TYPE = INTEGER;  V_FORM = V IN S
 1561        LOAD(V, ANY0)
 1562        V_TYPE = TYPE;  V_FORM = FORM
 1563        V_DISP = DISP
 1564     %END
 1565     %ROUTINE VMAP(%RECORD(STACKFM)%NAME V)
 1566        %INTEGER N
 1567        %CONSTBYTEINTEGERARRAY MAP(0:15) =
 1568+          V IN S, V IN S, V IN S, A IN S, V IN S,
 1569+          A IN REC, V IN S, V IN REC, 0(8)
 1570        LOAD(V, ANY0) %IF V_FORM = AINS %OR V_FORM = AINREC
 1571        %IF V_LOP # 0 %START
 1572           %IF V_LOP = ADD %AND CONST(V_LINK) %START
 1573              N = V_LINK_DISP
 1574              V_LOP = 0;  DROP(V_LINK)
 1575              %IF V_FORM = AVINS %OR V_FORM = AVINREC %START
 1576                 V_DISP = V_DISP+N
 1577              %ELSE
 1578                 LOAD(V, ANY0);  V_DISP = N
 1579              %FINISH
 1580           %ELSE
 1581              LOAD(V, ANY0)
 1582           %FINISH
 1583        %FINISH
 1584        V_FORM = MAP(V_FORM)
 1585     %END
 1586     %ROUTINE AMAP(%RECORD(STACKFM)%NAME V)
 1587        %CONSTSHORTINTEGERARRAY MAP(0:7) =
 1588+             -1, -1, V IN S, AV IN S, V IN REC, AV IN REC, -1, -1
 1589        V_FORM = MAP(V_FORM)
 1590        %IF  V_FORM = AV IN S %START
 1591           %IF  V_BASE = 0 %THEN  V_FORM = CONSTANT  %ELSE %START
 1592              V_FORM = V IN R %IF V_DISP = 0
 1593           %FINISH
 1594        %FINISH
 1595        ABORT(9) %IF V_FORM < 0
 1596        V_TYPE = INTEGER
 1597     %END
 1598     %ROUTINE OPTIMISE(%RECORD(STACKFM)%NAME V)
 1599        %INTEGER R
 1600        %RETURN %IF V_FORM = V IN R %OR V_LOP # 0
 1601        REDUCE(V) %IF V_FORM >= A IN REC %AND V_FORM # AV IN S
 1602        R = FIND USE(V_TYPE, V_FORM, V_BASE, V_DISP)
 1603        %IF R # 0 %START
 1604           V_BASE = R;  V_DISP = 0;  V_FORM = V IN R
 1605        %ELSE %IF V_FORM = A IN S
 1606           R = FIND USE(INTEGER, V IN S, V_BASE, V_DISP)
 1607           %RETURN %IF R = 0
 1608           V_BASE = R;  V_DISP = 0;  V_FORM = V IN S
 1609           OPTIMISE(V)
 1610        %FINISH
 1611     %END
 1612     %ROUTINE RANGE(%SHORTINTEGERNAME BASE, %INTEGERNAME DISP)
 1613        %RECORD(STACKFM) V
 1614        %RETURN %IF 0 <= DISP <= X'3FFF'
 1615        V_TYPE = INTEGER;  V_FORM = AV IN S
 1616        V_BASE = BASE;  V_DISP = DISP&(\X'3FFF')
 1617        DISP = DISP-V_DISP
 1618        V_LOP = 0
 1619        LOAD(V, ANY0)
 1620        BASE = V_BASE
 1621     %END
 1622     %ROUTINE ADDRESS(%RECORD(STACKFM)%NAME V)
 1623        %INTEGER TYPE, FORM
 1624        FORM = V_FORM;  TYPE = V_TYPE
 1625        %IF FORM = V IN REC %OR FORM = A IN REC %START
 1626           REDUCE(V);  FORM = V_FORM
 1627        %FINISH
 1628        %UNLESS FORM = V IN S %OR FORM = V IN R %START
 1629           %IF FORM = A IN S %START
 1630              FORM = V IN S;  V_FORM = FORM
 1631              V_TYPE = INTEGER
 1632              LOAD(V, ANY0)
 1633           %ELSE
 1634              LOAD(V, ANY)
 1635              FORM = V IN R;  TYPE = INTEGER
 1636           %FINISH
 1637        %FINISH
 1638        RANGE(V_BASE, V_DISP)
 1639        V_TYPE = TYPE;  V_FORM = FORM
 1640     %END
 1641     %ROUTINE LOAD(%RECORD(STACKFM)%NAME V, %INTEGER R)
 1642        %RECORD(STACKFM) H
 1643        %CONSTSHORTINTEGERARRAY OP KEY(1:17) = -1, 0, 0, 6, 4, 2, 0,
 1644+                                               0, 5,10, 0, 2, 0, 0, 0,0 ,0
 1645        %CONSTSHORTINTEGERARRAY PM(0:11) =
 1646+                       AR, AIS, AHI, AW, AH, AI,
 1647+                       SR, SIS, SHI, SW, SH, SI
 1648        %CONSTSHORTINTEGERARRAY MULDIV(0:5) = DR, DW,
 1649+                                             MR, MW,
 1650+                                             MR, MW
 1651        %CONSTSHORTINTEGERARRAY LOGICAL(0:14) =
 1652+                                            NR, NHI, NW, NH, NI,
 1653+                                            OR, OHI, OW, OH, OI,
 1654+                                            XR, XHI, XW, XH, XI
 1655  
 1656        %CONSTSHORTINTEGERARRAY SHIFT(0:3) = SLLS, SLL, SRLS, SRL
 1657  
 1658        %CONSTSHORTINTEGERARRAY REAL OP(3:14) = AER, SER, 0,
 1659+                                               MER, DER, 0, 0,
 1660+                                               AE, SE, 0,
 1661+                                               ME, DE
 1662        %INTEGERFN PRED(%INTEGER R)
 1663           %CONSTBYTEINTEGERARRAY INV(0:15) = R0, R1, R2, R3,
 1664+                                             R4, P2, P1, WSP,
 1665+                                             LINK, R9, R10, R11,
 1666+                                             R12, GLA, CODE, R15
 1667           %RESULT = INV(ACTUAL(R)!!1)
 1668        %END
 1669        %RECORD(STACKFM)%NAME W
 1670        %SWITCH F(0:8), IOP(1:17), ROP(1:17)
 1671        %INTEGER OP, T, D, TYPE, FORM, KEY, TEMP, N
 1672        %OWNINTEGER  ADDXCA=0, ADDXD=0, ADDXS=0, ADDXKEY=0
 1673  
 1674        ABORT(-2) %IF FREE SPACE < MIN FREE;   ! ...STACK OVERFLOW?
 1675        ->REALZ %IF FLOATING(V) %OR FPR0 <= R <= FPR14 %OR R = ANYF
 1676        OP = V_LOP;  V_LOP = 0
 1677        %IF OP # 0 %START
 1678           W == V_LINK
 1679           OPTIMISE(V);  OPTIMISE(W) %UNLESS W == NULL
 1680           %IF OP = SUB %AND W_FORM = CONSTANT %START
 1681              OP = ADD;  W_DISP = -W_DISP
 1682           %FINISH
 1683           %IF COMM(OP) # 0 %START;! SWOP OPERANDS ?
 1684              T = 0
 1685              T = 1 %IF W_BASE = R %OR (W_FORM = V IN R %AND V_FORM # V IN R)
 1686              T = 1 %IF V_TYPE # BYTE %AND W_TYPE = BYTE %AND V_BASE # R
 1687              T = 1 %IF W_FORM = CONSTANT %AND R < ANY %AND R # V_BASE %C
 1688+                                         %AND V_TYPE # BYTE
 1689              T = 0 %IF V_BASE = R %C
 1690+                   %OR (W_FORM = V IN R %AND ACTIVITY(W_BASE) < 0)
 1691              %IF T # 0 %START
 1692                 H = W;  W = V;  V = H
 1693              %FINISH
 1694           %FINISH
 1695           %IF CONTROL&UNASS DIAG # 0 %START
 1696              LOAD(W, ANY0) %UNLESS W_FORM = CONSTANT %C
 1697+                               %OR (W_TYPE # INTEGER %AND W_TYPE # REALS)
 1698           %FINISH
 1699           KEY = OP KEY(OP)
 1700           ->IOP(OP)
 1701        %FINISH
 1702        %IF V_TYPE = STRING %OR V_TYPE = 0 %START
 1703           AMAP(V)
 1704        %FINISH
 1705        %IF  V_FORM > V IN S  %AND  V_FORM # AV IN S  %THEN REDUCE(V)
 1706        OPTIMISE(V)
 1707        %IF R >= ANY %START
 1708           %RETURN %IF V_FORM = V IN R %AND (R = ANY %OR V_BASE # R0) %C
 1709+                                      %AND ACTIVITY(V_BASE) >= 0
 1710           R = GPR(R-ANY)
 1711        %ELSE
 1712           HAZARD(R) %UNLESS V_BASE = R %AND ACTIVITY(R) = 1
 1713        %FINISH
 1714        ->F(V_FORM)
 1715  F(AV IN REC):
 1716  F(A IN REC):
 1717  F(V IN REC):
 1718        CLAIM(R);  REDUCE(V);  RELEASE(R)
 1719        ->F(V_FORM)
 1720  F(AV IN S):
 1721        ABORT(10) %IF V_TYPE = REALS
 1722        %IF V_BASE # R0 %START
 1723           %IF -X'8000' <= V_DISP <= X'7FFF' %START
 1724              %IF V_DISP # 0 %START
 1725                 RI2(LHI, R, V_BASE, V_DISP)
 1726              %ELSE
 1727                 RR(LR,R,V_BASE)
 1728              %FINISH
 1729           %ELSE
 1730              RI3(LI, R, V_BASE, V_DISP)
 1731           %FINISH
 1732           CLAIM(R)
 1733           REMEMBER(R, V)
 1734           V_BASE = R;  V_DISP = 0
 1735           V_TYPE = INTEGER;  V_FORM = V IN R
 1736           %RETURN
 1737        %FINISH
 1738  F(CONSTANT):
 1739        ABORT(16) %IF V_TYPE = REALS
 1740        D = V_DISP
 1741        %IF -15 <= D <= 15 %START
 1742           %IF D >= 0 %START
 1743              SF(LIS, R, D)
 1744           %ELSE
 1745              SF(LCS, R, -D)
 1746           %FINISH
 1747        %ELSE
 1748           %IF -X'8000' <= D <= X'7FFF' %START
 1749              RI2(LHI, R, 0, D)
 1750           %ELSE
 1751              RI3(LI, R, 0, D)
 1752           %FINISH
 1753        %FINISH
 1754        CLAIM(R);  REMEMBER(R, V)
 1755        V_BASE = R;  V_DISP = 0
 1756        V_TYPE = INTEGER;  V_FORM = V IN R
 1757        %RETURN
 1758  F(V IN R):
 1759        OP = LR
 1760        %RETURN %IF V_BASE = R
 1761        OP = LER %IF V_TYPE = REALS
 1762        RR(OP, R, V_BASE);  CLAIM(R)
 1763        CCREG = R;  CCCA = CA
 1764        FORGET(R)
 1765        USE(R) = USE(V_BASE)
 1766        V_BASE = R
 1767        %RETURN
 1768  F(A IN S):
 1769        TYPE = V_TYPE
 1770        V_TYPE = INTEGER;  V_FORM = V IN S
 1771        CLAIM(R);  LOAD(V, ANY0);  RELEASE(R)
 1772        V_TYPE = TYPE;  V_FORM = V IN S
 1773  F(V IN S):
 1774        RANGE(V_BASE, V_DISP)
 1775        CCREG = R;  CCCA = CA+4
 1776        %IF V_TYPE = INTEGER %START
 1777           OP = LW
 1778        %ELSE %IF V_TYPE = SHORT
 1779           OP = LH
 1780        %ELSE %IF V_TYPE = BYTE
 1781           OP = LB;  CCCA = 0
 1782        %ELSE %IF V_TYPE = REALS
 1783           OP = LE
 1784        %ELSE
 1785           OP = LHL;        ! INTERNALLY GENERATED 'UNSIGNED HALFWORD'
 1786        %FINISH
 1787        RX(OP, R, V_BASE, V_DISP)
 1788        CLAIM(R);  REMEMBER(R, V)
 1789        V_BASE = R;  V_DISP = 0
 1790        V_FORM = V IN R
 1791        %RETURN
 1792  IOP(ADD):
 1793        %IF W_FORM = V IN R %AND W_BASE # R %AND V_FORM = CONSTANT %START
 1794           D = V_DISP
 1795           %IF (USE(W_BASE)_CA > LIMEN %OR USE(W_BASE+STORE)_CA > LIMEN %C
 1796+                %OR D < -15 %OR D > 15) %AND CA # ADDXCA %START
 1797              %IF R >= ANY %START
 1798                 R = GPR(R-ANY)
 1799              %ELSE %IF W_BASE # R %OR ACTIVITY(R) # 1
 1800                 HAZARD(R)
 1801              %FINISH
 1802              %IF -X'8000'<=D<=X'7FFF' %THEN RI2(LHI,R,W_BASE,D) %C
 1803+                %ELSE RI3(LI,R,W_BASE,D)
 1804              CCREG = R;  CCCA = CA
 1805              V_DISP = 0;  V_FORM = V IN R
 1806              V_BASE = R;  CLAIM(R)
 1807              ->END OP
 1808           %FINISH
 1809        %FINISH
 1810  IOP(SADD):
 1811  IOP(SUB):
 1812        LOAD(V, R);  R = V_BASE
 1813        LOAD(W, ANY) %IF W_TYPE = BYTE %OR W_TYPE = UNSIGNED HALFWORD
 1814        %IF W_FORM = CONSTANT %START
 1815           D = W_DISP
 1816           %IF -15 <= D <= 15 %START
 1817              D = -D %AND KEY = 6-KEY %IF D < 0
 1818              SF(PM(KEY+1), R, D)
 1819           %ELSE
 1820              %IF -X'8000' <= D <= X'7FFF' %START
 1821                 %IF CA = ADDXCA %AND R = ADDXD %START
 1822                    D = -D %IF ADDXKEY # KEY
 1823                    DUMP(D)
 1824                    PATCH(PM(ADDXKEY+2)+ACTUAL(R)<<4+ACTUAL(ADDXS),   %C
 1825+                                                                ADDXCA-2)
 1826                 %FINISH %ELSE RI2(PM(KEY+2), R, 0, D)
 1827              %ELSE
 1828                 RI3(PM(KEY+5), R, 0, D)
 1829              %FINISH
 1830           %FINISH
 1831        %ELSE %IF W_FORM = V IN R
 1832           RR(PM(KEY), R, W_BASE)
 1833           ADDXCA = CA;  ADDXD = R;  ADDXKEY = KEY;  ADDXS = W_BASE
 1834        %ELSE %IF W_FORM = AV IN S
 1835           RI2(PM(KEY+2), R, W_BASE, W_DISP)
 1836        %ELSE
 1837           ADDRESS(W)
 1838           KEY = KEY-1 %IF W_FORM = V IN R
 1839           KEY = KEY+1 %IF W_TYPE = SHORT
 1840           RX(PM(KEY+3), R, W_BASE, W_DISP)
 1841        %FINISH
 1842        ->SET CC
 1843  IOP(MUL):
 1844  IOP(DIV):
 1845  IOP(REM):
 1846        %IF R >= ANY %START
 1847           %IF KEY = 0 %THEN N = 0 %ELSE N = 1
 1848           %IF V_FORM = V IN R %AND ACTUAL(V_BASE)&1 = N %C
 1849+                              %AND ACTIVITY(PRED(V_BASE)) = 0 %START
 1850              TEMP = V_BASE
 1851              TEMP = PRED(TEMP) %IF KEY = 0
 1852           %ELSE
 1853              TEMP = EVEN ODD PAIR
 1854           %FINISH
 1855        %ELSE %IF ACTUAL(R)&1 = 0 %OR ACTIVITY(PRED(R)) # 0
 1856           TEMP = EVEN ODD PAIR
 1857        %ELSE
 1858           TEMP = R
 1859        %FINISH
 1860        N = PRED(TEMP);  HAZARD(N)
 1861        %IF KEY # 0 %START
 1862           CLAIM(N);  LOAD(V, TEMP)
 1863        %ELSE
 1864           CLAIM(TEMP);  LOAD(V, N)
 1865           RR(LR, TEMP, N)
 1866           USE(TEMP) = USE(N);  USE(TEMP+STORE) = USE(N)
 1867           CLAIM(N)
 1868           RX(SRA, N, 0, 31);  FORGET(N)
 1869        %FINISH
 1870        LOAD(W,ANY) %IF W_FORM = CONSTANT %OR W_TYPE # INTEGER
 1871        ADDRESS(W)
 1872        %IF W_FORM = V IN R %START
 1873           RR(MULDIV(KEY), N, W_BASE)
 1874        %ELSE
 1875           RX(MULDIV(KEY+1), N, W_BASE, W_DISP)
 1876        %FINISH
 1877        %IF OP = REM %START
 1878           D = TEMP;  TEMP = N;  N = D
 1879        %FINISH
 1880        RELEASE(N)
 1881        FORGET(N);  FORGET(TEMP)
 1882        V_BASE = TEMP;  V_DISP = 0;  V_FORM = V IN R
 1883        LOAD(V, R) %IF TEMP # R
 1884        ->END OP
 1885  IOP(AND):
 1886        %IF V_FORM = CONSTANT %AND V_DISP = 255 %START
 1887           %IF W_FORM = V IN R %START
 1888              %IF R >= ANY %START
 1889                 %IF ACTIVITY(W_BASE) = 1 %THEN R = W_BASE %C
 1890+                                         %ELSE R = GPR(R-ANY)
 1891              %ELSE %IF R # W_BASE %OR ACTIVITY(R) # 1
 1892                 HAZARD(R)
 1893              %FINISH
 1894           %ELSE
 1895              LOAD(W,R);  R = W_BASE
 1896           %FINISH
 1897           CLAIM(R)
 1898           RR(LBR,R,W_BASE)
 1899           V_BASE = R;  V_DISP = 0;  V_FORM = V IN R
 1900           -> FEND
 1901        %FINISH
 1902  IOP(IOR):
 1903  IOP(XOR):
 1904        %IF W_FORM = CONSTANT %AND -15 <= W_DISP <= 15 %START
 1905           %IF V_FORM # V IN R %OR (R < ANY %AND V_BASE # R) %START
 1906              H = W;  W = V;  V = H
 1907           %FINISH
 1908        %FINISH
 1909        LOAD(V, R);  R = V_BASE
 1910        LOAD(W, ANY) %IF W_TYPE = BYTE
 1911        %IF W_FORM = CONSTANT %START
 1912           %IF KEY = 0 %AND W_DISP = 255 %START;!  N&255
 1913              CLAIM(R)
 1914              RR(LBR, R, R);  -> FEND
 1915           %FINISH
 1916           %IF -X'8000' <= W_DISP <= X'7FFF' %START
 1917              RI2(LOGICAL(KEY+1), R, 0, W_DISP)
 1918           %ELSE
 1919              RI3(LOGICAL(KEY+4), R, 0, W_DISP)
 1920           %FINISH
 1921        %ELSE %IF W_FORM = V IN R
 1922           RR(LOGICAL(KEY), R, W_BASE)
 1923        %ELSE
 1924           ADDRESS(W)
 1925           KEY = KEY+1 %IF W_TYPE = SHORT %OR W_TYPE = UNSIGNED HALFWORD
 1926           RX(LOGICAL(KEY+2), R, W_BASE, W_DISP)
 1927        %FINISH
 1928        ->SET CC
 1929  IOP(RSH):
 1930  IOP(LSH):
 1931        LOAD(V, R);  R = V_BASE
 1932        !  IGNORE ANY VALUE IN A REGISTER WHICH HAPPENS TO BE THE
 1933        !  SAME AS A CONSTANT SHIFT COUNT <=15 AS OTHERWISE THE LONG FORM
 1934        !  OF SHIFT INSTRUCTION WILL BE GENERATED NEEDLESSLY.
 1935        %IF W_FORM = V IN R %AND USE(W_BASE)_CA > LIMEN  %C
 1936+                           %AND USE(W_BASE)_FORM = CONSTANT  %C
 1937+                           %AND 0 <= USE(W_BASE)_DISP <= 15  %START
 1938           W_DISP = USE(W_BASE)_DISP
 1939           W_FORM = CONSTANT
 1940           RELEASE(W_BASE)
 1941        %FINISH
 1942        %IF W_FORM = CONSTANT %START
 1943           %IF KEY = 0 %AND W_DISP = 1 %START
 1944              CLAIM(R)
 1945              RR(AR, R, R)
 1946           %ELSE %IF W_DISP > 15
 1947              RX(SHIFT(KEY+1), R, 0, W_DISP)
 1948           %ELSE
 1949              SF(SHIFT(KEY), R, W_DISP&15)
 1950           %FINISH
 1951        %ELSE
 1952           LOAD(W, ANY0)
 1953           RX(SHIFT(KEY+1), R, W_BASE, 0)
 1954        %FINISH
 1955        ->SET CC
 1956  IOP(NEG):
 1957  IOP(NOT):
 1958        %IF V_BASE = R %START
 1959           LOAD(V, R)
 1960           RI2(XHI, V_BASE, 0, -1)
 1961           SF(AIS, V_BASE, 1) %IF KEY = 0
 1962        %ELSE
 1963           W == RHS;  CSTACK(KEY);  RHS == W
 1964           SSTACK(V);  RELEASE(V_BASE);  V_BASE = 0
 1965           OPERATE(SUB);  STP = STP-1
 1966           V = STACKED(STP+1)_V;  DROP(STACKED(STP+1)_V)
 1967           LOAD(V, R)
 1968        %FINISH
 1969        FORGET(V_BASE)
 1970        CCREG = V_BASE;  CCCA = CA
 1971        %RETURN
 1972  IOP(EXP):
 1973        LOAD(V, R2);  LOAD(W, R3)
 1974        RELEASE(R2);  RELEASE(R3)
 1975        PERM(IEXP)
 1976        CLAIM(R1);  V_BASE = R1
 1977        ->END OP
 1978  IOP(CONC):
 1979        %IF V_TYPE # 0 %START
 1980           LOAD(V, R1);  RELEASE(R1)
 1981           HAZARD(R2)
 1982           %IF WDISP = 0 %START
 1983              RR(LR , R2, WSP)
 1984           %ELSE
 1985              RI2(LHI, R2, WSP, WDISP)
 1986           %FINISH
 1987           FORGET(R2)
 1988           WDISP = WDISP+256
 1989           PERM(CONC1)
 1990        %ELSE
 1991           LOAD(V, R2);  RELEASE(R2)
 1992        %FINISH
 1993        JOIN(W)
 1994        CLAIM(R2)
 1995        V_TYPE = 0;  V_FORM = V IN S
 1996        V_BASE = R2;  V_DISP = 0
 1997        %IF R # ANY %START;! NOT FROM OPERATE
 1998           LOAD(V, R);  V_TYPE = 0;  V_FORM = V IN S
 1999        %FINISH
 2000        %RETURN
 2001  REALZ:ABORT(11) %IF R = ANY;     ! ...SHOULD BE FLOATING REGISTER!!!
 2002        OP = V_LOP;  V_LOP = 0
 2003        %IF OP # 0 %START
 2004           -> ROP NEG %IF OP = NEG
 2005           W == V_LINK
 2006  IOP(RDIV):
 2007           FLOAT(W, ANYF) %IF W_TYPE # REALS %AND OP # EXP
 2008           FLOAT(V, R) %IF V_TYPE # REALS
 2009           %IF OP = ADD %OR OP = MUL %START
 2010              OPTIMISE(V);  OPTIMISE(W) %UNLESS W == NULL
 2011              %IF W_BASE=R %OR (V_FORM # V IN R %AND W_FORM = V IN R) %START
 2012                 H = W;  W = V;  V = H
 2013              %FINISH
 2014           %FINISH
 2015           ADDRESS(W) %UNLESS W == NULL
 2016           ->ROP(OP)
 2017  ROP(NOT):ROP(LSH):  ROP(RSH):
 2018  ROP(AND):ROP(IOR):    ROP(XOR):
 2019           REAL ERROR(OP)
 2020  ROP(RDIV):OP = DIV
 2021  ROP(ADD):
 2022  ROP(SUB):
 2023  ROP(MUL):
 2024           LOAD(V, R);  R = V_BASE
 2025           %IF W_FORM = V IN R %START
 2026              RR(REALOP(OP), R, W_BASE)
 2027           %ELSE
 2028              RX(REALOP(OP+7), R, W_BASE, W_DISP)
 2029           %FINISH
 2030           ->SET CC
 2031  ROP NEG:
 2032  ROP(NEG):LOAD(V, ANYF) %IF V_BASE = R
 2033           R = FPR %IF R = ANYF
 2034           HAZARD(R)
 2035           CLAIM(R);  RR(SER, R, R);  CLAIM(R)
 2036           ADDRESS(V)
 2037           %IF V_FORM = V IN R %START
 2038              RR(SER, R, V_BASE)
 2039           %ELSE
 2040              RX(SE, R, V_BASE, V_DISP)
 2041           %FINISH
 2042           CCREG = R;  CCCA = CA
 2043           FORGET(R)
 2044           V_BASE = R;  V_DISP = 0
 2045           V_FORM = V IN R
 2046           %RETURN
 2047        %FINISH
 2048        FLOAT(V, R) %IF V_TYPE # REALS
 2049        OPTIMISE(V)
 2050        %IF V_FORM = V IN R %START
 2051           %RETURN %IF R = ANYF %OR V_BASE = R
 2052           RR(LER, R, V_BASE);  USE(R) = USE(V_BASE)
 2053           V_BASE = R;  CLAIM(V_BASE)
 2054           CCREG = R;  CCCA = CA
 2055           %RETURN
 2056        %FINISH
 2057        R = FPR %IF R = ANYF
 2058        ABORT(12) %UNLESS FPR0 <= R <= FPR14
 2059        ->F(V_FORM)
 2060  ROP(EXP):
 2061        REAL ERROR(1) %AND W_TYPE = INTEGER %IF W_TYPE = REALS
 2062        LOAD(V, FPR2);  LOAD(W, R1)
 2063        RELEASE(FPR2);  RELEASE(R1)
 2064        PERM(REXP)
 2065        CLAIM(FPR0);  V_BASE = FPR0
 2066        ->ENDOP
 2067  SET CC:
 2068        CCCA = CA;  CCREG = R
 2069  FEND: FORGET(R)
 2070  END OP:DROP(W)
 2071     %END
?FORM unused
 2072        %ROUTINE COP(%INTEGER OP, %INTEGERNAME L, %INTEGER R)
 2073           %SWITCH S(1:17)
 2074           ->S(OP)
 2075  S(SADD):
 2076  S(RDIV):
 2077  S(NEG):
 2078  S(NOT):
 2079  S(CONC):    ABORT(13)
 2080  S(ADD):     L = L+R;    %RETURN
 2081  S(SUB):     L = L-R;    %RETURN
 2082  S(IOR):     L = L!R;    %RETURN
 2083  S(AND):     L = L&R;    %RETURN
 2084  S(XOR):     L = L!!R;   %RETURN
 2085  S(LSH):     L = L<<R;   %RETURN
 2086  S(MUL):     L = L*R;    %RETURN
 2087  S(RSH):     L = L>>R;   %RETURN
 2088  S(EXP):     L = L\\R;   %RETURN
 2089  S(DIV):     ABORT(-6) %AND R = 1 %IF R = 0
 2090              L = L//R;   %RETURN
 2091  S(REM):     ABORT(-6) %AND R = 1 %IF R = 0
 2092              L = L-L//R*R
 2093        %END
 2094        %ROUTINE JOIN(%RECORD(STACKFM)%NAME W)
 2095           %RECORD(STACKFM)%NAME QW
 2096           %CYCLE
 2097              QW == W_LINK;  W_LOP = 0
 2098              LRD(W, R1);  PERM(CONC2)
 2099              %EXIT %IF QW == NULL
 2100              W == QW
 2101           %REPEAT
 2102        %END
 2103        %ROUTINE OPERATE(%INTEGER OPER)
 2104           %CONSTINTEGERARRAY NULL OP(3:17) = 0,0,1,1,1,-1,0(4),1,0,0,1,1
 2105           %INTEGER RCON, LCON, WCON, LOP
 2106           %INTEGER KEY, D, S
 2107           %RECORD(STACKFM)%NAME WITH, LH, RH
 2108           %CONSTBYTEINTEGERARRAY TRANS(1:17) = 2,2,0,0,1(6),2(4),0,15,15
 2109  
 2110           %ROUTINE  SWOP
 2111              WCON = LCON;  LCON = RCON;  RCON = WCON
 2112              WITH == LH;  LH == RH;  RH == WITH
 2113              STACKED(STP)_V == LH
 2114           %END
 2115           %ROUTINE  PICKUP(%RECORD(STACKFM)%NAME  V)
 2116              %IF FLOATING(V) %THEN LOAD(V,ANYF) %ELSE LOAD(V,ANY)
 2117           %END
 2118  
 2119           %IF OPER <= NEG %START;! UNARY
 2120              LH == STACKED(STP)_V
 2121              %IF CONST(LH) %START
 2122                 LH_DISP = \LH_DISP+OPER-1
 2123              %ELSE
 2124                 PICKUP(LH) %IF LH_LOP # 0
 2125                 LH_LOP = OPER;  LH_LINK == NULL
 2126              %FINISH
 2127              %RETURN
 2128           %FINISH
 2129           STP = STP-1
 2130           LCON = 0;  RCON = 0;  WCON = 0
 2131           LH == STACKED(STP)_V
 2132           RH == STACKED(STP+1)_V
 2133           LCON = 1 %IF CONST(LH)
 2134           RCON = 1 %IF CONST(RH)
 2135           %IF OPER = SUB %AND RCON # 0 %START
 2136              OPER = ADD;  RH_DISP = -RH_DISP
 2137           %FINISH
 2138           %IF LH_LOP # 0 %START
 2139              LOP = LH_LOP
 2140              %IF OPER = CONC %START
 2141                 WITH == LH
 2142                 WITH == WITH_LINK %WHILE WITH_LOP # 0
 2143                 WITH_LINK == RH
 2144                 WITH_LOP = CONC
 2145                 %RETURN
 2146              %FINISH
 2147              WITH == LH_LINK
 2148              WCON = 1 %IF OPER > NEG %AND CONST(WITH)
 2149              %IF LOP = NEG %AND OPER = ADD %START
 2150                 RH_LOP = SUB;  RH_LINK == LH
 2151                 LH_LOP = 0
 2152                 STACKED(STP)_V == RH
 2153                 %RETURN
 2154              %FINISH
 2155              DUMP STRING(0) %IF WITH_TYPE = STRING
 2156              %IF WCON&RCON # 0 %START
 2157                 KEY = TRANS(OPER)!TRANS(LOP)
 2158                 %IF KEY = 0 %OR (KEY = 1 %AND OPER = LOP) %START
 2159                    COP(OPER, WITH_DISP, RH_DISP);  DROP(RH)
 2160                    %IF WITH_DISP = NULL OP(OPER) %START
 2161                       LH_LOP = 0;  DROP(WITH)
 2162                    %FINISH
 2163                    %RETURN
 2164                 %FINISH
 2165              %FINISH
 2166              PICKUP(LH)
 2167           %FINISH
 2168           %IF LCON&RCON # 0 %AND OPER # RDIV %START
 2169              COP(OPER, LH_DISP, RH_DISP);  DROP(RH);  %RETURN
 2170           %FINISH
 2171           %IF LCON # 0 %AND COMM(OPER) # 0 %START
 2172              SWOP
 2173              PICKUP(LH) %IF LH_LOP # 0
 2174           %FINISH
 2175           %IF RCON # 0 %AND (OPER = AND %OR OPER = RSH) %C
 2176+                 %AND (CONTROL&UNASS DIAG = 0 %OR LH_TYPE = SHORT) %START
 2177              OPTIMISE(LH)
 2178              %IF LH_FORM # V IN R %AND (LH_TYPE = INTEGER %OR  %C
 2179+                                            LH_TYPE = SHORT) %START
 2180                 ADDRESS(LH)
 2181                 %IF OPER = AND %START
 2182                    S = LH_TYPE;  D = 0
 2183                    D = REGLEN//2 %IF LH_TYPE = INTEGER
 2184                    %IF RH_DISP = 255 %START
 2185                       S = BYTE;  D = D + REGLEN//4
 2186                    %ELSE %IF RH_DISP>>16 = 0
 2187                       RH_DISP = RH_DISP!X'FFFF0000' %IF RH_DISP>>15#0
 2188                       LH_TYPE = UNSIGNED HALFWORD
 2189                       LH_DISP = LH_DISP+D
 2190                       D = -1
 2191                    %ELSE
 2192                       D = -1
 2193                    %finish
 2194                    %IF D >= 0 %START
 2195                       LH_TYPE = S;  LH_DISP = LH_DISP + D
 2196                       DROP(RH);  %RETURN
 2197                    %FINISH
 2198                 %ELSE;                !...'OPER' MUST BE RSH
 2199                    %IF RH_DISP = (8*REGLEN)//2 %C
 2200+                      %AND LH_TYPE # SHORT %START
 2201                       S = UNSIGNED HALFWORD
 2202                    %ELSE %IF RH_DISP = 8*(REGLEN-1)
 2203                       S = BYTE
 2204                    %ELSE
 2205                       S = -1
 2206                    %finish
 2207                    %IF  S >= 0 %START
 2208                       LH_TYPE = S;  DROP(RH);  %RETURN
 2209                    %FINISH
 2210                 %FINISH
 2211              %FINISH
 2212           %FINISH
 2213           PICKUP(RH) %IF RH_LOP # 0
 2214           %IF LCON!RCON # 0 %AND OPER = MUL %START
 2215              SWOP %IF LCON # 0
 2216              %IF FLOATING(LH) %THEN KEY = -1 %C
 2217+                               %ELSE KEY = POWER(RH_DISP)
 2218              %IF KEY >= 0 %START
 2219                 RH_DISP = KEY;  OPER = LSH
 2220              %ELSE
 2221                 SWOP
 2222              %FINISH
 2223           %FINISH
 2224           DROP(RH) %AND %RETURN %IF RCON # 0 %AND RH_DISP = NULL OP(OPER)
 2225           LH_LOP = OPER;  LH_LINK == RH
 2226        %END
 2227        %PREDICATE DIFFERENT(%RECORD(STACKFM)%NAME A, B)
 2228           %WHILE %NOT B == NULL %CYCLE
 2229              %FALSE %IF SAME(A, B)
 2230              B == B_LINK
 2231           %REPEAT
 2232           %TRUE
 2233        %END
 2234        %ROUTINE ASSIGN(%INTEGER ASSOP)
 2235           %RECORD(STACKFM)%NAME LHS, RHS, W
 2236           %RECORD(STACKFM) TEMP, HOLD
 2237           %INTEGER N, P, T, OP, VAL, SIZE
 2238           ABORT(8) %IF STP < 2
 2239           RHS == STACKED(STP)_V
 2240           LHS == STACKED(STP-1)_V
 2241           %IF ASSOP < 0 %START
 2242              %IF LHS_BASE = LINK %START;! INTRINSIC
 2243                 TEMP = LHS;  LHS = RHS;  RHS = TEMP
 2244                 NEW DISP = 0
 2245                 %RETURN
 2246              %FINISH
 2247              LHS_EXTRA = LHS_EXTRA-1
 2248              V == VAR(LHS_EXTRA)
 2249              DISPLAY VAR(V) %IF CONTROL < 0
 2250              VSTACK(V);  LHS == STACKED(STP)_V
 2251              ASSOP = 0 %IF V_FORM > 1
 2252              NEW DISP = LHS_DISP+LHS_LENGTH
 2253              %IF LHS_FORM&16 # 0 %START;! PROCEDURE PARAMETER
 2254                 FORGET(LINK);  HAZARD(R0)
 2255                 NEW DISP = LHS_DISP+2*REGLEN
 2256                 %IF RHS_DISP&X'4000' # 0 %START
 2257                    RX(ST, WSP, WSP, LHS_DISP);! ENVIRONMENT REF
 2258                    DEFINE REFERENCE(RHS_DISP&X'FFF', R REF)
 2259                    RX(LA, LINK, CODE, 0);       !  ADDRESS OF ROUTINE
 2260                    RX(ST, LINK, WSP, LHS_DISP+REGLEN);  ! ENVIRONMENT
 2261                 %ELSE
 2262                    RX(LW, LINK, RHS_BASE, RHS_DISP)
 2263                    RX(ST, LINK, WSP, LHS_DISP)
 2264                    RX(LW, LINK, RHS_BASE, RHS_BASE+REGLEN)
 2265                    RX(ST, LINK, WSP, LHS_DISP+REGLEN)
 2266                 %FINISH
 2267                 DROP(RHS);  DROP(LHS)
 2268                 STP = STP-2
 2269                 %RETURN
 2270              %FINISH
 2271           %FINISH
 2272           %IF LHS_DV < 0 %AND CONTROL&ARRAYDIAG # 0 %START;! ARRAYNAME
 2273              LHS_DV = 0
 2274              HOLD = LHS;  TEMP = RHS
 2275              HOLD_DISP = HOLD_DISP+4
 2276              %IF TEMP_DV < 0 %START
 2277                 TEMP_DISP = TEMP_DISP+4;  TEMP_FORM = A IN S
 2278              %ELSE
 2279                 TEMP_BASE = GLA;  TEMP_DISP = TEMP_DV
 2280                 TEMP_FORM = V IN S
 2281              %FINISH
 2282              SSTACK(HOLD);  SSTACK(TEMP)
 2283              ASSIGN(0)
 2284           %FINISH
 2285           STP = STP-2
 2286           %IF LHS_TYPE = 10 %START;! NAME PARAMETER
 2287              ABORT(15) %UNLESS ASSOP = 0
 2288              T = RHS_TYPE<<13!(RHS_LENGTH&X'1FFF')
 2289              AMAP(RHS);  LRD(RHS, ANY)
 2290              RX(ST, RHS_BASE, LHS_BASE, LHS_DISP)
 2291              RI2(LHI, RHS_BASE, 0, T)
 2292              CLAIM(LHS_BASE); RX(ST, RHS_BASE, LHS_BASE, LHS_DISP+REGLEN)
 2293              FORGET(RHS_BASE)
 2294              DROP(LHS)
 2295              %RETURN
 2296           %FINISH
 2297           %IF ASSOP = 0 %START
 2298              DUMP STRING(0) %IF RHS_TYPE = STRING %AND RHS_FORM = CONSTANT
 2299              AMAP(LHS);  AMAP(RHS)
 2300           %FINISH
 2301           %IF LHS_TYPE = RECORD %START
 2302              AMAP(LHS);  LOAD(LHS, R2)
 2303              N = LHS_LENGTH>>1
 2304              %IF RHS_TYPE = RECORD %START
 2305                 AMAP(RHS);  LOAD(RHS, R1);  RELEASE(R1)
 2306                 P = R COPY
 2307              %ELSE
 2308                 P = R CLEAR
 2309              %FINISH
 2310              DROP(RHS);  DROP(LHS)
 2311              CSTACK(N);  STP = STP-1;  LRD(STACKED(STP+1)_V, R0)
 2312              RELEASE(R2)
 2313              PERM(P)
 2314              %RETURN
 2315           %FINISH
 2316           %IF LHS_TYPE = 15 %START;        ! STRING PARAM (FINAL)
 2317              %IF RHS == ACTIVE STRING %START
 2318                 HAZARD(R1)
 2319                 RHS_BASE = 17;  REMEMBER(R1, RHS);  ! DISCRIMINATE
 2320                 ACTIVE STRING == NULL
 2321                 T = NEW TAG;  DEFINE REFERENCE(T, R REF)
 2322                 RX(BAL, R1, CODE, T)
 2323                 N = 0
 2324                 %CYCLE
 2325                    DUMP(CURRENTSTRING(N)<<8+CURRENTSTRING(N+1))
 2326                    N = N+2
 2327                    %EXIT %IF N > CSLEN
 2328                 %REPEAT
 2329                 CSLEN = 0
 2330                 DEFINE TAG(T)
 2331                 RHS_FORM = V IN S;  RHS_BASE = R1;  RHS_DISP = 0
 2332                 CLAIM(R1)
 2333              %FINISH
 2334              DUMP STRING(0)
 2335              WDISP = 44 %IF WDISP = 0
 2336              LRD(RHS, R1)
 2337              DROP(LHS)
 2338              %RETURN
 2339           %FINISH
 2340           %IF LHS_TYPE = STRING %START
 2341              SIZE = LHS_LENGTH-1
 2342              SIZE = 0 %IF SIZE < 0 %OR SIZE = 255 %OR CONTROL&ASSDIAG=0
 2343              DUMP STRING(-1)
 2344              %IF RHS_FORM = CONSTANT %START;! NULL STRING!!
 2345                 RHS_TYPE = INTEGER;  LHS_TYPE = BYTE
 2346              %ELSE
 2347                 WDISP = WDISP-256 %IF RHS_TYPE = 0
 2348                 %IF RHS_LOP # 0 %AND SIZE = 0 %START
 2349                    W == RHS_LINK;  RHS_LOP = 0
 2350                    %IF SAME(LHS, RHS) %AND DIFFERENT(LHS, W) %START;! S = S.T
 2351                       RELEASE(LHS_BASE)
 2352                       LOAD(LHS, R2);  RELEASE(R2)
 2353                       DROP(RHS);  JOIN(W)
 2354                       DROP(LHS)
 2355                       %RETURN
 2356                    %FINISH
 2357                    %IF DIFFERENT(LHS, W) %START;  ! S = P.Q
 2358                       LRD(RHS, R1);  LRD(LHS, R2);  PERM(CONC1)
 2359                       JOIN(W)
 2360                       %RETURN
 2361                    %FINISH
 2362                    RHS_LOP = CONC
 2363                 %FINISH
 2364                 WDISP = 44 %IF WDISP = 0 %AND LHS_BASE = WSP
 2365                 LRD(RHS, R1);  LRD(LHS, R2)
 2366                 %IF SIZE # 0 %START
 2367                    CSTACK(SIZE);  STP = STP-1;  LRD(STACKED(STP+1)_V, R0)
 2368                    PERM(STRING ASS)
 2369                 %FINISH
 2370                 PERM(SMOVE)
 2371                 %RETURN
 2372              %FINISH
 2373           %FINISH
 2374           ADDRESS(LHS)
 2375           %IF (LHS_TYPE = INTEGER %AND CONTROL&UNASS DIAG = 0) %C
 2376+          %OR LHS_TYPE = SHORT %START
 2377              %IF RHS_LOP = ADD %START
 2378                 T = ADD;  T = SADD %IF SAME(LHS, RHS)
 2379                 RHS_LOP = 0;  OPTIMISE(RHS);  RHS_LOP = T
 2380                 %IF SAME(LHS, RHS) %START
 2381                    W == RHS_LINK
 2382                    LOAD(W, ANY)
 2383                    RELEASE(LHS_BASE)
 2384                    CCV = LHS;  CCREG = -2
 2385                    %IF LHS_TYPE = SHORT %THEN P = AHM %C
 2386+                                        %ELSE P = AM
 2387                    RX(P, W_BASE, LHS_BASE, LHS_DISP)
 2388                    PERM(ASSTH) %IF CONTROL&ASSDIAG # 0 %C
 2389+                                    %AND P = AHM
 2390                    FORGET DEST(LHS)
 2391                    RELEASE(W_BASE)
 2392                    DROP(RHS);  DROP(W);  DROP(LHS)
 2393                    CCCA = CA
 2394                    %RETURN
 2395                 %FINISH
 2396              %FINISH
 2397           %FINISH
 2398           %IF LHS_BASE = PARAM %START
 2399              NEW DISP = 0
 2400              P = LHS_DISP
 2401              LOAD(RHS, P) %IF RHS_LOP # 0;  DROP(LHS)
 2402              LHS == STACKED(STP)_V
 2403              RHS_LINK == LHS_LINK;  RHS_LOP = LHS_LOP
 2404              LHS_LINK == RHS;  LHS_LOP = P
 2405           %ELSE
 2406              P = ANY;  VAL = 0
 2407              %IF LHS_TYPE = INTEGER %START
 2408                 OP = ST
 2409              %ELSE %IF LHS_TYPE = SHORT
 2410                 OP = STH;  VAL = X'FFFF';  T = ASSTH
 2411              %ELSE %IF LHS_TYPE = BYTE
 2412                 OP = STB;  VAL = 255;      T = ASSTB
 2413              %ELSE
 2414                 OP = STE;  P = ANYF
 2415              %FINISH
 2416              %IF VAL # 0 %START;          ! POSSIBLE TEST REQUIRED
 2417                 %IF RHS_LOP = 0 %START
 2418                    VAL = 0 %IF (VAL = X'FFFF' %AND RHS_TYPE # INTEGER) %C
 2419+                         %OR RHS_TYPE = BYTE
 2420                 %ELSE %IF RHS_LOP = AND
 2421                    %IF RHS_LINK_FORM=CONSTANT %AND RHS_LINK_DISP=VAL %START
 2422                       DROP(RHS_LINK)
 2423                       RHS_LOP = 0;  VAL = 0;   ! DISPENSE WITH TEST
 2424                    %FINISH
 2425                 %FINISH
 2426              %FINISH
 2427              %IF CONTROL&ASSDIAG # 0 %AND RHS_FORM = CONSTANT %START
 2428                 VAL = 0 %IF VAL = 255 %AND RHS_DISP>>8 = 0
 2429                 VAL = 0 %IF VAL = X'FFFF' %C
 2430+                               %AND X'FFFF8000'<=RHS_DISP<=X'10000'
 2431              %FINISH
 2432              LOAD(RHS, P)
 2433              FORGET DEST(LHS)
 2434              RX(OP, RHS_BASE, LHS_BASE, LHS_DISP);  CCCA = CCCA+4
 2435              REMEMBER(RHS_BASE+STORE, LHS);            !MOVED ONE LINE DOWN??
 2436              %IF VAL = 0 %OR CONTROL&ASSDIAG = 0 %START;! NO STORE TEST
 2437                 RELEASE(RHS_BASE)
 2438              %ELSE
 2439                 %IF T = ASSTH %START
 2440                    RR(CHVR, RHS_BASE, RHS_BASE)
 2441                 %ELSE
 2442                    HAZARD(R0)
 2443                    RR(LBR, R0, RHS_BASE)
 2444                    CLAIM(RHS_BASE);  RR(CR, R0, RHS_BASE)
 2445                 %FINISH
 2446                 PERM(T)
 2447              %FINISH
 2448              DROP(RHS);  DROP(LHS)
 2449           %FINISH
 2450        %END
 2451        %ROUTINE ARRAY REF
 2452           %RECORD(STACKFM)%NAME A
 2453           %ownRECORD(STACKFM) T=0   {to prevent unassigned problems}
 2454           %INTEGER R, D
 2455           SET BOTH
 2456           T_BASE = CODE
 2457           A == LHS
 2458           REDUCE(A) %IF A_FORM > V IN S %AND A_FORM # AV IN S
 2459           D = 0
 2460           %IF RHS_LOP=ADD %AND CONST(RHS_LINK) %START
 2461              D = RHS_LINK_DISP*A_LENGTH
 2462              RHS_LOP = 0
 2463              DROP(RHS_LINK)
 2464           %FINISH
 2465           %IF A_FORM = V IN S %START
 2466              %IF RHS_LOP = 0 %AND A_LENGTH <= 256 %START
 2467                 ADDRESS(RHS) %UNLESS RHS_FORM = CONSTANT
 2468                 T_BASE = RHS_BASE+A_BASE<<8
 2469                 T_DISP = RHS_DISP
 2470                 T_TYPE = A_LENGTH
 2471                 T_FORM = RHS_FORM ! 128
 2472                 R = FIND USE(T_TYPE, T_FORM, T_BASE, T_DISP)
 2473                 %IF R # 0 %START
 2474                    STP = STP-1
 2475                    A_BASE = R;  A_DISP = A_DISP+D;  A_FORM = V IN S
 2476                    DROP(RHS)
 2477                    %RETURN
 2478                 %FINISH
 2479              %FINISH
 2480           %FINISH
 2481           CSTACK(A_LENGTH)
 2482           OPERATE(MUL);  LHS == STACKED(STP)_V
 2483           SSET(A_BASE, A_DISP, V IN S, 0)
 2484           %IF A_FORM = V IN S %START;! ARRAY
 2485              D = D+RHS_DISP;  RHS_DISP = 0
 2486              RHS_FORM = V IN R
 2487           %FINISH
 2488           %IF CONST(LHS) %START
 2489              LOAD(RHS, ANY0) %IF RHS_FORM = V IN S
 2490              D = D+LHS_DISP;  LHS_BASE = RHS_BASE
 2491              STP = STP-1
 2492           %ELSE %IF RHS_BASE = 0 %AND RHS_FORM = V IN R
 2493              LOAD(LHS, ANY0)
 2494              STP = STP-1
 2495           %ELSE
 2496              OPERATE(ADD);  LHS == STACKED(STP)_V;  RHS == LHS
 2497           %FINISH
 2498           LOAD(LHS, ANY0) %IF LHS_LOP # 0
 2499           STP = STP-1
 2500           REMEMBER(LHS_BASE, T) %IF LHS_FORM = V IN R
 2501           A_FORM = V IN S;  A_BASE = LHS_BASE;  A_DISP = D
 2502           %IF D < 0 %START
 2503              R = A_TYPE;  AMAP(A);  LOAD(A, ANY0)
 2504              A_TYPE = R;  A_FORM = V IN S
 2505           %FINISH
 2506           DROP(RHS) %UNLESS RHS == LHS
 2507           DROP(LHS)
 2508        %END
 2509        %ROUTINE CHECKED ARRAY REF
 2510           %INTEGER D, FLAG
 2511           SET BOTH;  STP = STP-2
 2512           REDUCE(LHS) %IF LHS_FORM > V IN S %AND LHS_FORM # AV IN S
 2513           LRD(RHS, R1)
 2514           HAZARD(R2);  FORGET(R2)
 2515           %IF LHS_DV < 0 %START
 2516              FLAG = 0;  D = 0;  RX(LW, R2, LHS_BASE, LHS_DISP+REGLEN)
 2517              CLAIM(LHS_BASE)
 2518           %ELSE
 2519              FLAG = 1;  D = LHS_DISP;  RI2(LHI, R2, GLA, LHS_DV)
 2520           %FINISH
 2521           PERM(A REF);  FORGET(R1)
 2522           %IF FLAG # 0 %START
 2523              RR(AR, R1, LHS_BASE)
 2524           %ELSE
 2525              RX(AW, R1, LHS_BASE, LHS_DISP)
 2526           %FINISH
 2527           LHS_BASE = R1;  LHS_DISP = D;  LHS_FORM = V IN S;  LHS_DV = 0
 2528           SSTACK(LHS)
 2529           DROP(LHS)
 2530        %END
 2531        %ROUTINE KNOW(%INTEGER REG, VALUE, TYPE)
 2532           KNOWN_BASE = REG+STORE;  KNOWN_DISP = VALUE
 2533           KNOWN_TYPE = TYPE
 2534           KNOWN_CA = 0 %IF USE(KNOWN_BASE)_CA < LIMEN %C
 2535+                       %OR USE(KNOWN_BASE)_CA = USE(KNOWN_BASE-STORE)_CA
 2536        %END
 2537        %ROUTINE TEST ZERO(%RECORD(STACKFM)%NAME V)
 2538           %RECORD(STACKFM)%NAME W
 2539           %INTEGER OP, COP, CR, CT, NOT
 2540           NOT = NEXTSYMBOL-'#'
 2541           OP = V_LOP
 2542           COP = LR ;  CR = ANY;  CT = INTEGER
 2543           %IF FLOATING(V) %START
 2544              COP = LER;  CR = ANYF;  CT = REALS
 2545           %ELSE %IF OP # 0 %AND SYM = '?'
 2546              W == V_LINK;  V_LOP = 0
 2547              %IF OP = AND %AND (W_FORM = CONSTANT %OR W_FORM = V IN R) %C
 2548+                                              %START
 2549                 %IF V_FORM # V IN R # W_FORM %AND V_TYPE = INTEGER %START
 2550                    %IF W_DISP&X'FFFF' = 0 %OR W_DISP>>16 = 0 %START
 2551                       ADDRESS(V)
 2552                       V_TYPE = UNSIGNED HALFWORD
 2553                       W_TYPE = UNSIGNED HALFWORD
 2554                       %IF W_DISP&X'FFFF' = 0 %START
 2555                          W_DISP = W_DISP>>16
 2556                       %ELSE
 2557                          V_DISP = V_DISP+2
 2558                       %FINISH
 2559                    %FINISH
 2560                 %FINISH
 2561                 LOAD(V, ANY)
 2562                 W_DISP = 0 %AND W_TYPE = 0 %IF W_FORM = V IN R
 2563                 %IF -X'8000' <= W_DISP <= X'7FFF' %C
 2564+                   %OR W_TYPE = UNSIGNED HALFWORD %START
 2565                    RI2(THI,V_BASE,W_BASE,W_DISP)
 2566                 %ELSE
 2567                    RI3(TI,V_BASE,W_BASE,W_DISP)
 2568                 %FINISH
 2569                 RELEASE(V_BASE);  DROP(W)
 2570                 %RETURN
 2571              %FINISH
 2572              %IF W_FORM = CONSTANT %AND OP = ADD %C
 2573+                            %AND (W_DISP < -15 %OR W_DISP > 15) %START
 2574                 W_DISP = -W_DISP
 2575                 COMPARE(V, W);  DROP(W)
 2576                 %RETURN
 2577              %FINISH
 2578              V_LOP = OP
 2579           %FINISH
 2580           %IF OP = 0 %AND CCCA = CA %AND LIMEN # CA %START
 2581              %IF CCREG < 0 %AND SAME(CCV, V) %START
 2582                 RELEASE(V_BASE);  %RETURN
 2583              %FINISH
 2584              OPTIMISE(V)
 2585              %IF V_FORM = V IN R %AND V_BASE = CCREG %START
 2586                 RELEASE(V_BASE)
 2587                 KNOW(V_BASE, 0, CT) %IF NOT = 0
 2588                 %RETURN
 2589              %FINISH
 2590           %FINISH
 2591           LOAD(V, CR)
 2592           %UNLESS CCREG = V_BASE %AND CCCA = CA %START
 2593              RR(COP, V_BASE, V_BASE)
 2594           %ELSE
 2595              RELEASE(V_BASE)
 2596           %FINISH
 2597           KNOW(V_BASE, 0, CT) %IF NOT = 0
 2598        %END
 2599        %ROUTINE COMPARE REALS(%RECORD(STACKFM)%NAME L, R)
 2600           %RECORD(STACKFM) H
 2601           FLOAT(L, ANYF) %UNLESS L_TYPE = REALS
 2602           FLOAT(R, ANYF) %UNLESS R_TYPE = REALS
 2603           LOAD(L,ANYF) %IF L_LOP # 0
 2604           LOAD(R,ANYF) %IF R_LOP # 0
 2605           %IF L_FORM # V IN R %AND R_FORM = V IN R %START
 2606              H = L;  L = R;  R = H
 2607              INVERT = INVERT!!6;  SWOPPED = SWOPPED!!1
 2608           %FINISH
 2609           LOAD(L, ANYF)
 2610           LOAD(R, ANYF) %IF CONTROL&UNASS DIAG # 0
 2611           ADDRESS(R)
 2612           %IF R_FORM = V IN R %START
 2613              RR(CER, L_BASE, R_BASE)
 2614           %ELSE
 2615              RX(CE, L_BASE, R_BASE, R_DISP)
 2616           %FINISH
 2617           RELEASE(L_BASE)
 2618        %END
 2619     %ROUTINE COMPARE STRINGS(%RECORD(STACKFM)%NAME L, R)
 2620        %ROUTINE TEST NULL(%RECORD(STACKFM)%NAME R)
 2621           ACTIVE STRING == NULL
 2622           LOAD(R, ANY) %IF R_LOP # 0
 2623           R_TYPE = BYTE
 2624           TEST ZERO(R)
 2625        %END
 2626        SDISP = 256 %IF L_TYPE = 0 %OR R_TYPE = 0 %C
 2627+                   %OR L_LOP # 0 %OR R_LOP # 0
 2628        %IF CSLEN = 0 %START
 2629           %IF R_FORM = CONSTANT %START
 2630              TEST NULL(L);  L_TYPE = STRING;  L_FORM = V IN S;  %RETURN
 2631           %FINISH
 2632           %IF L_FORM = CONSTANT %START
 2633              TEST NULL(R);  INVERT = INVERT!!6;  %RETURN
 2634           %FINISH
 2635        %FINISH
 2636        DUMP STRING(0)
 2637        LOAD(R, R1);  LOAD(L, R2);  LOAD(R, R1);! IN CASE OF HAZARD!
 2638        RELEASE(R1);  RELEASE(R2)
 2639        PERM(SCOMP)
 2640        L_TYPE = STRING;  L_FORM = V IN S
 2641        WDISP = 0
 2642     %END
 2643        %ROUTINE COMPARE(%RECORD(STACKFM)%NAME L, R)
 2644           %RECORD(STACKFM) T
 2645           %INTEGER OP, ARITH
 2646           %PREDICATE CHANCED
 2647              %FALSE %UNLESS L_LOP = ADD %AND SYM # 126
 2648              %FALSE %UNLESS L_LINK_FORM = CONSTANT %AND L_BASE # 0
 2649              %FALSE %UNLESS -X'8000' <= L_LINK_DISP <= X'7FFF'
 2650              %FALSE %IF L_TYPE = REALS
 2651              INVERT = INVERT!!6;  SWOPPED = SWOPPED!!1
 2652              T = L;  L = R;  R = T
 2653              R_LOP = 0
 2654              LOAD(L, ANY)
 2655              LOAD(R, ANY0)
 2656              %IF -X'8000' <= R_LINK_DISP <= X'7FFF' %START
 2657                 %IF ARITH # 0 %THEN OP = CLHI %ELSE OP = CHI
 2658                 RI2(OP,L_BASE,R_BASE,R_LINK_DISP)
 2659              %ELSE
 2660                 %IF ARITH # 0 %THEN OP = CLI %ELSE OP = CI
 2661                 RI3(OP,L_BASE,R_BASE,R_LINK_DISP)
 2662              %FINISH
 2663              RELEASE(L_BASE)
 2664              DROP(R_LINK)
 2665              %TRUE
 2666           %END
 2667           SWOPPED = 0;  SDISP = 0
 2668           %IF LHS_TYPE = 0 %OR LHS_TYPE = STRING %START
 2669              COMPARE STRINGS(L, R);  %RETURN
 2670           %FINISH
 2671           %IF ZERO(R) %START
 2672              TEST ZERO(L);  %RETURN
 2673           %FINISH
 2674           %IF ZERO(L) %START
 2675              TEST ZERO(R);  INVERT = INVERT!!6;  %RETURN
 2676           %FINISH
 2677           ARITH = NEXTSYMBOL
 2678           ARITH = 0 %IF ARITH # '#' %AND ARITH # '=' %AND SYM # 'F'+32
 2679           %RETURN %IF CHANCED
 2680           OPTIMISE(R);  OPTIMISE(L)
 2681           COMPARE REALS(L ,R) %AND %RETURN %IF FLOATING(L) %OR FLOATING(R)
 2682           %IF CONST(L) %OR R_FORM = V IN R %OR L_TYPE = BYTE %C
 2683+                       %OR R_LOP # 0 %START
 2684              T = L;  L = R;  R = T
 2685              INVERT = INVERT!!6;  SWOPPED = SWOPPED!!1
 2686              %RETURN %IF CHANCED
 2687           %FINISH
 2688           LOAD(L, ANY)
 2689           %IF R_LOP # 0 %OR R_TYPE = BYTE %OR R_TYPE = UNSIGNED HALFWORD %C
 2690+             %OR (CONTROL&UNASS DIAG # 0 %AND (R_FORM=VINS %OR %C
 2691+                   R_FORM=AVINS)) %START
 2692              LOAD(R, ANY)
 2693           %FINISH
 2694           REDUCE(R) %IF R_FORM = AV IN REC
 2695           %IF (R_FORM = CONSTANT %OR R_FORM = AV IN S) %START
 2696              %IF -X'8000' <= R_DISP <= X'7FFF' %START
 2697                 %IF ARITH # 0 %THEN OP = CLHI %ELSE OP = CHI
 2698                 RI2(OP,L_BASE,R_BASE,R_DISP)
 2699              %ELSE
 2700                 %IF ARITH # 0 %THEN OP = CLI %ELSE OP = CI
 2701                 RI3(OP,L_BASE,R_BASE,R_DISP)
 2702              %FINISH
 2703              KNOW(L_BASE, R_DISP, INTEGER) %IF R_FORM = CONSTANT %C
 2704+                                         %AND ARITH = '#'
 2705           %ELSE
 2706              ADDRESS(R)
 2707              %IF R_FORM = V IN R %START
 2708                 %IF ARITH # 0 %THEN OP = CLR  %ELSE OP = CR
 2709                 RR(OP, L_BASE, R_BASE)
 2710              %ELSE
 2711                 %IF R_TYPE = BYTE %START
 2712                    OP = CLB
 2713                 %ELSE %IF ARITH # 0
 2714                    %IF R_TYPE = SHORT %THEN OP = CLH %ELSE OP = CL
 2715                 %ELSE
 2716                    %IF R_TYPE = SHORT %THEN OP = CH %ELSE OP = C
 2717                 %FINISH
 2718                 RX(OP, L_BASE, R_BASE, R_DISP)
 2719              %FINISH
 2720           %FINISH
 2721           RELEASE(L_BASE)
 2722        %END
 2723        %ROUTINE CLAIM WSP(%INTEGERNAME SIZE)
 2724           SIZE = (WDISP+(REGLEN-1))&(\(REGLEN-1));  %RETURN %IF SIZE = 0
 2725           WDISP = 0
 2726           RI2(AHI, WSP, 0, SIZE) %IF SIZE > 15
 2727        %END
 2728        %ROUTINE RELEASE WSP(%INTEGER SIZE)
 2729           WDISP = SIZE
 2730           RI2(SHI, WSP, 0, WDISP) %IF WDISP > 15
 2731        %END
 2732        %ROUTINE HEADER(%RECORD(VARFM)%NAME V)
 2733           LIMEN = CA-2
 2734           FRAME = 11*REGLEN %IF FRAME < 11*REGLEN
 2735           DEFINE TAG(V_DISP&X'FFF') %UNLESS V == BEGIN
 2736           RX(STM, P2, WSP, 0)
 2737           RR(LR , LOCAL, WSP)
 2738           %IF CONTROL&(UNASS DIAG!STKDIAG) # 0 %START
 2739              %IF CONTROL&UNASS DIAG # 0 %START
 2740                 PERM(EXBUNASS);  DUMP(FRAME)
 2741              %ELSE
 2742                 PERM(EXB)
 2743              %FINISH
 2744           %ELSE
 2745              DUMP(AHI+ACTUAL(WSP)<<4)
 2746           %FINISH
 2747           SIZE PATCH = CA
 2748           DUMP(0)
 2749        %END
 2750        %ROUTINE RETURN
 2751           %RETURN %IF UNCOND JUMP = CA
 2752           RX(LM, WSP, LOCAL, 2*REGLEN)
 2753           CLAIM(LINK);  RR(BFCR, 0, LINK)
 2754           UNCOND JUMP = CA
 2755        %END
 2756        %ROUTINE CALL(%RECORD(STACKFM)%NAME V)
 2757           %SWITCH B(0:15)
 2758           %OWNINTEGER INT G = 0, FRACPT G = 0
 2759           %INTEGER WORK, AWORK, REG, AREG
 2760           %INTEGER ADDR, T, L
 2761           %INTEGERFN SET(%INTEGER H, L)
 2762              GFIX(4)
 2763              GHALF(H);  GHALF(L)
 2764              %RESULT = GA-4
 2765           %END
 2766           ADDR = V_DISP
 2767           %IF ADDR < 0 %START
 2768              PERM(X'1EF00'-ADDR)
 2769           %ELSE
 2770              %IF V_BASE = LINK %START;      ! INTRINSIC
 2771                 V_DV = 0;  DROP(V)
 2772                 SET LHS
 2773                 L = 0;  T = V_DISP;  SYM = 0
 2774                 ->B(T)
 2775  B(12):! FRACPT
 2776                 LOAD(LHS, ANYF)
 2777                 REG = LHS_BASE;  AREG = ACTUAL(REG)
 2778                 WORK = FPR;      AWORK = ACTUAL(WORK)
 2779                 DUMP(LER+AWORK<<4+AREG)
 2780                 %IF FRACPT G = 0 %START
 2781                    FRACPT G = SET(X'4600', 0);  ! UNNORM. ZERO
 2782                    ADDR = SET(X'4110', 0);! 1.0
 2783                 %FINISH
 2784                 DUMP(AE+AWORK<<4+ACTUAL(GLA));  DUMP(FRACPT G)
 2785                 DUMP(LER+AWORK<<4+AWORK)
 2786                 DUMP(SER+AREG<<4+AWORK)
 2787                 DUMP(X'2313');     ! BNMFS .+3
 2788                 DUMP(AE+AREG<<4+ACTUAL(GLA));  DUMP(FRACPT G+4)
 2789                 FORGET(REG);  FORGET(WORK)
 2790                 %RETURN
 2791  B(11):! INT
 2792                 INT G = SET(X'4080', 0) %IF INT G = 0;!  =0.5
 2793                 STACK(INT G, GLA, REALS, 1, 0, 0, 0);  OPERATE(ADD)
 2794                 SET LHS
 2795  B(10):! INTPT
 2796                 LOAD(LHS, ANYF)
 2797                 L = GPR(0);   RR(FXR, L, LHS_BASE)
 2798                 CLAIM(L);  LHS_BASE = L;  LHS_TYPE = INTEGER
 2799                 %RETURN
 2800  B(0):! ADDR
 2801                 AMAP(LHS);  %RETURN
 2802  B(7):! LENGTH
 2803                 CSTACK(0)
 2804  B(8):! CHARNO
 2805                 SET BOTH
 2806                 LHS_TYPE = BYTE;  LHS_LENGTH = 1;  ARRAY REF
 2807                 %RETURN
 2808  B(4):! STRING
 2809                 L = 255
 2810  B(1):! INTEGER
 2811  B(2):! BYTEINTEGER
 2812  B(3):! SHORTINTEGER
 2813  B(5):! RECORD
 2814  B(6):! REAL
 2815                 VMAP(LHS);  LHS_TYPE = T;  LHS_LENGTH = L
 2816                 %RETURN
 2817  B(9):! REM
 2818                 SET BOTH
 2819                 OPERATE(REM);  %RETURN
 2820  B(13):! READSYMBOL
 2821                 LIMEN = CA;            !SPECIALLY HERE
 2822                 PERM(RSYM);  CLAIM(R1)
 2823                 SSET(R1, 0, V IN R, 0)
 2824                 ASSIGN(1);  %RETURN
 2825  B(14):! TOSTRING
 2826                 CSTACK(255);  OPERATE(AND)
 2827                 CSTACK(256);  OPERATE(ADD)
 2828                 SET LHS
 2829                 %IF CONST(LHS) %START
 2830                    GFIX(2);  ADDR = GA;  GHALF(LHS_DISP)
 2831                    LHS_TYPE = STRING;  LHS_FORM = V IN S
 2832                    LHS_BASE = GLA;  LHS_DISP = ADDR
 2833                 %ELSE
 2834                    SSTACK(LHS);  SET BOTH
 2835                    LHS_LOP = 0;  RELEASE(LHS_BASE)
 2836                    FRAME = (FRAME+1)&(\1)
 2837                    LHS_TYPE = SHORT;  LHS_FORM = V IN S
 2838                    LHS_BASE = LOCAL;  LHS_DISP = FRAME
 2839                    ASSIGN(1)
 2840                    SSET(LOCAL, FRAME, V IN S, 0);  RHS_TYPE = STRING
 2841                    FRAME = FRAME+2
 2842                 %FINISH
 2843                 %RETURN
 2844  B(15):! SVC(N, P)
 2845                 SET BOTH;  STP = STP-2
 2846                 REG = 0;  WORK = LHS_DISP
 2847                 %UNLESS CONST(LHS) %START
 2848                    LOAD(LHS, ANY0);  WORK = 0;  REG = LHS_BASE
 2849                 %FINISH
 2850                 ADDRESS(RHS)
 2851                 RX(LME, FPR0, RHS_BASE, RHS_DISP)
 2852                 RX(SVC, 0, REG, WORK)
 2853                 CLAIM(RHS_BASE)
 2854                 RX(STME, FPR0, RHS_BASE, RHS_DISP)
 2855                 DROP(RHS);  DROP(LHS)
 2856                 LIMEN = CA;   !FORGET EVERYTHING
 2857                 %RETURN
 2858              %FINISH
 2859              HAZARD ALL
 2860              %IF ADDR&X'4000' = 0 %START;   ! PARAMETER
 2861                 ADDR = NEW TAG;  DEFINE REFERENCE(ADDR, R REF)
 2862                 RX(LA, LINK, CODE, 0);! RETURN ADDRESS
 2863                 RX(STM, P2, WSP, 0)
 2864                 RX(LW, R2, V_BASE, V_DISP)
 2865                 RX(LW, R3, V_BASE, V_DISP+REGLEN)
 2866                 CLAIM(R2);  RX(LM, R9, R2, 4*REGLEN)
 2867                 CLAIM(R3);  RX(BAL, LINK, R3, 4)
 2868                 DEFINE TAG(ADDR)
 2869              %ELSE
 2870                 DEFINE REFERENCE(ADDR&X'FFF', R REF)
 2871                 RX(BAL, LINK, CODE, ADDR&X'FFF')
 2872              %FINISH
 2873              LIMEN = CA-1
 2874           %FINISH
 2875           DROP(V) %IF V_TYPE = 0
 2876        %END
 2877        %ROUTINE FOR
 2878           %RECORD(STACKFM)%NAME CV, IV, INC, FV
 2879           %INTEGER LAB, REG, SPECIAL
 2880           %ROUTINE  STAB(%RECORD(STACKFM)%NAME  V,  %INTEGER  TYPE)
 2881              %INTEGER T, R
 2882              %RETURN %IF CONST(V)
 2883              LOAD(V, ANY);  R = V_BASE
 2884              T = TEMP;  RX(ST, R, LOCAL, T)
 2885              RELEASE(R)
 2886              V_BASE = LOCAL;  V_DISP = T
 2887              V_TYPE = TYPE;  V_FORM = V IN S
 2888              REMEMBER(R, V)
 2889           %END
 2890           %PREDICATE  CHECK REQD
 2891           %INTEGER I
 2892              %TRUE %UNLESS CONST(FV) %AND CONST(IV) %AND CONST(INC)
 2893              %IF INC_DISP # 0 %START
 2894                 I = (FV_DISP - IV_DISP)//INC_DISP + 1
 2895                 %FALSE %IF I >= 0 %AND IV_DISP + (I-1)*INC_DISP = FV_DISP
 2896              %FINISH
 2897              ABORT(-12);    ! ...FAULTY, CONSTANT, %FOR PARAMETERS
 2898              %TRUE;         ! ...INCLUDE RUN-TIME CHECK FOR SAFETY
 2899           %END
 2900           %ROUTINE  SET(%RECORD(STACKFM)%NAME  V, %INTEGER  REG)
 2901           %RECORD(STACKFM)%NAME  R
 2902              SSTACK(V);  R == STACKED(STP)_V
 2903              LRD(R, REG)
 2904              STP = STP-1
 2905           %END
 2906  
 2907           SPECIAL = 0
 2908           CV == STACKED(STP-3)_V
 2909           IV == STACKED(STP-2)_V
 2910           INC== STACKED(STP-1)_V
 2911           FV == STACKED(STP  )_V
 2912           SKIPSYMBOL;  LAB = TAG
 2913           STAB(INC,INTEGER);  STAB(FV,INTEGER)
 2914           %IF CONTROL&FORDIAG # 0 %AND CHECK REQD %START
 2915              STAB(IV,INTEGER)
 2916              SET(IV,R0);  SET(FV,R1);  SET(INC,R2)
 2917              PERM(FORTEST)
 2918           %FINISH
 2919           %IF CV_FORM # V IN S %OR ACTIVITY(CV_BASE) >= 0 %START
 2920              AMAP(CV)
 2921              STAB(CV, CV_TYPE)
 2922              CV_FORM = A IN S
 2923           %FINISH
 2924           SPECIAL = CONTROL&512 %IF CONST(FV) %AND CONST(INC) %C
 2925+                               %AND CONST(IV) %AND FV_DISP+INC_DISP # IV_DISP
 2926           STP = STP-4
 2927           SSTACK(CV);  SSTACK(IV);  RELEASE(IV_BASE);  SSTACK(INC)
 2928           DROP(IV)
 2929           OPERATE(SUB)
 2930           %IF SPECIAL # 0 %START
 2931              REG = GPR(0);  SET LHS;  LOAD(LHS, REG)
 2932           %ELSE
 2933              ASSIGN(1);    ! CV = CV-INC
 2934           %FINISH
 2935           DEFINE LABEL(LAB)
 2936           %IF SPECIAL # 0 %START
 2937              FLAB_BASE = CV_BASE;  FLAB_DISP = CV_DISP
 2938              FLAB_REG = REG
 2939              FLAB_LIMIT = FV_DISP
 2940              SSTACK(INC);  OPERATE(ADD);  ASSIGN(1)
 2941              USE(REG) = USE(REG+STORE);   ! REMEMBER CONTROL VAR
 2942           %ELSE
 2943              SSTACK(CV);  SSTACK(CV)
 2944              COMPARE(CV, FV)
 2945              JUMP TO(LAB-2, 0, REDEFINE)
 2946              SSTACK(INC);  OPERATE(ADD);  ASSIGN(1)
 2947           %FINISH
 2948           DROP(CV);  DROP(FV);  DROP(INC)
 2949        %END;        ! ... OF 'FOR'
 2950        %ROUTINE  ADUMP
 2951        %IF OWNTYPE = INTEGER  %START
 2952           GWORD(OWNVAL)
 2953        %ELSE %IF OWNTYPE = SHORT
 2954           GHALF(OWNVAL)
 2955        %ELSE %IF OWNTYPE = BYTE
 2956           GBYTE(OWNVAL)
 2957        %ELSE %IF OWNTYPE = STRING
 2958           DUMP STRING(DATA SIZE)
 2959        %ELSE %IF OWNTYPE = REALS
 2960           GWORD(OWNVAL) %IF REALGA = GA
 2961           REALGA = GA
 2962        %ELSE
 2963           GHALF(0) %FOR VAL = 1,1,DATA SIZE >> 1
?Non-local
 2964        %FINISH
 2965     %END
 2966  
 2967  NEXT: READSYMBOL(SYM);  ->Z(SYM)
 2968  Z('O'):ABORT(14) %IF STP # 0
 2969         ABORT(19) %UNLESS USING_LINK == NULL
 2970         CHECK RELEASED
 2971         SET LINE
 2972         MIN TEMP = FRAME
 2973         DIAG GLA = 0;  WDISP = 0
 2974         %IF FRAME >= X'4000' %AND WARNING = 0 %START
 2975  WARN:     WARNING = -15;  ABORT(-15)
 2976         %FINISH
 2977         ->NEXT
 2978  Z('$'):DEFINE VAR;  ->NEXT
 2979  Z(98):APARM = TAG;    ! LOWER CASE 'B'
 2980  Z(119):STP = STP-2;    !  LOWER CASE 'W'
 2981         VLB = STACKED(STP+1)_V_DISP
 2982         VUB = STACKED(STP+2)_V_DISP
 2983         DROP(STACKED(STP+1)_V);  DROP(STACKED(STP+2)_V)
 2984        ! IMP SWITCH BOUNDS MUST BE AS BELOW -- POTENTIAL ALGOL PROBLEM???
 2985         %IF VLB < -32768 %OR VUB > 32767 %START
 2986            ABORT(-10);  VUB = 0;  VLB = 0
 2987         %FINISH
 2988         ->NEXT
 2989  Z('I'):VAL = (VUB-VLB+1)*DATA SIZE
 2990         VAL = DATA SIZE %AND ABORT(-8) %IF VAL <= 0
 2991         GBYTE(0) %FOR J = 1, 1, VAL
 2992         ->NEXT
 2993  Z('A'):APARM = 1
 2994         SKIPSYMBOL %AND APARM = TAG %IF NEXTSYMBOL = COMMA
 2995         %IF OWNFORM = ARRAY %START
 2996            OWNVAL = 0
 2997            %IF STP # 0 %START
 2998               POP LHS;  OWN VAL = LHS_DISP;  DROP(LHS)
 2999            %FINISH
 3000            %IF STP # 0 %START
 3001               APARM = OWN VAL
 3002               POP LHS;  OWNVAL = LHS_DISP;  DROP(LHS)
 3003            %FINISH
 3004            %IF OWNTYPE = REALS %START
 3005               %IF LHS_TYPE = INTEGER %START
 3006                  REAL(ADDR(OWNVAL)) = OWNVAL
 3007               %ELSE
 3008                  DECVAR_DISP = DECVAR_DISP-4
 3009               %FINISH
 3010            %FINISH
 3011            APARM = VUB-VLB+1 %IF APARM = 0
 3012            %IF APARM <= 0 %START
 3013               VUB = VLB;  APARM = 1;  ABORT(-8)
 3014            %FINISH
 3015            %FOR J = 1, 1, APARM %CYCLE
 3016               VLB = VLB+1
 3017               ADUMP
 3018            %REPEAT
 3019         %ELSE
 3020            OWNVAL = 0
 3021            %IF STP # 0 %START
 3022               POP LHS;  OWN VAL = LHS_DISP;  DROP(LHS)
 3023            %FINISH
 3024            NAMES = NAMES-APARM
 3025            ->NEXT %IF OWNFORM = 5
 3026            %FOR J = 1, 1, APARM %CYCLE
 3027               NAMES = NAMES+1;  DEC VAR == VAR(NAMES)
 3028               %IF OTYPE = 0 %START
 3029                  DECVAR_DISP = OWNVAL;  DECVAR_BASE = 0
 3030                  DECVAR_FORM = DECVAR_FORM-1
 3031               %ELSE
 3032                  DECVAR_DISP = GA;  DECVAR_BASE = GLA
 3033                  %IF OWNTYPE = REALS %AND LHS_TYPE = REALS %START
 3034                     DECVAR_DISP = DECVAR_DISP-4
 3035                  %FINISH
 3036                  ADUMP
 3037               %FINISH
 3038            %REPEAT
 3039         %FINISH
 3040         ->WARN %IF GA > X'4000' %AND WARNING = 0
 3041         ->NEXT
 3042  Z(''''):GET STRING;  ->NEXT
 3043  Z('N'):LEN = TAG;  SKIPSYMBOL
 3044         CSTACK(EVAL(LEN));  ->NEXT
 3045  Z('D'): RHS == DESCRIPTOR; FP CSTACK(REAL CONSTANT,RHS); -> NEXT
 3046  
 3047  Z('@'):%IF NEXTSYMBOL = MINUS %START
 3048            SKIPSYMBOL;  LEN = TAG;  SET LHS
 3049            V == VAR(VAR(LHS_FORMAT)_EXTRA+LEN-1)
 3050            DISPLAY VAR(V) %IF CONTROL < 0
 3051            VSTACK(V);  SET BOTH
 3052            STP = STP-1
 3053            %IF LHS_FORM = V IN S %OR LHS_FORM = V IN REC %START
 3054               RHS_DISP = LHS_DISP+RHS_DISP
 3055               LHS_FORM = LHS_FORM-V IN S+RHS_FORM
 3056            %ELSE %IF LHS_FORM = A IN REC
 3057              LHS_FORM = V IN REC;  LHS_TYPE = INTEGER
 3058              LOAD(LHS, ANY0)
 3059              LHS_FORM = RHS_FORM
 3060            %ELSE %IF LHS_FORM <= V IN R
 3061               LHS_FORM = RHS_FORM
 3062            %ELSE
 3063               LHS_EXTRA = LHS_DISP
 3064               LHS_FORM = RHS_FORM+2
 3065            %FINISH
 3066            LHS_DISP = RHS_DISP
 3067            LHS_TYPE = RHS_TYPE;  LHS_LENGTH = RHS_LENGTH
 3068            LHS_FORMAT = RHS_FORMAT;  LHS_DV = RHS_DV
 3069            DROP(RHS)
 3070         %ELSE
 3071            V == VAR(LOOKUP(TAG))
 3072            VSTACK(V)
 3073            CLAIM WSP(LHS_DV) %IF LHS_FORM&16 # 0 %AND  %C
 3074+                             LHS_BASE # LINK %AND NEXTSYMBOL # 'P'+32
 3075         %FINISH
 3076         ->NEXT
 3077  Z('E'):POP LHS
 3078         OPR = LHS_LOP;  LHS_LOP = 0;  J = 0
 3079         %WHILE OPR # 0 %CYCLE
 3080            X == LHS_LINK;  LHS_LINK == X_LINK
 3081            N = X_LOP;  X_LOP = 0
 3082            LOAD(X, OPR)
 3083            DROP(X);  J = J<<8!OPR
 3084            OPR = N
 3085         %REPEAT
 3086         RELEASE(J&255);  RELEASE(J>>8)
 3087         X == LHS;  CALL(X);  DOPE = X_DV
 3088         %IF X_TYPE # 0 %AND SYM # 0 %START;! FN/MAP
 3089           SSTACK(X);  DROP(X);  SET LHS;  RELEASE(LHS_BASE)
 3090            %IF LHS_TYPE = REALS %THEN OPR = FPR0 %ELSE OPR = R1
 3091            LHS_BASE = OPR;  LHS_DISP = 0;  LHS_FORM = LHS_FORM&15
 3092            CLAIM(OPR)
 3093            %IF LHS_TYPE = STRING %AND LHS_FORM = V IN R %START
 3094               LHS_FORM = V IN S
 3095               SYM = NEXTSYMBOL
 3096               %IF SYM # 'S' %AND SYM # 'P'+32 %AND SYM # '?' %START
 3097                  N = X_LENGTH;  N = 256 %IF N = 0
 3098                  FRAME = (FRAME+1)&(\1)
 3099                  LHS_FORM = V IN S;  LHS_BASE = LOCAL;  LHS_DISP = FRAME
 3100                  FRAME = FRAME+N
 3101                  SSET(LOCAL, LHS_DISP, V IN S, 0)
 3102                  RHS_TYPE = STRING;  RHS_LENGTH = N
 3103                  SSET(R1, 0, V IN S, 0);  RHS_TYPE = STRING
 3104                  ASSIGN(1)
 3105               %FINISH
 3106            %FINISH
 3107         %FINISH
 3108         RELEASE WSP(DOPE) %IF SYM # 0;  !NOT IF BUILT-IN
 3109         ->NEXT
 3110  Z('R'):RETURN;  ->NEXT
 3111  Z('V'):POP LHS
 3112        DUMP STRING(0)
 3113         %IF GVAR_TYPE = REALS %THEN OPR = FPR0 %ELSE OPR = R1
 3114         LRD(LHS, OPR);  RETURN;  ->NEXT
 3115  Z('M'):POP LHS;  AMAP(LHS);  LRD(LHS, R1);  RETURN;  ->NEXT
 3116  Z('T'):DUMP(X'2411');  RETURN;     !  *LIS R1, 1
 3117         ->NEXT
 3118  Z('K'):DUMP(X'2410');  RETURN;     !  *LIS R1, 0
 3119         ->NEXT
 3120  Z(97):%IF CONTROL&ARRAY DIAG # 0 %THEN CHECKED ARRAY REF %C
 3121+                                  %ELSE ARRAY REF
 3122         ->NEXT
 3123  Z('.'):OPR = CONC;  ->ARITH
 3124  Z('+'):OPR = ADD;   ->ARITH
 3125  Z('-'):OPR = SUB;   ->ARITH
 3126  Z('!'):OPR = IOR;   ->ARITH
 3127  Z('%'):OPR = XOR;   ->ARITH
 3128  Z('&'):OPR = AND;   ->ARITH
 3129  Z('['):OPR = LSH;   ->ARITH
 3130  Z(']'):OPR = RSH;   ->ARITH
 3131  Z('*'):OPR = MUL;   ->ARITH
 3132  Z('/'):OPR = DIV;   ->ARITH
 3133  Z('Q'):OPR = RDIV;  ->ARITH
 3134  Z('U'):OPR = NEG;   ->ARITH
 3135  Z('\'):OPR = NOT;   ->ARITH
 3136  Z('X'):
 3137  Z(120):OPR = EXP;   ! LOWER CASE 'X'
 3138  
 3139  ARITH: OPERATE(OPR);  ->NEXT
 3140  
 3141  Z(118):SET LHS;    ! LOWER CASE 'V'
 3142         CCREG = 0 %IF CCREG < 0
 3143         %IF FLOATING(LHS) %THEN K = ANYF %ELSE K = ANY
 3144         LOAD(LHS,K)
 3145         TEST ZERO(LHS)
 3146         K = LHS_BASE
 3147         JUMP TO(3, 5, REDEFINE)
 3148         CLAIM(LHS_BASE)
 3149         OPERATE(NEG);  SET LHS
 3150         LOAD(LHS,K)
 3151         DEFINE LABEL(3)
 3152         FORGET(LHS_BASE)
 3153         ->NEXT
 3154  
 3155  Z('S'):ASSIGN(1);  ->NEXT
 3156  Z('Z'):ASSIGN(0);  ->NEXT
 3157  Z(112):ASSIGN(-1);  WDISP = NEW DISP; ->NEXT;      ! LOWER CASE 'P'
 3158  
 3159  Z(107):KNOW(R1, 1, INTEGER)
 3160  Z('='):OPR = 0;  ->COND;     !  LOWER CASE  'K'
 3161  Z(116):KNOW(R1, 0, INTEGER)
 3162  Z('#'):OPR = 1;  ->COND;       ! LOWER CASE 'T'
 3163  Z('<'):OPR = 2;  ->COND
 3164  Z('>'):OPR = 3;  ->COND
 3165  Z('('):OPR = 4;  ->COND
 3166  Z(')'):OPR = 5
 3167  
 3168  COND:  VAL = TAG
 3169         JUMP TO(VAL, OPR+INVERT, REDEFINE)
 3170         ->NEXT
 3171  Z('C'):SET BOTH
 3172         AMAP(LHS);  AMAP(RHS)
 3173  Z(126):! FIRST OF DOUBLE SIDED
 3174  Z('?'):SET BOTH
 3175         COMPARE(LHS, RHS);  STP = STP-2
 3176         DROP(RHS);  DROP(LHS)
 3177         ->NEXT
 3178  Z('"'):ST WORK = STACKED(STP+SWOPPED+1)_V
 3179         SSTACK(ST WORK)
 3180         WDISP = SDISP
 3181         ->NEXT
 3182  Z('_'):LIMEN = CA
 3183         UNCONDJUMP = 0
 3184         V == VAR(LOOKUP(TAG));  POP LHS;  DROP(LHS)
 3185         GPATCH(CA, V_EXTRA+LHS_DISP*2)
 3186         ->NEXT
 3187  Z('W'):V == VAR(LOOKUP(TAG))
 3188         %IF CONTROL&TEST SWITCH # 0 %START
 3189            HALF = GLA;  K = V_DISP
 3190            RANGE(HALF, K)
 3191            POP LHS;  LRD(LHS, R1)
 3192            RI2(LHI, R2, HALF, K)
 3193            PERM(SWJUMP)
 3194         %ELSE
 3195            CSTACK(1);  OPERATE(LSH)
 3196            POP LHS;  LRD(LHS, ANY0)
 3197            J = ACTUAL(LHS_BASE)
 3198            DUMP(LHL+J<<4+ACTUAL(GLA))
 3199            K = V_EXTRA
 3200            DUMP(X'4000'+J<<8+K>>16&255)
 3201            DUMP(K&X'FFFF')
 3202            DUMP(AR+J<<4+ACTUAL(CODE))
 3203            DUMP(BFCR+J)
 3204            LIMEN = CA;  UNCOND JUMP = CA
 3205         %FINISH
 3206         ->NEXT
 3207  Z('B'):
 3208  Z(113):       ! LOWER CASE 'Q'
 3209        JUMP TO(TAG, JUMP, DEFINE);  ->NEXT
 3210  Z('F'):
 3211  Z(117):      ! LOWER CASE 'U'
 3212        JUMP TO(TAG, JUMP, REDEFINE);  ->NEXT
 3213  Z('J'):JUMP TO(-TAG, JUMP, DEFINE);  ->NEXT
 3214  Z('L'):DEFINE LABEL(-TAG);  ->NEXT
 3215  Z(':'):DEFINE LABEL(TAG);  ->NEXT
 3216  Z(102):FOR;  ->NEXT;      !  LOWER CASE 'F'
 3217  
 3218  Z('P'):POP LHS;  DROP(LHS);    DUMP(LHS_DISP);  LIMEN = CA;  ->NEXT
 3219  Z(122):POP LHS;  DROP(LHS);  CONTROL = LHS_DISP
 3220         %IF CONTROL&UNASS DIAG # 0 %START
 3221            ACTIVITY(R4) = -1
 3222            ABORT(-14) %IF ENTER UNASS = 0
 3223         %FINISH %ELSE ACTIVITY(R4) = 0
 3224         ->NEXT
 3225  
 3226  Z(100):ABORT(-9) %IF TAG # 1;    ! LOWER CASE 'D'
 3227         SET BOTH
 3228         DOPE = 0
 3229         %UNLESS CONST(LHS) %AND CONST(RHS) %START
 3230            LOAD(LHS, P2);  LOAD(RHS, R3)
 3231            DOPE = -FRAME;  FRAME = FRAME+12
 3232            DYNAMIC = -1
 3233         %ELSE
 3234            DYNAMIC = 0
 3235            VLB = LHS_DISP;  VUB = RHS_DISP
 3236            ABORT(-7) %AND VUB = VLB %UNLESS VLB <= VUB
 3237         %FINISH
 3238         STP = STP-2
 3239         DROP(RHS);  DROP(LHS)
 3240         ->NEXT
 3241  Z(104):%IF DYNAMIC # 0 %START;   ! LOWER CASE 'H'
 3242            %IF DYNAMIC < 0 %START
 3243               RI2(LHI, P1, LOCAL, -DOPE)
 3244  BIG STATIC:  CSTACK(DATA SIZE);  POP LHS;  LRD(LHS, R1)
 3245               RELEASE(P2);  RELEASE(R3)
 3246               PERM(ASET)
 3247               DYNAMIC = 1
 3248            %FINISH
 3249            DECVAR_FORM = ARRAYNAME;  DECVAR_DISP = FRAME
 3250            FRAME = FRAME+8
 3251            RI2(LHI, R3, LOCAL, DECVAR_DISP);  PERM(ALLOC)
 3252         %ELSE
 3253            %IF DOPE = 0 %START
 3254               GFIX(4);  DOPE = GA
 3255               GWORD(VLB);  GWORD(VUB);  GWORD(DATA SIZE)
 3256            %FINISH
 3257            K = (VUB-VLB+1)*DATA SIZE + FRAME
 3258            %IF K > MAX STATIC %AND GMODE = 0 %START;    ! TOO BIG FOR LOCALS
 3259               CSTACK(VLB);  CSTACK(VUB);  SET BOTH
 3260               LOAD(LHS, P2);  LOAD(RHS, R3)
 3261               DROP(RHS);  DROP(LHS);  STP = STP-2
 3262               RI2(LHI, P1, GLA, DOPE);  FORGET(P1)
 3263               DOPE = -DOPE
 3264               -> BIG STATIC
 3265            %FINISH
 3266            DECVAR_DISP = FRAME-VLB*DATA SIZE
 3267            FRAME = K
 3268         %FINISH
 3269         DECVAR_EXTRA = DOPE
 3270  Z(99):->NEXT;    ! LOWER CASE 'C'
 3271  Z('G'):READSYMBOL(GG)
 3272         GMODE = \GMODE
 3273         %IF GMODE # 0 %START
 3274            ASSEMBLE(GTYPE, LABS, NAMES)
 3275         %ELSE
 3276            SPS = 0;  N = P1
 3277            GVAR_LENGTH = (FRAME+(REGLEN-1))&(\(REGLEN-1)) %IF GG=FORMATS
 3278            LEN = NAMES-GSTART
 3279            J = 0;  J = LEN %IF GG = FORMATS
 3280            %IF LEN > 0 %START
 3281               LEN = 0
 3282               GVAR_EXTRA = PARMS-J
 3283               %FOR J = GSTART+1, 1, NAMES %CYCLE
 3284                  PARMS = PARMS-1
 3285                  FP == VAR(PARMS);  AP == VAR(J)
 3286                  FP = AP
 3287                  %IF GG # FORMATS %START
 3288                     %IF FP_BASE = PARAM %START
 3289                        AP_BASE = LOCAL;  FP_DISP = N
 3290                        %IF GG = PROCEDURE %START
 3291                           VSTACK(AP);  POP LHS;  DROP(LHS)
 3292                           %IF LHS_FORM # V IN S %START
 3293                              LHS_TYPE = INTEGER;  LHS_FORM = V IN S
 3294                           %FINISH
 3295                           REMEMBER(N, LHS)
 3296                        %FINISH
 3297                     %ELSE
 3298                        FP_BASE = WSP;  N = P2
 3299                     %FINISH
 3300                  %FINISH
 3301                  %IF CONTROL < 0 %START
 3302                     DISPLAY VAR(FP);  DISPLAY VAR(AP)
 3303                  %FINISH
 3304                  N = N-1
 3305               %REPEAT
 3306               ABORT(-4) %IF PARMS <= NAMES
 3307               %IF GG # FORMATS %START
 3308                  %IF FP_TYPE = STRING %AND FP_FORM = 1 %START
 3309                     FP_TYPE = 15;  N = 0
 3310                  %FINISH
 3311               %FINISH
 3312            %FINISH
 3313            ->OUT %IF GG # PROCEDURE
 3314            HEADER(GVAR)
 3315            %IF N = 0 %START
 3316               RX(LHI, R2, LOCAL, AP_DISP)
 3317               %IF CONTROL&ASSDIAG # 0 %AND AP_SIZE # 255 %START
 3318                  CSTACK(AP_SIZE);  POP LHS;  LRD(LHS, R0)
 3319                  PERM(STRING ASS)
 3320               %FINISH
 3321               PERM(SMOVE)
 3322            %FINISH
 3323         %FINISH
 3324         ->NEXT
 3325  Z('H'):
 3326         %IF CA = 0 %START;           ! INITIAL BEGIN
 3327            ENTER UNASS = 0
 3328            %IF CONTROL&UNASS DIAG # 0 %START
 3329               ENTER UNASS = X'0140'+ACTUAL(CODE)
 3330               DUMP(X'0234');  DUMP(X'0884');  DUMP(X'2401')
 3331               DUMP(X'2410');  DUMP(X'2440')
 3332               DUMP(X'583D');  DUMP(SIGNAL EP)
 3333               DUMP(X'0303')
 3334               DUMP(X'8080');  DUMP(X'8080')
 3335               DUMP(X'8080');  DUMP(X'8080')
 3336            %FINISH
 3337            HEADER(BEGIN)
 3338         %FINISH
 3339         N = TEMP
 3340         HALF = LOCAL;  K = N;  RANGE(HALF, K)
 3341         RX(ST, WSP, HALF, K)
 3342         DECVAR == BEGIN
 3343         ASSEMBLE(0, LABS, NAMES)
 3344         HALF = LOCAL;  K = N;  RANGE(HALF, K)
 3345         RX(LW, WSP, HALF, K)
 3346         ->NEXT
 3347  
 3348  Z(115):                     ! LOWER CASE 'S'  -  %STOP
 3349         CSTACK(0);  CSTACK(0)
 3350  Z(101):     !  LOWER CASE 'E' -- %SIGNAL EVENT,SUBEVENT,EXTRA
 3351         N = STP+R0-1
 3352         %WHILE STP # 0 %CYCLE
 3353            POP LHS;  LRD(LHS, N-STP)
 3354         %REPEAT
 3355         PERM(MONITOR)
 3356         UNCOND JUMP = CA;  STP = 0
 3357         -> NEXT
 3358  
 3359  Z(';'):%IF AMODE = 0 %START
 3360            OLD FRAME = FRAME
 3361         %ELSE
 3362            PATCH((FRAME+(REGLEN-1))&(\(REGLEN-1)), SIZE PATCH)
 3363            %IF UNCOND JUMP # CA %START
 3364               %IF GVAR_TYPE # 0 %START
 3365                  ABORT(-11);       ! ...%RESULT MISSING
 3366               %ELSE
 3367                  RETURN
 3368               %FINISH
 3369            %FINISH
 3370         %FINISH
 3371         SET DIAG(0, 0, 0, -1)
 3372  OUT:   FRAME = OLD FRAME
 3373         %IF AMODE > 0 %START
 3374            ACTIVITY(LOCAL) = 0
 3375            ASS LEVEL = ASS LEVEL-1;  LOCAL = BASE REG(ASS LEVEL)
 3376         %FINISH
 3377         XLEVEL = XLEVEL-1
 3378     %END;! OF ASSEMBLE
 3379  
 3380  
 3381     FAULTY = 0
 3382  
 3383     ABORT(0) %IF MAX VARS = 1;    ! ----COMPILER CAN'T RUN AT ALL----
 3384  
 3385     SELECT INPUT(INSTREAM)
 3386     SELECT OUTPUT(DIRECT);  PRINT SYMBOL(INIT GLA)
 3387     SELECT OUTPUT(OBJECT);  PRINT SYMBOL(START)
 3388     BLOCK WORD = 'B'-32+('L'-32)<<6+('O'-32)<<12 %C
 3389+                       +('C'-32)<<18+('K'-32)<<24
 3390     CA = 0;  LIMEN = 0;  GA = INIT GLA;  DA = 0;  LINE SIZE = 0
 3391     STP = 0;  STACK ASL = 0;  ENVP = 0;  GMODE = 0
 3392     UNCOND JUMP = 0;  CURRENT LINE = 0
 3393     INVERT = 0;  SWOPPED = 0
 3394     PARMS = MAX VARS
 3395     CSLEN == CURRENT STRING(0);  CSLEN = 0;  ACTIVE STRING == NULL
 3396     ACTIVITY(J) = 0 %FOR J = 0, 1, 44
 3397     USED(J) = 0 %FOR J = 0, 1, 20
 3398     ACTIVITY(WSP) = -1;  ACTIVITY(GLA) = -1;  ACTIVITY(CODE) = -1
 3399     ACTIVITY(0) = -1;  KNOWN_CA = -1
 3400     ACTIVITY(R4) = -1 %IF CONTROL&UNASS DIAG # 0
 3401     ENTER UNASS = -1
 3402     ENVIR(J) = 0 %FOR J = 0, 1, MAX ENVIRS
 3403     %for j = 1,1,44 %cycle
 3404        use(j) = 0
 3405        USE(J)_CA = -8
 3406     %repeat
 3407     %FOR J = 0, 1, MAX STACK-1 %CYCLE
 3408        STAK(J)_LINK == STAK(J+1)
 3409        DLIST(J)_LINK == DLIST(J+1)
 3410     %REPEAT
 3411     STAK(MAX STACK)_LINK == NULL;  DLIST(MAX STACK)_LINK == NULL
 3412     DESC ASL == STAK(0);  DASL == DLIST(0)
 3413     USING_LINK == NULL
 3414     DECVAR == BEGIN
 3415  
 3416     ASSEMBLE(2, 0, 0);           ! ASSEMBLE THE OUTER BLOCK (+REST)
 3417  
 3418     GFIX(4)
 3419     PRINTSYMBOL(CEND)
 3420     SELECTOUTPUT(DIRECT);  PRINTSYMBOL(DEND)
 3421     PUT(CA);  PUT((GA+1)&(\1));  PUT(LINE SIZE);  PUT(DA)
 3422  
 3423     %SIGNAL 15,3 %IF FAULTY # 0
 3424  
 3425  %ENDOFPROGRAM
?TRUSTED unused

 3667 Statements compiled
