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

 1517 Statements compiled
