         Edinburgh IMP77 Compiler - Version 8.4

    1  %BEGIN;                               !HAL-70
    2  !    INPUT/OUTPUT STREAMS
    3  %OWNINTEGER MAIN=1, PRE=2;            !INPUT
    4  %OWNINTEGER BIN=1, LIS=2;             !OUTPUT
    5  !    OPERAND TYPES
    6  %OWNINTEGER OPMASK=16_F000;           !MACHINE INSTRUCTION OR MACRO
    7  %OWNINTEGER MACRO=16_A000
    8  %OWNINTEGER SINGLE=16_5000
    9  %OWNINTEGER FMASK=16_0800;            !FORWARD REF
   10  %OWNINTEGER OPFMASK=16_F800;          !=OPMASK+FMASK
   11  %OWNINTEGER UMASK=16_0200;            !UNDEF (FORWARD REF)
   12  %OWNINTEGER BMASK=16_0100;            !BYTE
   13  %OWNINTEGER REG=16_0080;              !REGISTER
   14  %OWNINTEGER MEMMASK=16_0040;          !MEM REF
   15  %OWNINTEGER RELMASK=16_0020;          !RELOCATABLE
   16  %OWNINTEGER XMASK=16_0010;            !INDEXED
   17  %OWNINTEGER REGXMASK=16_0090;         !=REG+XMASK
   18  %OWNINTEGER RELUXMASK=16_0230;        !=RELMASK+UMASK+XMASK
   19  !    TEXT POINTERS (BYTE ADDRESSES)
   20  %OWNINTEGER CODEPOS;                  !(NOT ACTUALLY BYTE)
   21  %OWNINTEGER STARTPOS;                 !START OF CURRENT LINE
   22  %OWNINTEGER GETPOS;                   !INPUT POINTER (NEXT)
   23  %OWNINTEGER PUTPOS
   24  %OWNINTEGER PSEUDOLIM
   25  %OWNINTEGER PRINTPOS;                 !START OF PRINT LINE
   26  %OWNINTEGER FAULTPOS
   27  %OWNINTEGER MACLIM;                   !MACRO DEF LIMIT
   28  !    OTHER POINTERS (WORD ADDRESSES)
   29  %OWNINTEGER MP;                       !MACRO-CALL PARAMETERS
   30  %OWNINTEGER QBASE,QSTART,QLIM,TRANSF; !OPERAND QUEUE
   31  %OWNINTEGER DEFMIN;                   !TAG MIN (DOWN - RESET)
   32  %OWNINTEGER DEFLIM;                   !TAG LIM (FIXED)
   33  %OWNINTEGER ALMAX;                    !ASSEMBLER LAB MAX (UP - RESET)
   34  %OWNINTEGER LABMIN;                   !USER LAB MIN (DOWN - RESET)
   35  %OWNINTEGER LABLIM;                   !USER LAB LIM (FIXED)
   36  %OWNINTEGER BP;                       !BLOCK POINTER (UP - DOWN)
   37  %OWNINTEGER NP;                       !NEST POINTER (DOWN - UP)
   38  %OWNINTEGER STORELIM;                 !(FIXED)
   39  %INTEGER SYM;                         !CURRENT SYMBOL
   40  %INTEGER TERM;                        !TAG TERMINATOR
   41  %INTEGER FSYM;                        !FAULT FLAG SYMBOL
   42  %OWNINTEGER CHARS=0;                  !PRINT CHAR COUNT
   43  %OWNINTEGER LINES=0;                  !PRINT LINE COUNT
   44  %OWNINTEGER BINCOUNT=0;               !OUTPUT RECORD ITEM COUNT
   45  %OWNINTEGER CHECK=0;                  !OUTPUT RECORD CHECKSUM
   46  %OWNINTEGER PASS=-1;                  !CURRENT PASS (-1,0,1)
   47  %OWNINTEGER LIST=-1;                  !LISTING CONTROL
   48  %INTEGER ASSCOND,SKIP;                !ASSEMBLY CONDITIONS (BIT NEST)
   49  %OWNINTEGER SAVE=1;                   !REG SAVE DISPLACEMENT
   50  %OWNINTEGER TEMPS=12;                 !TEMPORARY REGISTER SET (2,3)
   51  %INTEGER LOCTYPE,LOC;                 !LOCATION COUNTER
   52  %INTEGER ACC,ATYPE,AVAL;              !MAIN TEMP REGISTER
   53  %INTEGER CREG,CTYPE,CVAL;             !CONDITION CODE
   54  %INTEGER COND;                        !CONDITION CODE MASK
   55  %INTEGER DREG,DUSE;                   !DESTINATION REGISTER
   56  %INTEGER TYPE,VAL;                    !CURRENT TYPE,VALUE
   57  %INTEGER TAG1,TAG2;                   !TAG (CHARS 1:3, 4:6)
   58  %INTEGER MODE;                        !ASSEMBLY MODE
   59  %INTEGER PEND;                        !TAG ALREADY RECOGNISED
   60  %INTEGER FLAG;                        !JUMPS / AHM
   61  %OWNINTEGER QQ='?'
   62  %OWNINTEGERARRAY BREC(1:52);          !BINARY OUTPUT RECORD
   63  %constINTEGER SBOUND = 32767;
   64      SELECT OUTPUT(LIS)
   65  %ownINTEGERARRAY STORE(0:SBOUND)
   66  %INTEGERFN CHAR(%INTEGER P)
   67    %result = STORE(P)
   68  %END
   69  %ROUTINE PUT CHAR(%INTEGER K)
   70  !AT PUTPOS WITH POST-INCREMENT
   71    !printstring("Putpos = "); write(putpos, -1); newline
   72    STORE(PUTPOS) = K
   73    PUTPOS = PUTPOS + 1
   74  %END
   75  %ROUTINE FAULT(%INTEGER K)
   76  !RECORD (FIRST) FAULT
   77  !NOT NECESSARILY CULPABLE IN PASS 0
   78      FSYM = K %IF FSYM = ' '
   79  %END
   80  
   81  %integermap integer(%integer p)
   82    %result == store(p)
   83  %end
   84  
   85  %ROUTINE PRINT(%INTEGER K)
   86      INTEGER(CODEPOS+CHARS) = K
   87      CHARS = CHARS+1
   88  %END
   89  %ROUTINE PRINT WORD(%INTEGER V)
   90      %ROUTINE PRINT HIT(%INTEGER V)
   91          V = V&15+'0';  V = V+7 %IF V > '9'
   92          PRINT(V)
   93      %END
   94      %ROUTINE PRINT1(%INTEGER V)
   95          PRINT HIT(V>>4);  PRINT HIT(V)
   96      %END
   97      PRINT1(V>>8);  PRINT1(V)
   98  %END
   99  %ROUTINE PRINT LOC
  100      PRINT WORD(LOC)
  101      %IF LOCTYPE&RELMASK # 0 %THEN PRINT('''') %ELSE PRINT(' ')
  102      PRINT(' ')
  103  %END
  104  %ROUTINE DO NEWLINE
  105      NEWLINE;  LINES = LINES+1
  106      NEWLINES(2) %AND LINES = 0 %IF LINES = 61
  107  %END
  108  %ROUTINE PRINT LINE
  109     %ROUTINE PRINTIT(%INTEGER SUB)
  110     %OWNINTEGER MARKER=124;            !VERTICAL BAR
  111     %INTEGER P,Q,K
  112         %RETURN %IF CHARS = 0 %AND CHAR(PRINTPOS) = NL
  113         PRINT SYMBOL(FSYM);  SPACE
  114         P = CODEPOS;  Q = P+CHARS
  115         PRINT SYMBOL(INTEGER(P)) %AND P=P+1 %WHILE P # Q
  116         %RETURN %IF PRINTPOS = 0
  117         SPACES(17-CHARS)
  118         P = PRINTPOS;  Q = 0
  119         %CYCLE
  120            PRINT SYMBOL(MARKER) %IF P = FAULTPOS
  121            K = CHAR(P);  K = SUB %IF P = PSEUDOLIM
  122            PRINT SYMBOL('''') %IF (K!!Q)&128 # 0
  123            %RETURN %IF K = NL
  124            PRINT SYMBOL(K&127)
  125            P = P+1;  Q = K
  126         %REPEAT
  127     %END
  128      %RETURN %IF PASS = 0
  129      %UNLESS LIST < 0 %OR (PRINTPOS=0 %AND FSYM=' ' %AND LIST&1=0) %START
  130         NEWLINES(3) %IF LINES = 0
  131         PRINTIT(' ')
  132         DO NEWLINE
  133      %FINISH
  134      %IF FSYM # ' ' {%AND OUTDEV # 1} %START
  135         SELECT OUTPUT(0)
  136         PRINTPOS = STARTPOS %IF PRINTPOS = 0
  137         PRINT LOC %IF CHARS = 0
  138         PRINTIT(NL)
  139         NEWLINE
  140         SELECT OUTPUT(LIS)
  141      %FINISH
  142      FSYM = ' ';  PRINTPOS = 0;  CHARS = 0
  143  %END
  144  %ROUTINE PUT(%INTEGER V)
  145  !STORE 4-BIT ITEM IN BINARY RECORD
  146  %OWNINTEGER HOLD=0
  147      V = V&15
  148      HOLD = HOLD<<4+V
  149      BINCOUNT = BINCOUNT+1
  150      %IF BINCOUNT&3 = 0 %START
  151         BREC(BINCOUNT>>2) = HOLD
  152         CHECK = CHECK!!HOLD
  153         HOLD = 0
  154      %FINISH
  155  %END
  156  %ROUTINE PUT WORD(%INTEGER V)
  157      %ROUTINE PUT1(%INTEGER V)
  158          PUT(V>>4);  PUT(V)
  159      %END
  160      PUT1(V>>8);  PUT1(V)
  161  %END
  162  %ROUTINE OUTPUT RECORD
  163  %OWNINTEGER SEQ=0
  164  %INTEGER I
  165      %ROUTINE OUTPUT WORD(%INTEGER W)
  166          PRINT SYMBOL(W>>8&255);  PRINT SYMBOL(W&255)
  167      %END
  168      PUT(0) %WHILE BINCOUNT # 208
  169      SELECT OUTPUT(BIN)
  170      %CYCLE I = 1,1,10
  171         PRINT SYMBOL(0);                   !RUNOUT
  172      %REPEAT
  173      PRINT SYMBOL(16_F0);                  !HEADER CODE
  174      SEQ = SEQ-1
  175      OUTPUT WORD(SEQ);                 !SEQUENCE NUMBER
  176      OUTPUT WORD(\(CHECK!!SEQ));       !CHECKSUM
  177      %CYCLE I = 1,1,52
  178         OUTPUT WORD(BREC(I))
  179      %REPEAT
  180      BINCOUNT = 0;  CHECK = 0
  181      SELECT OUTPUT(LIS)
  182  %END
  183  %ROUTINE PLANT VAL
  184  %INTEGER I,J
  185      TYPE = 0 %IF TYPE = SINGLE
  186      I = 2;  I = 4 %IF TYPE&OPMASK # 0
  187      %IF PASS > 0 %START
  188         OUTPUT RECORD %IF BINCOUNT+I+I >= 208
  189         %IF I = 4 %START
  190            %IF TYPE&16_4000 = 0 %START
  191               PUT(11);  J = TYPE!!OPMASK
  192               TYPE = RELMASK
  193            %FINISH %ELSE %START
  194               PUT(10);  J = TYPE;  TYPE = 0
  195            %FINISH
  196            PUT WORD(J)
  197            PRINT LINE %IF CHARS # 0
  198            PRINT LOC
  199            PRINT WORD(J);  PRINT(' ')
  200         %FINISH %ELSE %START
  201            %IF TYPE&RELMASK # 0 %THEN PUT(9) %ELSE PUT(8)
  202            %IF CHARS # 0 %THEN PRINT(' ') %ELSE PRINT LOC
  203         %FINISH
  204         PUT WORD(VAL);  PRINT WORD(VAL)
  205         PRINT('''') %IF TYPE&RELMASK # 0
  206         PRINT LINE %IF TYPE&RELMASK#0 %OR CHARS=15
  207      %FINISH
  208      LOC = LOC+I
  209  %END
  210  %ROUTINE NEST(%INTEGER K)
  211      NP = NP-1;  %SIGNAL %EVENT 14,23 %IF NP = BP
  212      INTEGER(NP) = K
  213  %END
  214  %ROUTINE SET LAB(%INTEGER DEST)
  215  %INTEGER D
  216      D = DEST
  217      %CYCLE
  218         TYPE = INTEGER(NP)&16_FFF+DEFLIM; !DEST SLOT
  219         NP = NP+1
  220         VAL = INTEGER(NP);             !LOC OF JUMP
  221         NP = NP+1
  222         ATYPE = -1;  CREG = -1
  223         FLAG = 0;  FLAG = 2 %IF (D-VAL)>>1+PASS <= 16
  224         VAL = VAL-FLAG
  225         %IF PASS = 0 %START
  226            D = D-FLAG;  INTEGER(TYPE) = D
  227            %IF FLAG # 0 %START
  228               LOC = LOC-2;  DEST = DEST-2
  229               %WHILE TYPE # ALMAX %CYCLE
  230                  TYPE = TYPE+1;  INTEGER(TYPE) = INTEGER(TYPE)-2
  231               %REPEAT
  232            %FINISH
  233         %FINISH %ELSE %START
  234            FAULT('P') %IF INTEGER(TYPE) # D
  235         %FINISH
  236         %RETURN %UNLESS INTEGER(NP)&16_1000 # 0
  237         %IF INTEGER(NP)&16_2000 # 0 %START; !OR
  238            D = VAL+4 %IF D = DEST
  239         %FINISH %ELSE %START
  240            D = DEST
  241         %FINISH
  242      %REPEAT
  243  %END
  244  %ROUTINE ASSEMBLE
  245  !   INTERDATA OP-CODES (+FORMATS)
  246  %OWNINTEGER LOAD=16_080F, LB=16_9303
  247  %OWNINTEGER ADD=16_0A0F, SUB=16_0B0F, AND=16_0407
  248  %OWNINTEGER OR=16_0607, XOR=16_0707
  249  %OWNINTEGER SLLS=16_7508, SRLS=16_7408, SLHL=16_0D04, SRHL=16_0C04
  250  %OWNINTEGER COMP=16_0907, CLB=16_9402
  251  %OWNINTEGER STORE=16_0002, STB=16_9202, AHM=16_2102
  252  %OWNINTEGER BT=16_0203, BF=16_0303
  253  !    FORMAT CODES
  254  %OWNINTEGER REGISTER=1, MEM=2, LIT=4, SHORT=8
  255  %OWNINTEGER ZQUERY=0
  256  %INTEGER OP,K,Q,LITVAL,NQ,TYPE1,VAL1,FREE
  257  %SWITCH ASS(-30:-1)
  258  %ROUTINE FORM INST(%INTEGER CODE)
  259  !    LS 4 BITS OF CODE DEFINE VALID FORMATS
  260  !    INTERDATA OP-CODES FOR DIFFERENT FORMATS
  261  !    ARE SYSTEMATICALLY RELATED
  262  !    SHORT=REGISTER+SINC, LIT=REGISTER+LINC, MEM=REGISTER+MINC
  263  %OWNINTEGER SINC=16_1C00, LINC=16_C000, MINC=16_4000
  264  %INTEGER OP
  265      OP = CODE&16_FFF0
  266      %IF TYPE = REG %START
  267         %IF CODE&REGISTER # 0 %START
  268            TYPE = SINGLE;  VAL = OP+VAL
  269            %RETURN
  270         %FINISH
  271         TYPE = XMASK+VAL;  VAL = 0;    !COERCE TO INDEXED IMMEDIATE
  272      %FINISH
  273      %IF TYPE=0 %AND |VAL|<=15 %AND CODE&SHORT#0 %START; !SHORT
  274         VAL = -VAL %AND OP = OP!!16_100 %IF VAL < 0
  275         TYPE = SINGLE;  VAL = OP+SINC+VAL
  276      %FINISH %ELSE %START
  277         FAULT('R') %IF TYPE&31 = XMASK; !R0 AS INDEX
  278         %IF TYPE&MEMMASK = 0 %START;   !IMMEDIATE
  279            FAULT('I') %IF CODE&LIT = 0
  280            OP = OP+LINC
  281         %FINISH %ELSE %START;                  !MEMORY
  282            FAULT('I') %IF CODE&MEM = 0
  283            OP = OP+MINC
  284         %FINISH
  285         OP = OP!!OPMASK %IF TYPE&RELMASK # 0
  286         TYPE = TYPE&15+OP
  287      %FINISH
  288  %END
  289  %ROUTINE PLANT JUMP
  290  %INTEGER I,OP
  291      OP = BF;  COND=\COND %AND OP=BT %IF COND < 0
  292      %IF TYPE&(\UMASK) = LOCTYPE %START
  293         I = LOC>>1-VAL>>1
  294         FAULT('J') %AND I=0 %IF FLAG # 0 %AND |I| > 15
  295         %IF |I| <= 15 %START
  296            %IF TYPE&UMASK = 0 %OR FLAG # 0 %START
  297               OP = OP<<1+2;            !0408, 0608
  298               TYPE = 0;  VAL = I
  299            %FINISH %ELSE %START
  300               FAULT('S') %IF LIST >= 0 %AND LIST&8 # 0
  301            %FINISH
  302         %FINISH
  303      %FINISH
  304      FORM INST(COND<<4+OP)
  305      PLANT VAL
  306      COND = 0
  307  %END
  308  %ROUTINE SET JUMP(%INTEGER CASE)
  309  %INTEGER THOLD,VHOLD,FHOLD
  310      ALMAX = ALMAX+1;  %SIGNAL %EVENT 14,22 %IF ALMAX = LABMIN
  311      NEST(LOC);  NEST(ALMAX-DEFLIM+CASE)
  312      THOLD = TYPE;  VHOLD = VAL;  FHOLD = FLAG
  313      TYPE = LOCTYPE;  VAL = INTEGER(ALMAX);  FLAG = 0
  314      TYPE = TYPE+UMASK %IF PASS = 0
  315      COND = \COND
  316      PLANT JUMP
  317      TYPE = THOLD;  VAL = VHOLD;  FLAG = FHOLD
  318  %END
  319  %ROUTINE PLANT INST(%INTEGER CODE)
  320      FORM INST(CODE)
  321      SET JUMP(16_1000) %IF COND # 0
  322      PLANT VAL
  323  %END
  324  %ROUTINE LOAD REG(%INTEGER R)
  325  %INTEGER OP
  326      %IF ATYPE = TYPE %AND AVAL = VAL %START
  327         TYPE = REG;  VAL = ACC
  328         %RETURN %IF R = ACC
  329      %FINISH
  330      ATYPE = TYPE %AND AVAL = VAL %IF R = ACC
  331      ATYPE = -1 %IF (ATYPE=REG %AND AVAL=R) %OR ATYPE&15=R#0
  332      %IF TYPE&BMASK = 0 %START
  333         OP = LOAD
  334         OP = ADD %AND TYPE = 0 %IF TYPE!!XMASK = R # 0
  335         CREG = R;  CTYPE = 0;  CVAL = 0
  336      %FINISH %ELSE %START
  337         OP = LB
  338         CREG = -1 %IF CREG = R
  339      %FINISH
  340      PLANT INST(R<<4+OP)
  341      TYPE = REG;  VAL = R
  342  %END
  343  %ROUTINE RELEASE
  344  %INTEGER I
  345      %RETURN %IF TYPE&REGXMASK = 0
  346      I = TYPE&15;  I = VAL %IF I = 0
  347      %IF I = DREG %START
  348         DUSE = DUSE-1
  349      %FINISH %ELSE %START
  350         I = 1<<I
  351         FREE = FREE!I %IF TEMPS&I # 0
  352      %FINISH
  353  %END
  354  %ROUTINE LOAD TEMP
  355  %INTEGER I,J
  356      RELEASE
  357      %IF DREG >= ZQUERY %AND DUSE = 0 %START
  358         I = DREG;  DUSE = 1
  359      %FINISH %ELSE %START
  360         J = 1+ZQUERY
  361         %CYCLE I = ZQUERY,1,15
  362            ->OK %IF FREE&J # 0 %AND I # DREG
  363            J = J<<1
  364         %REPEAT
  365         FAULT('R')
  366  OK:    FREE = FREE-J
  367      %FINISH
  368      LOAD REG(I)
  369  %END
  370  %ROUTINE SWOP
  371  %INTEGER K
  372      K = TYPE1;  TYPE1 = TYPE;  TYPE = K
  373      K = VAL1;  VAL1 = VAL;  VAL = K
  374  %END
  375  %ROUTINE PROGREF
  376      %IF TYPE&RELUXMASK = XMASK %AND VAL = 0 %START
  377         VAL = TYPE&15;  TYPE = REG
  378      %FINISH
  379      TYPE = TYPE!MEMMASK %IF TYPE # REG
  380  %END
  381      Q = QSTART
  382  NEW:NQ = QSTART;  FREE = TEMPS
  383      TYPE = INTEGER(Q);  Q = Q+1
  384      VAL = INTEGER(Q);  Q = Q+1
  385  GET:%CYCLE
  386        %RETURN %IF Q = QLIM
  387         K = INTEGER(Q);  Q = Q+1
  388         ->ASS(K) %IF K < 0
  389         INTEGER(NQ) = TYPE1;  INTEGER(NQ+1) = VAL1
  390         NQ = NQ+2
  391         TYPE1 = TYPE;  VAL1 = VAL
  392         TYPE = K;  VAL = INTEGER(Q);  Q = Q+1
  393      %REPEAT
  394  %PREDICATE TEMP
  395      %FALSE %IF TYPE1 # REG
  396      %IF VAL1 = DREG %START
  397         %FALSE %IF DUSE # 1
  398      %FINISH %ELSE %START
  399         %FALSE %IF 1<<VAL1&TEMPS = 0
  400      %FINISH
  401      %TRUE
  402  %END
  403  NOP: K = 0;                           !NOT SYMMETRIC
  404  BOP:%IF MODE <= 0 %OR (TYPE = 0 %AND TYPE1 = 0) %START
  405         FAULT('A') %IF TYPE # 0
  406         TYPE = TYPE1;  VAL = LITVAL
  407      %FINISH %ELSE %START
  408         %IF %NOT TEMP %OR (TYPE=REG %AND VAL=DREG %AND DUSE=1 %AND K#0) %START
  409            SWOP
  410            %IF K = 0 %OR %NOT TEMP %START
  411               LOAD TEMP;  SWOP
  412            %FINISH
  413         %FINISH
  414         LOAD TEMP %IF TYPE&BMASK # 0 %OR (OP&MEM=0 %AND TYPE&MEMMASK#0)
  415         RELEASE
  416         PLANT INST(VAL1<<4+OP)
  417         TYPE = REG;  VAL = VAL1
  418         CREG = VAL;  CTYPE = 0;  CVAL = 0
  419         ATYPE = -1 %IF ACC = VAL %OR ATYPE&15 = VAL # 0
  420         ATYPE = -1 %IF ATYPE = REG %AND AVAL = VAL
  421      %FINISH
  422  POP:NQ = NQ-2
  423      TYPE1 = INTEGER(NQ);  VAL1 = INTEGER(NQ+1)
  424      ->GET
  425  ASS(-2):
  426      OP = SUB
  427      ->NOP %IF MODE > 0 %AND TYPE # 0
  428      TYPE1 = 0 %AND TYPE = 0 %IF MODE <= 0 %AND TYPE1 = TYPE
  429      VAL = -VAL
  430  ASS(-1):
  431      OP = ADD;  LITVAL = VAL1+VAL
  432      ->BOP %UNLESS TYPE = 0
  433      %IF TYPE1&MEMMASK # 0 %AND MODE > 0 %START
  434         SWOP;  LOAD TEMP;  SWOP
  435      %FINISH
  436      %IF TYPE1 = REG %START
  437         ->BOP %IF VAL1 = 0
  438         TYPE1 = XMASK+VAL1;  LITVAL = VAL
  439      %FINISH
  440      TYPE = TYPE1;  VAL = LITVAL
  441      ->POP
  442  ASS(-3):
  443      OP = AND;  LITVAL = VAL1&VAL
  444      ->BOP
  445  ASS(-4):
  446      OP = OR;  LITVAL = VAL1!VAL
  447      ->BOP
  448  ASS(-5):
  449      OP = XOR;  LITVAL = VAL1!!VAL
  450      ->BOP
  451  ASS(-6):
  452      OP = SLLS;  LITVAL = VAL1<<VAL
  453      OP = SLHL %IF TYPE # 0
  454      ->NOP
  455  ASS(-7):
  456      OP = SRLS;  LITVAL = VAL1>>VAL
  457      OP = SRHL %IF TYPE # 0
  458      ->NOP
  459  ASS(-8):                              !TYPE_VAL
  460      TYPE = VAL1
  461      TYPE = 0 %IF TYPE&OPMASK = MACRO; !SAFETY
  462      TYPE = 0 %IF TYPE&(OPMASK+FMASK) = FMASK
  463      ->POP
  464  ASS(-11):                             !COMPARE
  465      K = INTEGER(Q);  Q = Q+1
  466      %IF MODE <= 0 %START
  467         VAL1 = TYPE1 %AND VAL = TYPE %IF TYPE1 # TYPE
  468         LITVAL = \3
  469         LITVAL = 1 %IF VAL1 < VAL
  470         LITVAL = 2 %IF VAL1 > VAL
  471         K = K&LITVAL;  K = \0 %IF K # 0
  472      %FINISH %ELSE %UNLESS CREG=16 %AND TYPE1=CTYPE %AND VAL1=CVAL %AND TYPE=VAL=0 %START
  473         %IF TYPE1 # REG %START
  474            SWOP
  475            %IF TYPE1 # REG %START
  476               LOAD TEMP;  SWOP
  477            %FINISH %ELSE %START
  478               K = K!!3 %UNLESS K = 3 %OR K = \3
  479            %FINISH
  480         %FINISH
  481         %UNLESS CREG = VAL1 %AND CTYPE = TYPE %AND CVAL = VAL %START
  482            CREG = VAL1;  CTYPE = TYPE;  CVAL = VAL
  483            %UNLESS TYPE = VAL = 0 %START
  484               OP = COMP
  485               %IF TYPE = ATYPE %AND VAL = AVAL %START
  486                  TYPE = REG;  VAL = ACC
  487               %FINISH
  488               %IF TYPE&BMASK # 0 %START
  489                  OP = CLB
  490                  FAULT('I') %UNLESS K = 3 %OR K = \3
  491               %FINISH
  492            %FINISH %ELSE %START
  493               OP = LOAD
  494               TYPE = REG;  VAL = VAL1
  495            %FINISH
  496            PLANT INST(VAL1<<4+OP)
  497         %FINISH
  498      %FINISH
  499      COND = K
  500      ->GET
  501  ASS(-12):                             !TEST CC
  502      COND = \VAL
  503      ->GET
  504  ASS(-13):                             !AND,WHILE
  505      %IF MODE > 0 %START
  506         SET JUMP(16_1000)
  507      %FINISH %ELSE %START
  508         %RETURN %IF COND # 0;          !CONDITION FALSE
  509      %FINISH
  510      %RETURN %IF Q = QLIM
  511      ->NEW
  512  ASS(-14):                             !OR
  513      %IF MODE > 0 %START
  514         COND = \COND
  515         SET JUMP(16_3000)
  516      %FINISH %ELSE %START
  517         %RETURN %IF COND = 0;          !CONDITION TRUE
  518      %FINISH
  519      ->NEW
  520  ASS(-15):                             !IF
  521      SET JUMP(16_2000)
  522      %RETURN
  523  ASS(-16):                             !ELSE
  524      COND = \0
  525      SET JUMP(16_4000)
  526      %RETURN
  527  ASS(-17):                             !IF AFTER ELSE
  528      SET JUMP(16_6000)
  529      %RETURN
  530  ASS(-18):                             !MACCALL IF
  531      SET JUMP(16_8000)
  532      %RETURN
  533  ASS(-20):                             !HASH
  534      TYPE = TYPE&(UMASK+63)
  535      ->GET
  536  ASS(-21):                             !INDEX
  537      FAULT('I') %IF TYPE1&REGXMASK # 0
  538      %IF TYPE&MEMMASK # 0 %START
  539         %IF MODE > 0 %START
  540            ZQUERY = 1
  541            LOAD TEMP
  542            ZQUERY = 0
  543         %FINISH %ELSE FAULT('A')
  544      %FINISH
  545      %IF TYPE = REG %START
  546         TYPE = XMASK+VAL;  VAL = 0
  547      %FINISH
  548      ZQUERY = 0
  549      FAULT('I') %IF TYPE1&TYPE&RELMASK # 0
  550      TYPE = TYPE1!TYPE!MEMMASK;  VAL = VAL1+VAL
  551      ->POP
  552  ASS(-22):                             !MINST SEPARATOR
  553      %IF TYPE1&OPMASK = 16_7000 %START
  554         %IF TYPE1&16_10 = 0 %START;    !REG-TYPE INST
  555            FAULT('I') %IF TYPE # REG
  556         %FINISH %ELSE %START
  557            VAL = \VAL %AND VAL1 = VAL1!!16_0100 %IF VAL < 0
  558            FAULT('I') %IF TYPE # 0 %OR VAL > 15
  559         %FINISH
  560         TYPE = TYPE1+16_8000;  VAL = VAL1&16_FF0F+VAL<<4
  561      %FINISH %ELSE %IF TYPE1&OPMASK = 16_F000 %START
  562         PROGREF %IF VAL1&16_FC0F = 16_0003; !BAL,BTC,BFC
  563         FORM INST(VAL1)
  564      %FINISH %ELSE FAULT('I')
  565      ->POP
  566  ASS(-23):                             !MACHINE INST
  567      SET JUMP(16_1000) %IF COND # 0
  568      PLANT VAL
  569      CREG = -1;  ATYPE = -1
  570      %RETURN
  571  ASS(-24):                             !LOAD
  572      LOAD TEMP %IF TYPE # REG
  573      Q = QBASE
  574      ->GET
  575  ASS(-25):                             !STORE (TYPE1,VAL1 -> TYPE,VAL)
  576      %IF TYPE = REG %START
  577         SWOP %AND LOAD REG(VAL1) %IF VAL1 # VAL
  578      %FINISH %ELSE %START
  579         ATYPE = -1 %IF ATYPE&MEMMASK # 0
  580         %IF FLAG = 0 %START
  581            %IF VAL1 = ACC %AND ATYPE < 0 %START
  582               K = TYPE&15
  583               ATYPE = TYPE %AND AVAL = VAL %IF K = 0 %OR 1<<K&TEMPS = 0
  584            %FINISH
  585            OP = STORE;  OP = STB %IF TYPE&BMASK # 0
  586         %FINISH %ELSE %START
  587            CREG = 16;  CTYPE = TYPE;  CVAL = VAL
  588            OP = AHM
  589         %FINISH
  590         PLANT INST(VAL1<<4+OP)
  591      %FINISH
  592      %RETURN
  593  ASS(-26):                             !JUMP
  594      SET JUMP(16_1000) %IF INTEGER(NP)&16_F000 = 16_3000; !OR
  595      %IF FLAG < 0 %START;              !REPEAT
  596         FLAG = 0
  597         %IF PASS = 0 %START
  598            K = NP;  LITVAL = LOC
  599            %WHILE INTEGER(K)&16_1000 # 0 %CYCLE
  600               K = K+2;  LITVAL = LITVAL-2
  601            %REPEAT
  602            FLAG = 1 %IF LITVAL-VAL < 32
  603         %FINISH
  604      %FINISH
  605      PROGREF
  606      PLANT JUMP
  607      %RETURN
  608  %END;  !ASSEMBLE
  609  %ROUTINE LOOKUP(%INTEGER CONTROL)
  610  !ALL DICT OPERATIONS LOCALISED HERE
  611  !CONTROL = 0 (LOOKUP ONLY), 1 (FORWARD OK),
  612  !          2 (REDEF), 3 (DEF),
  613  !          4 (MACPARM), 7 (LABEL)
  614  %INTEGER DP
  615      DP = DEFMIN;  DP = MP+5 %IF CONTROL = 4
  616      %WHILE INTEGER(DP) # 0 %CYCLE
  617         ->YES %IF INTEGER(DP) = TAG1 %AND INTEGER(DP+1) = TAG2
  618         DP = DP+4
  619      %REPEAT
  620  !%OWNINTEGER P
  621  NO:
  622      %RETURN %IF CONTROL&1 = 0;        !NO CREATION
  623  NEW:DEFMIN = DEFMIN-4;  DP = DEFMIN
  624      %SIGNAL %EVENT 14,21 %IF DP-QLIM <= 0
  625      INTEGER(DP) = TAG1;  INTEGER(DP+1) = TAG2
  626  SET:INTEGER(DP+2) = TYPE;  INTEGER(DP+3) = VAL
  627      %RETURN
  628  YES:%IF CONTROL&2 = 0 %START;         !NOT DEF CLASS
  629         TYPE = INTEGER(DP+2);  VAL = INTEGER(DP+3)
  630         %RETURN
  631      %FINISH
  632      %IF CONTROL = 3 %START
  633         ->NEW %IF DP-INTEGER(BP) >= 0; !GLOBAL
  634         FAULT('D')
  635      %FINISH
  636      ->SET %IF CONTROL # 7
  637      %IF INTEGER(DP+2)&OPFMASK = FMASK %START
  638         VAL = INTEGER(DP+3)
  639         %IF PASS = 0 %START
  640            INTEGER(VAL) = LOC
  641         %FINISH %ELSE %START
  642            FAULT('P') %AND LOC=INTEGER(VAL) %IF INTEGER(VAL) # LOC
  643         %FINISH
  644         VAL = LOC
  645      %FINISH %ELSE %START
  646         ->NEW %IF DP-INTEGER(BP) >= 0
  647         FAULT('D')
  648      %FINISH
  649      ->SET
  650  %END
?NO unused
  651  %ROUTINE TAGREF
  652  %OWNINTEGER B=2184, W=24717
  653      %IF TERM = '(' %START
  654         TYPE = 0;  VAL = 0
  655         %RETURN %IF TAG1 = W
  656         TYPE = BMASK
  657         %RETURN %IF TAG1 = B
  658      %FINISH
  659      TYPE = LOCTYPE+FMASK+UMASK;  VAL = LABMIN-1
  660      LOOKUP(1)
  661      %IF TYPE&OPFMASK = FMASK %START
  662         %IF VAL = LABMIN-1 %START
  663            LABMIN = VAL;  %SIGNAL %EVENT 14,22 %IF LABMIN = ALMAX
  664         %FINISH
  665         %IF PASS > 0 %START
  666            VAL = INTEGER(VAL)
  667            FAULT('U') %IF VAL = 0
  668         %FINISH
  669         TYPE = TYPE-FMASK
  670      %FINISH
  671  %END
  672  %ROUTINE GET SYM
  673      %CYCLE
  674         SYM = CHAR(GETPOS);  GETPOS = GETPOS+1
  675         %RETURN %IF SYM # ' '
  676      %REPEAT
  677  %END
  678  %PREDICATE S(%INTEGER K)
  679      %FALSE %UNLESS K = SYM
  680      GET SYM
  681      %TRUE
  682  %END
  683  %PREDICATE SS(%INTEGER K)
  684      %FALSE %UNLESS K = SYM = CHAR(GETPOS)
  685      GETPOS = GETPOS+1
  686      GET SYM
  687      %TRUE
  688  %END
  689  %PREDICATE TAG
  690  %INTEGER J,K
  691      %ROUTINE CODE SYM
  692         SYM = CHAR(GETPOS);  GETPOS = GETPOS+1
  693         K = SYM-'0'
  694         %IF K >= 0 %START
  695            TERM = -1 %AND %RETURN %IF K < 10
  696            K = SYM-'A'
  697            %RETURN %IF K >= 0 %AND K < 26 %AND TERM = 0
  698         %FINISH
  699         TERM = SYM
  700      %END
  701      %ROUTINE PACK TRIPLE
  702         ->T1 %IF TERM < 0
  703         J = ((K<<5+K)<<1+K)<<4+K+1111; !K*1073+1111
  704         CODE SYM
  705         ->T2 %IF TERM # 0
  706         J = (K<<3+K)<<2+K+111+J;       !J+K*37+111
  707         CODE SYM
  708         ->T3 %IF TERM # 0
  709         J = J+K+11
  710         CODE SYM
  711         %RETURN
  712  T1:    J = ((K<<1+K)<<1+K)<<4-K+1;    !K*111+1
  713         CODE SYM
  714  T2:    %RETURN %IF TERM > 0
  715         J = (K<<2+K)<<1+K+1+J;         !J+K*11+1
  716         CODE SYM
  717  T3:    %RETURN %IF TERM > 0
  718         J = J+K+1
  719         CODE SYM
  720      %END
  721      K = SYM-'A'
  722      %FALSE %UNLESS K >= 0 %AND K < 26
  723      %FALSE %IF SYM = 'X' %AND CHAR(GETPOS)&128 # 0
  724      TERM = 0
  725      PACK TRIPLE
  726      TAG1 = J
  727      %CYCLE
  728         J = 0
  729         PACK TRIPLE %IF TERM <= 0
  730         TAG2 = J
  731         CODE SYM %WHILE TERM <= 0
  732         %EXIT %UNLESS TERM = QQ
  733         TYPE = 1;  LOOKUP(0)
  734         FAULT('U') %IF TYPE # 0
  735         TAG1 = VAL
  736         TERM = 0;  CODE SYM
  737      %REPEAT
  738      GET SYM %IF TERM = ' '
  739      %TRUE
  740  %END
  741  %PREDICATE TAGIF
  742      %FALSE %UNLESS SYM='I' %AND CHAR(GETPOS)='F' %AND CHAR(GETPOS+1)=' '
  743      GETPOS = GETPOS+2
  744      GET SYM
  745      %TRUE
  746  %END
  747  %ROUTINE QUEUE(%INTEGER K)
  748      INTEGER(QLIM) = K
  749      QLIM = QLIM+1;  %SIGNAL %EVENT 14,21 %IF QLIM = DEFMIN
  750  %END
  751  %ROUTINE GET EXP
  752  %INTEGER I,NBASE
  753      NBASE = NP
  754      ->E3 %IF PEND # 0
  755  E1: NEST(0) %WHILE S('(')
  756      NEST(-20) %IF S('#')
  757      %IF TAG %START
  758  E3:    TAGREF %IF PEND >= 0
  759         PEND = 0
  760         %IF TYPE = REG %AND TERM = '(' %START
  761            TYPE = 0 %IF SAVE&1 = 0;  VAL = VAL+VAL+SAVE
  762         %FINISH
  763         FAULT('I') %AND TYPE=0 %IF TYPE&OPMASK # 0
  764         %IF MODE # 0 %START
  765            %IF TYPE&REGXMASK # 0 %START
  766               I = TYPE&15;  I = VAL %IF I = 0
  767               DUSE = DUSE+1 %IF I = DREG
  768            %FINISH
  769         %FINISH
  770         %IF TERM = '(' %START
  771            GET SYM
  772            I = TYPE&31
  773            QUEUE(TYPE-I);  QUEUE(VAL)
  774            NEST(-21);  NEST(0)
  775            %IF I # 0 %START
  776               QUEUE(REG);  QUEUE(I&15)
  777               NEST(-1)
  778            %FINISH
  779            ->E1
  780         %FINISH
  781      %FINISH %ELSE %IF '0' <= SYM <= '9' %START
  782         TYPE = 0;  VAL = SYM-'0'
  783         %CYCLE
  784            SYM = CHAR(GETPOS)-'0'
  785            %EXIT %UNLESS 0 <= SYM <= 9
  786            VAL = (VAL<<2+VAL)<<1+SYM
  787            GETPOS = GETPOS+1
  788         %REPEAT
  789         GET SYM
  790      %FINISH %ELSE %IF SYM = 'X' %START
  791         TYPE = 0;  VAL = 0
  792         %CYCLE
  793            SYM = CHAR(GETPOS)-128
  794            %EXIT %IF SYM < 0
  795            SYM = SYM-32 %IF SYM >= 96; !ENSURE UPPER-CASE
  796            %IF '0' <= SYM <= '9' %OR 'A' <= SYM <= 'F' %START
  797               VAL = VAL<<4+SYM-'0'
  798               VAL = VAL-7 %IF SYM >= 'A'
  799            %FINISH %ELSE FAULT('H')
  800            GETPOS = GETPOS+1
  801         %REPEAT
  802         GET SYM
  803      %FINISH %ELSE %IF SYM&128 # 0 %START
  804         TYPE = 0;  VAL = SYM-128
  805         GET SYM
  806         %IF MODE >= 0 %AND SYM&128 # 0 %START
  807            VAL = VAL<<8+SYM-128;  GET SYM
  808         %FINISH
  809      %FINISH %ELSE %IF S('.') %START
  810         ->ERR %IF %NOT TAG
  811         TYPE = 0;  VAL = TAG1
  812      %FINISH %ELSE %IF S('*') %START
  813         TYPE = LOCTYPE&63;  VAL = LOC
  814         %IF SYM = 'L' %START;          !FOR NOW
  815            TYPE = 0;  VAL = LIST %IF TAG
  816         %FINISH
  817      %FINISH %ELSE %IF SYM = '-' %START
  818         TYPE = 0;  VAL = 0
  819      %FINISH %ELSE %IF SYM = '\' %START
  820         TYPE = 0;  VAL = \0
  821      %FINISH %ELSE ->ERR
  822      QUEUE(TYPE);  QUEUE(VAL)
  823      %WHILE NP # NBASE %CYCLE
  824         %IF INTEGER(NP) < 0 %START
  825            QUEUE(INTEGER(NP))
  826         %FINISH %ELSE %START
  827            %EXIT %IF %NOT S(')')
  828         %FINISH
  829         NP = NP+1
  830      %REPEAT
  831      I = 1
  832      NEST(-1) %AND ->E8 %IF S('+')
  833      NEST(-2) %AND ->E8 %IF S('-')
  834      NEST(-3) %AND ->E9 %IF S('&')
  835      NEST(-4) %AND ->E9 %IF S('!')
  836      NEST(-5) %AND ->E9 %IF S('\')
  837      NEST(-6) %AND ->E9 %IF SS('<')
  838      NEST(-7) %AND ->E9 %IF SS('>')
  839      NEST(-8) %AND ->E9 %IF S('_')
  840      %RETURN %IF NP = NBASE
  841  ERR:NP = NBASE
  842      %SIGNAL %EVENT 1{9}
  843  E8: I = 0
  844  E9: ->E1 %UNLESS MODE = 2 %AND NP+1 = NBASE
  845      %IF FLAG = I %THEN FLAG = QLIM %ELSE FLAG = -1
  846      ->E1
  847  %END
  848  %ROUTINE CONDIT(%INTEGER QVAL)
  849  %OWNINTEGER AND=1717, OR=16873
  850  %INTEGER J,K
  851      TRANSF = QSTART;  QSTART = QLIM
  852      J = 0
  853      %CYCLE
  854         GET EXP
  855         %IF S('=') %START
  856            K = 3
  857         %FINISH %ELSE %IF S('#') %START
  858            K = \3
  859         %FINISH %ELSE %IF S('<') %START
  860            K = \1;  K = 2 %IF S('=')
  861         %FINISH %ELSE %IF S('>') %START
  862            K = \2;  K = 1 %IF S('=')
  863         %FINISH %ELSE %START
  864            QUEUE(-12)
  865            ->ANDOR
  866         %FINISH
  867         GET EXP
  868         QUEUE(-11);  QUEUE(K)
  869  ANDOR:
  870         %EXIT %IF %NOT TAG
  871         %IF TAG1 = AND %AND TAG2 = 0 %START
  872            %SIGNAL %EVENT 1{9} %IF J < 0
  873            J = 1;  QUEUE(-13)
  874         %FINISH %ELSE %START
  875            %SIGNAL %EVENT 1{9} %IF TAG1 # OR %OR J > 0
  876            J = -1;  QUEUE(-14)
  877         %FINISH
  878      %REPEAT
  879      QUEUE(QVAL) %IF QVAL # 0
  880      ASSEMBLE
  881      ATYPE=-1 %AND CREG=-1 %IF J < 0
  882  %END
  883  %ROUTINE GET INST
  884  %INTEGER I
  885  !OPMASK VALUES
  886  !    0100,0110,1100,1101,1110: DOUBLE WORD INSTRUCTIONS
  887  !    1011,1001,0011,0010,0001: AS ABOVE BUT RELOCATABLE
  888  !    0101: SINGLE WORD INSTRUCTION
  889  !    0111: 2 OPERANDS TO COME
  890  !    1111: 1 OPERAND TO COME
  891  !    1010: MACRO
  892      QUEUE(TYPE);  QUEUE(VAL)
  893      %RETURN %IF TYPE&16_7000 # 16_7000
  894      %RETURN %IF TERM # ' ';           !NO OPERAND FOLLOWING =>
  895      %CYCLE
  896         GET EXP
  897         QUEUE(-22)
  898         %RETURN %IF %NOT S(',')
  899      %REPEAT
  900  %END
?I unused
  901  %ROUTINE READ LINE
  902  %INTEGER Q
  903      PUTPOS = STARTPOS
  904      %IF MP = 0 %START
  905         Q = 0;  PSEUDOLIM = 0
  906         %CYCLE
  907            READ SYMBOL(SYM)
  908            READ SYMBOL(SYM) %AND Q=Q!!128 %IF SYM = ''''
  909            %EXIT %IF SYM = NL
  910            SYM = SYM-32 %IF SYM-Q >= 96; !LOWER-CASE -> UPPER-CASE
  911            SYM = SYM+Q
  912            %EXIT %IF SYM = '/' %AND PSEUDOLIM # 0
  913            %IF SYM = ' ' %START
  914               PSEUDOLIM = PUTPOS %IF PSEUDOLIM = 0
  915            %FINISH %ELSE PSEUDOLIM = 0
  916            PUT CHAR(SYM)
  917         %REPEAT
  918         %IF PSEUDOLIM # 0 %START
  919            Q = PUTPOS;  PUTPOS = PSEUDOLIM
  920            PUT CHAR(NL)
  921            PUTPOS = Q
  922         %FINISH
  923         %CYCLE
  924            PUT CHAR(SYM)
  925            %EXIT %IF SYM = NL
  926            READ SYMBOL(SYM)
  927         %REPEAT
  928         PRINTPOS = STARTPOS
  929      %FINISH %ELSE %START
  930         GETPOS = INTEGER(MP)
  931         %IF CHAR(GETPOS) = 0 %START
  932            QBASE = MP
  933            GETPOS = INTEGER(MP+2)
  934            STARTPOS = INTEGER(MP+3)
  935            MP = INTEGER(MP+4)
  936            %IF MP < 0 %START
  937               MP = MP-8_700000
  938               %WHILE INTEGER(NP)&16_8000 = 0 %CYCLE
  939                  FAULT('C');  NP = NP+2
  940               %REPEAT
  941               SET LAB(LOC)
  942            %FINISH
  943            PRINTPOS = 0 %IF LIST&2 # 0
  944            GET SYM;                    !TERMINATOR
  945            GET SYM %IF SYM = ';'
  946            %RETURN
  947         %FINISH
  948         PRINTPOS = STARTPOS %IF LIST&2 # 0
  949         QQ = 0
  950         %CYCLE
  951            SYM = CHAR(GETPOS);  GETPOS = GETPOS+1
  952            %IF TAG %START
  953               SYM=TERM %AND GETPOS=GETPOS-1 %IF TERM = ' '
  954               TYPE = INTEGER(MP);  VAL = GETPOS-1
  955               LOOKUP(4)
  956               %WHILE TYPE # VAL %CYCLE
  957                  PUT CHAR(CHAR(TYPE))
  958                  TYPE = TYPE+1
  959               %REPEAT
  960            %FINISH
  961            PUT CHAR(SYM)
  962            INTEGER(MP) = GETPOS
  963            %EXIT %IF SYM = NL
  964         %REPEAT
  965         QQ = '?'
  966      %FINISH
  967      QBASE = (PUTPOS+1)>>1
  968      GETPOS = STARTPOS;  GET SYM
  969  %END
  970  %ROUTINE SCAN ARG
  971  !    SET TYPE,VAL TO START,LIM OF ARG IF NOT NULL
  972  %INTEGER I,J
  973      %RETURN %IF SYM='I' %AND CHAR(GETPOS)='F' %AND CHAR(GETPOS+1)=' '
  974      I = GETPOS-1;  I = GETPOS %IF SYM = '['
  975      J = 0
  976      %CYCLE
  977         %EXIT %IF SYM = NL
  978         %EXIT %IF (SYM=' ' %OR SYM=',' %OR SYM=';') %AND J<=0
  979         J = J+1 %IF SYM = '['
  980         %IF SYM = ']' %START
  981            J = J-1;  %EXIT %IF J = 0
  982         %FINISH
  983         SYM = CHAR(GETPOS);  GETPOS = GETPOS+1
  984      %REPEAT
  985      %IF GETPOS-1 # I %START
  986         TYPE = I;  VAL = GETPOS-1
  987      %FINISH
  988      GET SYM %IF SYM = ']'
  989  %END
  990  %ROUTINE SET ACC
  991  %INTEGER I
  992      ACC = -1;  ATYPE = -1;  CREG = -1
  993      I = TEMPS
  994      %RETURN %IF I = 0
  995      %CYCLE
  996         ACC = ACC+1
  997         %RETURN %IF I&1 # 0
  998         I = I>>1
  999      %REPEAT
 1000  %END
 1001  !MAIN PROGRAM
 1002  !RADIX 36 CONSTANTS
 1003  %OWNINTEGER B=2184, IF=9991, ELS=5950, E=5403, FIN=6907, ISH=10490
 1004  %OWNINTEGER JUM=11642, P=17206, PS=17983, DEF=4605, END=6009
 1005  %INTEGER I,J,K
 1006      %ON %EVENT 9, 1{9} %START
 1007        %IF EVENT_EVENT {no}=1{9} %THEN ->ERR;                      !RECOGNITION ERROR
 1008        %IF EVENT_EVENT {no}=9 %THEN ->BEND;                      !INPUT ENDED
 1009      %FINISH
 1010      %CYCLE I = 1,1,SBOUND
 1011         STORE(I) = 0
 1012      %REPEAT
 1013      CODEPOS = 1{ADDR(STORE(1))}
 1014      MACLIM = (CODEPOS+20)<<1
 1015      STORELIM = sbound {ADDR(STORE(SBOUND))}
 1016      NP = STORELIM
 1017      LABLIM = NP-60
 1018      BP = LABLIM
 1019      DEFLIM = BP-(SBOUND>>2)
 1020      DEFMIN = DEFLIM
 1021      INTEGER(BP) = DEFLIM
 1022      
 1023  !%OWNINTEGER MAIN=1, PRE=2;            !INPUT
 1024  !%OWNINTEGER BIN=1, LIS=2;             !OUTPUT
 1025      open input(MAIN, "test.hal")
 1026      open input(PRE, "hal70.def")
 1027      open output(BIN, "test.bin")
 1028      open output(LIS, "test.lis")
 1029      select output(0)
 1030      
 1031      SELECT INPUT(PRE)
 1032  DO PASS:
 1033      STARTPOS = MACLIM
 1034      MP = 0
 1035      ALMAX = DEFLIM
 1036      LABMIN = LABLIM
 1037      ASSCOND = 1;  SKIP = 0
 1038      LOCTYPE = MEMMASK+RELMASK;  LOC = 0
 1039      SET ACC
 1040  READ: FSYM = ' ';  FAULTPOS = 0
 1041      READ LINE
 1042  NEXT:
 1043      DREG = -1
 1044      MODE = 0
 1045      PEND = 0;  COND = 0
 1046      QSTART = QBASE;  QLIM = QSTART
 1047      FLAG = 0
 1048      %IF S('$') %START
 1049         ->NEWPAGE %IF SYM = '/'
 1050         ->ERR %IF %NOT TAG
 1051         ->ASSIF %IF TAG1 = IF
 1052         ->ASSELSE %IF TAG1 = ELS
 1053         ->ASSFIN %IF TAG1 = FIN
 1054         ->LEND %IF SKIP # 0
 1055         ->DEFINE %IF TAG1 = DEF
 1056         ->DEFINE %IF TAG1 = 19625;     !RED
 1057         ->LISTC %IF TAG1 = 13350;      !LIS
 1058         ->TEMP %IF TAG1 = 21780;       !TEM
 1059         ->LOCC %IF TAG1 = 13556;       !LOC
 1060         ->LOCC %IF TAG1 = 1917;        !ASS
 1061         ->SAVC %IF TAG1 = 20568;       !SAV
 1062         ->MACDEF %IF TAG1 = 14111;     !MAC
 1063         ->BEGIN %IF TAG1 = 2460;       !BEG
 1064         ->BEND %IF TAG1 = END
 1065         FAULT('U')
 1066         ->LEND
 1067      %FINISH
 1068      ->LEND %IF SKIP # 0 %OR SYM = '/'
 1069      ->LEND %IF SYM = NL
 1070      %IF TAG %START
 1071         ->LABDEF %IF TERM = ':'
 1072         MODE = 1
 1073         ->ASSIGN %IF TERM = '(' %OR SYM = '='
 1074         ->JUMP %IF TAG1 = JUM %AND (TAG2=P %OR TAG2=PS)
 1075         ->IFC %IF TAG1 = IF
 1076         ->ELSE %IF TAG1 = ELS %AND TAG2 = E
 1077         ->FINISH %IF TAG1 = FIN %AND TAG2 = ISH
 1078         ->WHILE %IF TAG1 = 25106 %AND TAG2 = 13173
 1079         ->CYCLE %IF TAG1 = 4269 %AND TAG2 = 13173
 1080         ->REPEAT %IF TAG1 = 19637 %AND TAG2 = 5544
 1081         MODE=-2 %AND ->DATA %IF TAG1 = B
 1082         TYPE = UMASK;  LOOKUP(0)
 1083         ->MACCALL %IF TYPE&OPMASK = MACRO
 1084         ->MINST %IF TYPE&OPMASK # 0
 1085         FAULT('U') %AND ->LEND %IF TYPE&UMASK # 0
 1086         PEND = -1
 1087      %FINISH
 1088      MODE = -1
 1089  DATA:
 1090      %CYCLE
 1091         GET EXP;  ASSEMBLE
 1092         FAULT('I') %IF TYPE&REGXMASK # 0
 1093         I = 1
 1094         %IF S('$') %START
 1095            I = VAL %IF VAL < 1000
 1096            QLIM = QSTART
 1097            GET EXP;  ASSEMBLE
 1098         %FINISH
 1099         %WHILE I > 0 %CYCLE
 1100            %IF MODE # -1 %START
 1101               FAULT('T') %IF VAL&16_FF00 # 0
 1102               %IF MODE = -2 %START
 1103                  J = VAL<<8;  MODE = -3
 1104               %FINISH %ELSE %START
 1105                  VAL = VAL+J;  MODE = -2
 1106                  PLANT VAL;  VAL = VAL&255
 1107               %FINISH
 1108            %FINISH %ELSE %START
 1109               PLANT VAL
 1110            %FINISH
 1111            I = I-1
 1112         %REPEAT
 1113         %EXIT %UNLESS S(',') %OR SYM&128 # 0
 1114         %IF SYM = NL %START
 1115            PRINT LINE %IF PRINTPOS # 0;  READ LINE
 1116            QSTART = QBASE
 1117         %FINISH
 1118         QLIM = QSTART
 1119      %REPEAT
 1120      VAL=J %AND PLANT VAL %IF MODE = -3
 1121      ->SEND
 1122  LABDEF:
 1123      CREG = -1;  ATYPE = -1
 1124      GET SYM
 1125      FAULT('C') %AND NP=STORELIM %IF NP # STORELIM
 1126      TYPE = LOCTYPE;  VAL = LOC
 1127      LOOKUP(7)
 1128      ->NEXT
 1129  ASSIGN:
 1130      PEND = 1
 1131      GET EXP
 1132      ->ERR %IF %NOT S('=')
 1133      QUEUE(-25);                       !'STORE'
 1134      %IF INTEGER(QBASE) = REG %START
 1135         DREG = INTEGER(QBASE+1)
 1136         DUSE = 0
 1137      %FINISH
 1138      QSTART = QLIM;  MODE = 2
 1139      GET EXP
 1140      %IF FLAG # 0 %START
 1141         %IF DREG<0 %AND FLAG-QSTART=QSTART-QBASE-1 %C
 1142+           %AND INTEGER(QBASE)&BMASK=0 %START
 1143         I = QBASE;  J = QSTART
 1144         I = I+1 %AND J=J+1 %WHILE INTEGER(I) = INTEGER(J)
 1145         %IF J = FLAG %START
 1146            %IF INTEGER(QLIM-1) = -2 %START; !MINUS
 1147               QSTART = J-2
 1148               INTEGER(QSTART) = 0;  INTEGER(QSTART+1) = 0
 1149            %FINISH %ELSE %START
 1150               QSTART = J;  QLIM = QLIM-1
 1151            %FINISH
 1152         %FINISH %ELSE FLAG = 0
 1153         %FINISH %ELSE FLAG = 0
 1154      %FINISH
 1155      QUEUE(-24);                       !'LOAD'
 1156  CONDQ:
 1157      %IF TAGIF %START
 1158         MODE = MODE+4;  DREG = DREG-16; !SCARIFY
 1159         CONDIT(0)
 1160         MODE = MODE-4;  DREG = DREG+16; !RESTORE
 1161         QLIM = QSTART;  QSTART = TRANSF
 1162      %FINISH
 1163      ASSEMBLE
 1164      ->SEND
 1165  JUMP:
 1166      FLAG = TAG2-P;                    !POSITIVE IF SHORT
 1167      GET EXP
 1168      QUEUE(-26);                       !'JUMP'
 1169      ->CONDQ
 1170  MINST:
 1171      MODE = -1
 1172      GET INST
 1173      QUEUE(-23);                       !'PLANT'
 1174      ->CONDQ
 1175  MACCALL:
 1176      QUEUE(0);                         !(DEFPOS)
 1177      QUEUE(0);                         !SPARE
 1178      QUEUE(0);                         !(CALLPOS)
 1179      QUEUE(STARTPOS)
 1180      QUEUE(MP)
 1181      J = VAL;  QQ = 0
 1182      %CYCLE
 1183         %EXIT %IF CHAR(J) = NL;        !END OF MAC DEF
 1184         I = GETPOS-1;                  !SAVE CALLPOS
 1185         GETPOS = J;  GET SYM
 1186         %SIGNAL %EVENT 14,24 %IF %NOT TAG
 1187         TYPE = 0;  VAL = 0
 1188         SCAN ARG
 1189         GET SYM %IF SYM = ','
 1190         J = GETPOS-1;                  !SAVE DEFPOS
 1191         GETPOS = I;  GET SYM;          !RESTORE CALLPOS
 1192         SCAN ARG
 1193         GET SYM %IF SYM = ','
 1194         QUEUE(TAG1);  QUEUE(TAG2)
 1195         QUEUE(TYPE);  QUEUE(VAL)
 1196      %REPEAT
 1197      QQ = '?'
 1198      GET SYM %IF SYM = ' '
 1199      %IF TAGIF %START
 1200         CONDIT(-18)
 1201         QLIM = QSTART
 1202         INTEGER(QBASE+4) = MP+8_700000
 1203      %FINISH
 1204      QUEUE(0)
 1205      STARTPOS = QLIM<<1
 1206      MP = QBASE
 1207      INTEGER(MP) = J+1;                !START OF BODY
 1208      INTEGER(MP+2) = GETPOS-1
 1209      ->LEND
 1210  !CODING OF JUMPS: 1000 (SINGLE INST), 2000 (MAIN IF)
 1211  !                 4000 (ELSE), 6000 (IF AFTER ELSE)
 1212  IFC:
 1213      CONDIT(-15)
 1214      ->SEND
 1215  ELSE:
 1216      ->CERR %IF INTEGER(NP)&16_2000 = 0
 1217      QUEUE(0);  QUEUE(0)
 1218      QUEUE(-16);  ASSEMBLE
 1219      ATYPE = -1; CREG = -1
 1220      %IF TAGIF %START
 1221         CONDIT(-17)
 1222      %FINISH
 1223      ->SEND
 1224  FINISH:
 1225      ->CERR %IF INTEGER(NP)&16_6000 = 0
 1226      I = LOC
 1227      %WHILE INTEGER(NP)&16_4000 # 0 %CYCLE
 1228         %IF INTEGER(NP)&16_2000 # 0 %START; !IF AFTER ELSE
 1229            SET LAB(I)
 1230         %FINISH %ELSE %START
 1231            SET LAB(LOC)
 1232            I = VAL+4
 1233         %FINISH
 1234      %REPEAT
 1235      SET LAB(I)
 1236      ->SEND
 1237  WHILE:
 1238      I = LOC;  ATYPE = -1;  CREG = -1
 1239      CONDIT(-13)
 1240      NEST(I);  NEST(1)
 1241      ->SEND
 1242  CYCLE:
 1243      NEST(LOC);  NEST(1)
 1244      ATYPE = -1;  CREG = -1
 1245      ->SEND
 1246  REPEAT:
 1247      ->CERR %IF INTEGER(NP) # 1
 1248      QUEUE(LOCTYPE);  QUEUE(INTEGER(NP+1))
 1249      NP = NP+2
 1250      QUEUE(-26);                       !'JUMP'
 1251      FLAG = -1
 1252      ->CONDQ
 1253  CERR:
 1254      FAULT('C')
 1255      ->LEND
 1256  SEND:
 1257      SET LAB(LOC) %IF INTEGER(NP)&16_1000 # 0
 1258      ->LEND %IF SYM = NL
 1259      ->NEXT %IF S(';')
 1260  ERR:FSYM = 'F';  FAULTPOS = GETPOS-1
 1261      PRINTPOS = STARTPOS
 1262  LEND:
 1263      ->READ %IF SKIP # 0 %AND LIST&4 = 0
 1264      ->READ %IF FSYM = ' ' %AND CHARS = 0 %AND %C
 1265+      (PRINTPOS = 0 %OR (MP#0 %AND LIST&2=0))
 1266      PRINT LINE
 1267      ->READ
 1268  ASSIF:
 1269      ASSCOND = ASSCOND<<1
 1270      ->LEND %IF SKIP # 0
 1271  A1: CONDIT(0)
 1272      SKIP = ASSCOND %IF COND # 0
 1273      PRINT LINE %IF PRINTPOS # 0
 1274      ->LEND
 1275  ASSELSE:
 1276      %IF SKIP = 0 %START
 1277         ->CERR %IF ASSCOND&1 # 0
 1278         SKIP = ASSCOND
 1279      %FINISH %ELSE %START
 1280         ->LEND %IF SKIP # ASSCOND
 1281         SKIP = 0
 1282         ->A1 %IF TAGIF
 1283      %FINISH
 1284      ASSCOND = ASSCOND+1
 1285      ->LEND
 1286  ASSFIN:
 1287      ->CERR %IF ASSCOND = 1
 1288      ASSCOND = ASSCOND>>1
 1289      SKIP = 0 %IF SKIP>>1 = ASSCOND
 1290      ->LEND
 1291  DEFINE:
 1292      FAULT('C') %IF NP # STORELIM
 1293      I = TAG1
 1294      %CYCLE
 1295         ->ERR %IF %NOT (TAG %AND S('='))
 1296         J = TAG1;  K = TAG2
 1297         %IF TAG %START
 1298            TAGREF
 1299            %IF TYPE&OPMASK # 0 %START
 1300               GET INST
 1301            %FINISH %ELSE %START
 1302               PEND = -1;  GET EXP
 1303            %FINISH
 1304         %FINISH %ELSE GET EXP
 1305         ASSEMBLE
 1306         TAG1 = J;  TAG2 = K
 1307         %IF I=DEF %THEN LOOKUP(3) %ELSE LOOKUP(2)
 1308         %EXIT %UNLESS S(',')
 1309         QLIM = QSTART
 1310      %REPEAT
 1311      ->SEND
 1312  NEWPAGE:
 1313      DO NEWLINE %WHILE LINES # 0
 1314      ->LEND
 1315  LISTC:
 1316      GET EXP;  ASSEMBLE
 1317      LIST = VAL
 1318      ->SEND
 1319  TEMP:
 1320      I = 0
 1321      %IF SYM # NL %START
 1322         %CYCLE
 1323            GET EXP
 1324            FAULT('I') %IF TYPE # REG
 1325            I = I!1<<VAL
 1326            %EXIT %UNLESS S(',')
 1327         %REPEAT
 1328      %FINISH
 1329      TEMPS = I
 1330      SET ACC
 1331      ->SEND
 1332  LOCC:
 1333      I = TAG1
 1334      GET EXP;  ASSEMBLE
 1335      %IF TYPE&16_FF80 = 0 %START
 1336         %IF I = 13556 %START;          !LOC
 1337            OUTPUT RECORD %IF BINCOUNT >= 203
 1338            PUT(3) %IF (LOCTYPE!!TYPE)&RELMASK # 0
 1339            PUT(5);  PUT WORD(VAL)
 1340         %FINISH
 1341         LOCTYPE = TYPE&63+MEMMASK;  LOC = VAL
 1342      %FINISH %ELSE FAULT('I')
 1343      ->SEND
 1344  SAVC:
 1345      GET EXP;  ASSEMBLE
 1346      SAVE = VAL
 1347      ->SEND
 1348  MACDEF:
 1349      ->CERR %IF MP # 0
 1350      ->ERR %IF %NOT TAG
 1351      J = TAG1;  K = TAG2
 1352      I = GETPOS-1
 1353      %IF SYM # NL %START
 1354         %CYCLE
 1355            ->ERR %IF %NOT TAG
 1356            SCAN ARG
 1357            %EXIT %IF %NOT S(',')
 1358         %REPEAT
 1359      %FINISH
 1360      ->ERR %IF SYM # NL
 1361      TAG1 = J;  TAG2 = K
 1362      TYPE = MACRO;  VAL = I
 1363      LOOKUP(3)
 1364      %CYCLE
 1365         PRINT LINE
 1366         %EXIT %IF S('$') %AND TAG %AND TAG1 = END
 1367         STARTPOS = PUTPOS
 1368         STARTPOS = PSEUDOLIM+1 %IF PSEUDOLIM # 0
 1369         READ LINE
 1370      %REPEAT
 1371      PUTPOS = STARTPOS;  PUT CHAR(0)
 1372      STARTPOS = PUTPOS
 1373      MACLIM = STARTPOS
 1374      ->LEND
 1375  %ROUTINE BNEST
 1376      BP = BP+4;  %SIGNAL %EVENT 14,23 %IF BP-NP >= 0
 1377      INTEGER(BP-3) = SAVE;  INTEGER(BP-2) = TEMPS
 1378      INTEGER(BP-1) = MACLIM;  INTEGER(BP) = DEFMIN
 1379  %END
 1380  BEGIN:
 1381      BNEST
 1382      ->NEWPAGE %IF SYM # NL
 1383      ->LEND
 1384  BEND:
 1385      FAULT('C') %IF NP # STORELIM %OR MP # 0
 1386      MP = 0;  NP = STORELIM
 1387      %IF BP # LABLIM %START
 1388         SAVE = INTEGER(BP-3);  TEMPS = INTEGER(BP-2)
 1389         MACLIM = INTEGER(BP-1);  STARTPOS = MACLIM
 1390         DEFMIN = INTEGER(BP)
 1391         SET ACC
 1392         BP = BP-4
 1393         ->LEND %IF BP # LABLIM
 1394      %FINISH
 1395      CLOSE INPUT;  SELECT INPUT(MAIN)
 1396      BNEST
 1397      LIST = 5
 1398      PASS = PASS+1
 1399      ->DO PASS %IF PASS # 2
 1400      OUTPUT RECORD %IF BINCOUNT = 208
 1401      PUT(1)
 1402      OUTPUT RECORD
 1403      FAULT('$')
 1404      PRINT LOC;  PRINT LINE
 1405  %ENDOFPROGRAM

 1505 Statements compiled
