TWOSEG;
#FILE AMOD -- ASSEMBLY MODULE FOR NEW IMP.
  THE ASSEMBLER MAKES THREE PASSES THRU THE CODE:
    PASS 1: COUNT REGISTER REFERENCES
    PASS 2: ALLOCATE REGISTERS, INSERT REGISTER SAVES & RESTORES, DEFINE TAGS,
            COUNT INSTRUCTIONS, SUPPRESS REGISTER LOADS (WHEN PERMITTED),
            AND MARK REFERENCES TO VARIABLES OR LONG CONSTANTS BY SETTING
            THE DIR PROPERTY "ATYPE" TO 6.
    PASS 3: PUT OUT THE OBJECT CODE
  BETWEEN THE SECOND AND THIRD PASSES, STORAGE IS ALLOCATED FOR VARIABLES.

  /A   PROVIDES AN ASSEMBLY LISTING.
  /B   TURNS ON DEBUGGING PRINTOUT AND LISTING.

  THE FORMATTING OF THE OBJECT PROGRAM IS DONE IN FILE "OMOD" (OUTPUT MODULE).

  *** IMPORTANT ASSUMPTION: THE ASSEMBLER MUST BE CALLED ONLY ONCE! ***     #


CO,NCO,FINAM,CONST,RG,ARR,NARR ARE COMMON;
SUBR ASSEMB(E,F,REGN,IMPM,RELNM) IS (

 AST_CALLI(27B,0); IASSEM(RELNM); INIREG();
 SUPPR_1; LCONS_FALLOT('LCONS',25); NLCONS_0;
 FINAM[5]_FINAM[5] AND NOT 4;  #TURN OFF CONTINUE OPTION#
 LIST_FINAM[5] AND 3; LIST => ALIST(8,RELNM);
 (DBG_FINAM[5] AND 2) => (S_ENSTACK(0);
                          E => (PRINT /,STG 0,'HIGH SEGMENT --',/;
                                FREES(S+2,E LS 18); PCODE(S,9999));
                          F => (PRINT /,STG 0,'LOW SEGMENT --',/;
                                FREES(S+2,F LS 18); PCODE(S,9999)));
 IW_E; SEG_1; UNREFL_0;
PASS1: IW=0=>GO TO P1X; W_NXCW(IW); IW => (
    UNPKCW(W);
    CODE NE 1 => (W_NXCW2(IW);
                  CODE=0 => (ACI=>REGREF(ACI);
                             IXI=>UNREFL=0=>REGREF(IXI);
			       UNREFL_0;
                             VIF=>REGREF(W AND 777777B)))
           ELSE  (CODE_(W RS 27) AND 177B; VI_W AND 777777B;
		  CODE=0=>DPROP('COM',VI)=1=>DPROPS('COM',VI,2);
                  CODE=5 => REGREF(VI);
                  CODE=6 => (REGREF(VI); REGREF(VI)); #EXTRA REFERENCE
                            TO RESERVE REGISTER FOR DURATION OF PROGRAM#
                  CODE=7 => OPTREG(IW);
                  CODE=8 => REGREF(VI);
                  CODE=9 => REGREF(VI);
                  CODE=10 => REGREF(VI);
                  CODE=11=>UNREFL_1);
    GO TO PASS1);
   P1X: SEG=>(IW_F; SEG_0; GO TO PASS1);

 DBG => (PRINT /,STG 0,'REGISTER ARRAY --',/;
         N_(REGN+2)/4;
         (K_I; DBR: R_RGG(K); PRINT STG 0;
          R AND 10000B => PRINT 'U'; R AND 4000B => PRINT 'Z';
          R AND 40B => PRINT 'D'; (R AND 14040B)=0 => PRINT ' ';
          PRINT ' R',OCT 3,K,STG 0,' ',OCT 2,37B AND R RS 6,37B AND R,
                IGR 3,7777B AND R RS 18,STG 0,'    ';
          K_K+N; K<REGN => GO TO DBR;
          PRINT /) FOR I IN 1,1,N;
         PRINT /);

 IW_0;
ASCOM: IW<NARR => (
             VI_FREE(ARR+IW) AND 777777B;
             DPROP('COM',VI)=1 => DPROPS('COM',VI,2);
             IW_IW+1; GO TO ASCOM);

 IW_E; SEG_1; ADR_400000B; SNO_0;

PASS2: IW=0=>GO TO P2X; OIW_IW; W_NXCW(IW); IW => (
 UNPKCW(W);
 CODE=1 => (
    VI_W AND 777777B; OPC_(W RS 27) AND 177B;
    OPC>11 => GO TO PASS2;
    GO TO (SF0,SF1,SF2,SF3,SF4,SF5,SF5,PASS2,SF8,SF9,SF10,PASS2) OPC;

#TAG#
    SF0: DPROP('ATYPE',VI)=7 => (ERROR(1,'DUPLICATE TAG'); ERTYP(VI);
                                 ALIST(0,VI); GO TO PASS2);
         DPROPS('SEM',VI,ADR); DPROPS('ATYPE',VI,7); REGCLR(0);
         PUTS(VI,ADR)=2=>SNO_SNO+1; LIST=>ALIST(0,VI); GO TO PASS2;

#SAVE REGISTERS#
    SF1: IW_SVREG(SNO,OIW,IW,VI); GO TO PASS2;

#RESTORE REGISTERS; VI NE 0 MEANS FORCE A REFERENCE TO THE REGISTER
 WHICH IS INDEXED BY VI (THIS ALLOCATES THE REGISTER WHICH CONTAINS
 THE RETURNED VALUE OF A FUNCTION). #
    SF2: IW_RSREG(OIW,IW);
         VI => (REGREF(VI); REGSET(VI,0,0,0,0,0));
         GO TO PASS2;

#ENTER DELETE NO INSTRUCTIONS MODE#
    SF3: SUPPR_0; GO TO PASS2;

#LEAVE DELETE NO INSTRUCTIONS MODE#
    SF4: SUPPR_1; GO TO PASS2;

#RESERVE A REGISTER-- COUNT THIS AS A REFERENCE TO IT#
    SF5: REGSET(VI,0,0,0,0,0); GO TO PASS2;

#RELEASE A PARTICULAR REGISTER#
    SF8: REGSET(VI,0,0,0,0,0); RELREG(VI); GO TO PASS2;

#DECLARE REGISTER SCRATCH - WON'T BE SAVED & RESTORED#
    SF9: REGSET(VI,0,0,0,0,0); RSCR(VI); GO TO PASS2;

#PROTECT REGISTER - SAVE & RESTORE#
    SF10: REGSET(VI,0,0,0,0,0); RPRT(VI); GO TO PASS2); #END OF SPECIAL FUNCTIONS#

 SW_W; W_NXCW2(IW);
 CODE=0 =>
      (OPC_(SW RS 24) AND 777B;
       (OPC RS 3)=33B => (IXI=0=>(OPTSKP(IW,OPC,VIF,W,ADR)=>GO TO PASS2));
       REGSET(ACI,IXI,W,VIF,OPC,1 AND SW RS 33) => SUPPR =>
                        (FREES(CO+OIW,400000000000B+IW); GO TO PASS2);
# IN DELETE NO INSTRUCTIONS MODE, PRESUMABLY INSTRUCTION MAY
	BE SKIPPED (THAT'S WHY THE MODE EXISTS).  THUS, ZAP
	CONTENTS OF REGISTER AND/OR MEMORY AFFECTED. #
	SUPPR=0=>(	J_OCHK(OPC);
			(J AND 1)=>ACI=>REGZAP(37B AND RGG(R) RS 13,0);
			(J AND 2)=>REGZAP(-1,W));
       VIF=0 => ((I_W<R>) => MKVAR(I,ADR,OPC)))
    ELSE
       (I_SW AND 777777B) => MKVAR(I,ADR,202B);
 ADR_ADR+1; GO TO PASS2);
P2X: SEG=>(IW_F; SEG_0; HADR_ADR; ADR_0; GO TO PASS2);
 LADR_ADR;

 IW_0; LIST => ALIST(6,0);
ASVEC: IW<NARR => (
            W_FREE(ARR+IW); VI_W AND 777777B;
            DPROP('ATYPE',VI)=7 => (
                 ERROR(2,'VECTOR APPEARS IN MORE THAN ONE DECLARATION');
                 ERTYP(VI); ALIST(0,VI); GO TO NXVEC);
            DPROPS('SEM',VI,ADR); DPROPS('ATYPE',VI,7); PUTS(VI,ADR);
            LIST => ALIST(0,VI);
            ADR_ADR+(W RS 18);
            NXVEC: IW_IW+1; GO TO ASVEC);

 IW_-1; VEND_ADR; LIST => ALIST(6,0);
ASSCA: (IW_DSEQ(IW)) GE 0 => (
             DPROP('ATYPE',IW)=6 =>
                   (I_CONVC(IW);
                   I=0=>(LIST => ALIST(0,IW);
                         DPROPS('SEM',IW,ADR); PUTS(IW,ADR);
                         DPROP('ENTRY',IW) NE 7 => (
                             ERROR(2,'QUESTIONABLY DEFINED VARIABLE');
                             ERTYP(IW); PNAME(IW); ALIST(6,0));
                         ADR_ADR+1; GO TO ASSCA);
                   I NE 0=>(DPROPS('SEM',IW,NLCONS);
                          I=-1 => FADD(LCONS,NLCONS,CONST);
                          I>0 => (VI_FREE(I); IX_0;
                                  SVCNS: (IX_IX+1) LE VI => (
                                                FADD(LCONS,NLCONS,FREE(I+IX));
                                                GO TO SVCNS))));
              GO TO ASSCA);

 SEND_ADR;
 STCONS_(E=>HADR ELSE ADR); LIST => ALIST(7,NLCONS);
 E=>HISEG(HADR);
 IMPM=>(E=>STADR(400000B) ELSE STADR(0));

 IW_E; SEG_1; STCODE(400000B);
PASS3: IW=0=>GO TO P3X; W_NXCW(IW); IW => (
  UNPKCW(W); CODE=1=>(LIST=>(((W RS 27) AND 177B)=0=>ALIST(4,W AND 777777B));
                      GO TO PASS3);
  I_NXCW2(IW);
  CODE=3 =>
     (C_I; (VI_W AND 777777B) => C_C+GETADR(VI,IXI)   ELSE   IXI_0)
    ELSE
     (J_((W LS 3) AND 777000000000B) OR ((W RS 11) AND 20000000B);
      IXI=>J_J OR (GETREG(IXI) LS 18);
      ACI=>J_J OR (GETREG(ACI) LS 23);
      VI_I AND 777777B;
      VIF => (C_J OR GETREG(VI); VI_IXI_0)
        ELSE (I_I RS 18;
              VI => C_J OR (GETADR(VI,IXI)+I) AND 777777B
               ELSE (C_J OR I; IXI_0)));
  ADR_PUT(C,IXI); LIST => ALIST(3,VI); GO TO PASS3);

 P3X: SEG=>(NLCONS=>(IW_NLCONS-1; STCODE(STCONS);
                 PUT(FREE(LCONS+I),0) FOR I TO IW);
        IW_F; SEG_0; STCODE(0); GO TO PASS3);
  BRK1_STCONS+NLCONS; BRK2_(E=>SEND ELSE 0);
  EASSEM(BRK1,BRK2); LIST => ALIST(9,0);
AST_CALLI(27B,0)-AST; ASTATS(0));


SUBR MKVAR(VI,A,OPC) IS (
 DPROP('ATYPE',VI) NE 7 => (
          DPROP('COM',VI) NE 1 => (DPROPS('ATYPE',VI,6);
                                   OPC=320B=>M_2 ELSE M_OCHK(OPC);
                                   M AND 2=>DPROPS('ENTRY',VI,7))
                             ELSE  (PUTS(VI,A); DPROPS('SEM',VI,0)));
 0);


SUBR GETADR(IW,IXI) IS (
 RTV_DPROP('SEM',IW); IXI_1;
 CONVC(IW) => RTV_RTV+STCONS
         ELSE (DPROP('COM',IW)=1=>IXI_0);
 RTV);


SUBR NXCW(I) IS (
 GWC: J_FREE(CO+I);
      (J RS 34)=2=>((I_J AND 777777B)=>GO TO GWC; GO TO EXITN);
      I_I+1;
 EXITN: J);


SUBR NXCW2(I) IS (
 J_FREE(CO+I);
 I_I+1; J);


SUBR UNPKCW(W) IS (
 (CODE_W RS 34)=0 => (
    ACI_(W RS 12) AND 3777B;
    IXI_W AND 3777B;
    VIF_(W RS 11) AND 1);
 0);


#FCN WHICH OPTIMIZES EXPLICIT REGISTER USEAGE:
     MOVE   TREG,UREG
     INST   TREG,ANYTHING
     MOVE   UREG,TREG
 BECOMES
     INST   UREG,ANYTHING  #

SUBR OPTREG(IW) IS (
 ADF_IW; AC_3777B AND (NXCW(ADF) RS 12); VI_3777B AND NXCW2(ADF);
 OP_NXCW(ADF); ADR_NXCW2(ADF); C_NXCW(ADF);
 VI=3777B AND C RS 12 => C AND 4000B => 200B=777B AND C RS 24 =>
        (C_NXCW2(ADF); AC=3777B AND C =>
               (FREES(CO+IW,(OP AND 777740007777B) OR (VI LS 12));
                FREES(CO+IW+1,ADR); NXCW(IW); NXCW2(IW);
                FREES(CO+IW,400000000000B+ADF);
                REGREF(VI)));
 0);



#FCN WHICH RECOGNIZES THE SEQUENCE:
  SKIPX  MEM     WHEN MEM HAPPENS TO ALREADY BE IN A REGISTER
  JRST   L
 THIS BECOMES:
  JUMPNX  R,L    (WHERE REG R CONTAINS MEM)  #

SUBR OPTSKP(IW,OPC,VIF,W,ADR) IS (
 RTV_0; VIF=>VI_ W AND 777777B ELSE ((VI_REGCON(W))=0=>GO TO EXITSK);
 ADF_IW; (C_NXCW(ADF)) RS 34 => (
                C NE 203000000000B=>GO TO EXITSK; #IGNORE SCL FCN 3#
                (C_NXCW(ADF)) RS 34=>GO TO EXITSK);
 (I_777B AND C RS 24) NE 254B => (I NE 324B=>GO TO EXITSK);
 C AND 100000007777B => GO TO EXITSK;
 J_7 AND 4+(OPC AND 7); I_((320B OR J) LS 24) OR (VI LS 12);
 C_NXCW2(ADF); (J_C AND 777777B) => MKVAR(J,ADR,0);
 FREES(CO+IW-2,I); FREES(CO+IW-1,C); FREES(CO+IW,400000000000B+ADF);
 ADR_ADR+1; IW_ADF; RTV_1;
 EXITSK: RTV);


SUBR ERTYP(VI)  IS  (ADF_GNAME(VI); MSG([ADF]));


SUBR ALIST(L,V) IS (
 GO TO ATG[L];
ATG: GO TO AL0; GO TO AL1; GO TO AL1; GO TO AL3; GO TO AL4;
     GO TO AL5; GO TO AL6; GO TO AL7; GO TO AL8; GO TO AL9;

AL0: PRINT STG 3,' ', OCT 6,ADR, STG 3,' ';
     PNAME(V); GO TO AL6;
AL1: PRINT OCT 4,IW-L, STG 4,' ', OCT 1,CODE, STG 1,' ',
           OCT 3,OPC, STG 1,' ';
     L=1 => PRINT OCT 6,V,/
       ELSE PRINT OCT 4,ACI, IGR 2,VIF, STG 1,' ', OCT 4,IXI, OCT 15,V,/;
     GO TO EXITA;
AL3: ADF_C AND 777777B; OP_C RS 27;
     PRINT STG 3,' ', OCT 6,ADR-1,
           STG 3,' ', OCT 6,C RS 18, STG 1,' ', OCT 6,ADF, STG 5,' ';
     OPCODE(OP,O,M) => M_PRINT STG 0,O,M
                  ELSE M_PRINT OCT 3,OP;
     AC_(C RS 23) AND 17B; IX_(C RS 18) AND 17B; I_I AND 777777B;
     PRINT STG 38-M,' '; AC=>PRINT OCT 0,AC, STG 0,',';
     C AND 20000000B => PRINT STG 0,'@';
     V=>PNAME(V)  ELSE  (PRINT OCT 0,ADF; I_0);
     I => (I AND 400000B=>PRINT STG 0,'-', OCT 0, -(I OR 777777000000B)
                     ELSE PRINT STG 0,'+', OCT 0,I);
     IX => PRINT STG 0,'(', OCT 0,IX, STG 0,')';
     GO TO AL6;
AL4: PRINT STG 25,' '; PNAME(V); PRINT STG 0,':',/; GO TO EXITA;
AL5: PRINT OCT 4,IW-2, OCT 16,SW, OCT 20,V,/; GO TO EXITA;
AL9: PRINT STG 33,'END',/; GO TO EXITA;
AL7: V => (PRINT /; ADF_V-1;
              (PRINT STG 3,' ', OCT 6, STCONS+I,
               OCT 15,FREE(LCONS+I),/) FOR I TO ADF);
     GO TO AL6;
AL8: PRINT /, STG 0,'** CODE PRODUCED BY PROGRAM '; PNAME(V); PRINT /;
AL6: PRINT /;
EXITA: 0);

SUBR ASTIME(NIL) IS (AST);

SUBR ASTATS(NIL) IS (
 HLEN_HADR-400000B;
 PRINT /,STG 0, 'ASSEMBLY TIME = ', IGR 0,AST, STG 0, '   MSEC.',/,
       ' ', IGR 0,HLEN+LADR, STG 0,' WORDS OBJECT CODE',/;
 HLEN=>PRINT ' ',IGR 0,HLEN+NLCONS,STG 0,' WORDS HIGH SEGMENT,   ',
                 IGR 0,SEND,STG 0,' WORDS LOW SEGMENT',/;
 PRINT ' ', IGR 0,VEND-LADR, STG 0,' WORDS VECTOR STORAGE,   ',
            IGR 0,SEND-VEND, STG 0,' WORDS SCALAR STORAGE,   ',
            IGR 0,NLCONS, STG 0,' CONSTANTS',/,/;
 0) %%%