TWOSEG;
# THIS IS FILE IMPSEM, WHICH CONTAINS THE OBJECT MACHINE-INDEPENDANT SEMANTIC
  ROUTINES FOR THE IMP COMPILER.  THEY ARE:
IMPSEM() - INITIALIZING ROUTINE.
ASSEMC(A) - ADDS PARAMETERS AND CALLS ASSEMB WITH TWO SEGMENTS OF CODE.
NAME(N) - N IS A STACK POINTER TO A RAW NAME.  RESULT IS THE VALUE OF
  THE IDENTIFIER, WHICH MAY BE A VARIABLE, CONSTANT, OR REGISTER.  IF IT
  IS SPECIAL (LIKE A FORMAL ARGUMENT OF SUBPROGRAM) IT GETS DIDDLED HERE.
AREG1(I,J) - I,J INTEGERS.  RESERVES A FRESH REGISTER BETWEEN REGISTER I
  AND REGISTER J INCLUSIVE AND RETURNS THE REGISTER INDEX.  SPECIAL CASES:
  IF J HAS THE 40B BIT SET, TWO SUCCESSIVE REGISTERS BOTH WITHIN THE BOUNDS
  I-J ARE RESERVED.  THE INDEX OF THE FIRST IS RETURNED, AND THE SECOND MAY
  BE REFERRED TO BY REG2(R), WHERE R IS THE INDEX OF THE FIRST.  IF I HAS
  THE 40B BIT SET, THEN THIS REGISTER IS THE RETURNED VALUE OF A SUBROUTINE.
  IF I HAS THE 100B BIT SET THEN THIS IS A USER-ASSIGNED REGISTER.
AREG(I) - GETS INDEX FOR HARDWARE REGISTER I.  THIS INDEX IS NOT NEW - IT
  WILL BE RETURNED FOR ALL AREG CALLS WITH THAT VALUE OF I.  IF I HAS THE
  40B BIT SET THEN THIS IS A USER-DEFINED REGISTER AND NOT TO BE CLOBBERED
  UNLESS THE USER SPECIFICALY WRITES CODE TO DO SO.
REG2(R) - RETURNS THE INDEX FOR THE REGISTER AC+1 WHERE AC IS
  THE REGISTER CORRESPONDING TO REGISTER INDEX R.  R MUST HAVE
  BEEN DEFINED BY AREG1(I,J OR 40B).
REG2S(S) - CHANGES THE REGISTER ASSOCIATED WITH OBJECT S, WHICH
  MUST BE OF TYPE 2, TO BE REG2(REGOF(S)).
SAMEREG(J) - RETURNS A NEW REGISTER HAVING THE SAME LIMITS AS REGISTER J.
DECL(I,S) - SAVES UP PROPERTIES IN A DECLARATION LIST.
DECLARE() - APPLIES DECLARED PROPERTIES TO NAMES IN CURRENT LIST.
SUBBEG(A) - INITIALIZES A SUBROUTINE.  A CONTAINS THE NAME, AND THE
  FORMAL ARGUMENT LIST IS IN THE CURRENT ENLIST/GETLIST LIST.
  ** SUBBEG CONTAINS MACHINE-DEPENDANT PORTIONS. **
SVAL(N) - RETURNS A SCRATCH STACK NODE, TYPE 1, THE VALUE WORD SET TO N.
VAL(S) - RETURNS THE VALUE WORD OF THE STACK ENTRY S.
SUBPR0(I) - CALLED WITH 0 AT SUBR CALLS AND 1 AT END OF PARAM LIST; KEEPS
  TRACK OF WHEN IT IS PERMISSIBLE TO REUSE SUBR CALL TEMPORARIES.
SWITCH(N) - HAS THE SAME EFFECT AS SETTING COMPILER SWITCH WHICH IS
  THE NTH LETTER OF THE ALPHABET.
FCON(A,B,E) - CONVERTS FLOATING CONSTANT A.B(E).
THE FOLLOWING ARE NON-SEMANTIC SUBROUTINES:
  RMATCH(I,J,RN) -  RETURNS 1 IF REGISTER RN FALLS WITHIN THE LIMITS I-J.
  REGEQ(I,J) - RETURNS 1 IF I AND J ARE GUARANTEED TO BE SAME REGISTER.
  REGSIM(I,J) - RETURNS 1 IF I AND J HAVE IDENTICAL LIMITS.
  TSTRN(J) = CHECKS STRING J FOR REGISTER NAME, RETURNQ REG NUMBER OR -1
  SUBREG(I) - RETURNS 1 IF I IS THE INDEX OF A SUBROUTINE RETURN REG
  TMPREG(I) - RETURNS 1 IF I IS A TEMPORARY REG AND CAN BE OPTIMIZED OUT
  HISREG(I) - RETURS NONZERO IF I IS A USER-SPECIFIED REGISTER.
  REG0(I) - RETURNS 1 IF I NE 0 AND MAY BE ASSIGNED TO REGISTER 0.
  NSUBP() - RETURNS NUMBER OF ARGUMENTS OF CURRENT SUBROUTINE.
  SUBPRM() - RETURNS STACK ENTRY FOR NEXT TEMPORARY FOR SUBR CALLS
  SUBTMPF() - CALLED AT END OF EACH SUBROUTINE TO PLAY WITH SUBR CALL TEMPS.

 SOME SEMANTIC ROUTINES PLAY WITH LISTS.  THOSE ROUTINES MAY BE CALLED FROM
   OTHER ROUTINES OR DIRECTLY FROM SEMANTICS STATEMENTS IN SYNTAX.  THE LISTS
   ARE STORED IN FREE STORAGE ARRAY LISTS, AND CONSIST OF THREE WORD ENTRIES.
   LISTB HOLDS THE BEGINNING AND LISTE THE END OF THE CURRENT LIST.  WHEN A
   NEW ONE IS OPENED, LISTB AND LISTE ARE PLACED AT THE END OF LIST, AND
   THE VALUES ARE RESET TO THAT POINT.  THE PREVIOUS LIST IS REOPENED BY
   RESTORING THE SAVED VALUES.  THE ROUTINES THAT HANDLE THE LIST ARE:
 NEWLIST(S) - OPENS A NEW LIST AND PLACES THE STACK ENTRY AT S ON IT.
               S ON IT.
 ENLIST(S) - ADDS S TO THE CURRENT LIST.
 GETLIST(S) - PUTS THE NEXT ENTRY IN THE LIST IN THE STACK AT S.
               THIS IS USED TO EMPTY THE CURRENT LIST.  IT STARTS FEEDING
               OUT FROM THE BEGINNING OF THE LATEST LIST THE FIRST TIME IT
               IS CALLED FOLLOWING A NEWLIST CALL.  IT RETURNS 0 WHEN THE LIST
               IS EMPTY, CLOSES OUT THE LIST AND REOPENS THE PREVIOUS ONE.   #

SUBR IMPSEM(NIL) IS (
  RG,ARR,NARR ARE COMMON,1 LONG;
 IMPSMD IS COMMON; GO TO IMPSMD;
 REMOTE (IMPSMD: (LOC(IMPSMQ)-LOC(IMPSMD)) LE 128=>ERROR(0,0);
  DSEM('LETSYN',LETSYN);
  DSEM('NAME',NAME);
  DSEM('AREG1',AREG1);
  DSEM('AREG',AREG);
  DSEM('REG2',REG2);
  DSEM('VAL',VAL);
  DSEM('SVAL',SVAL);
  DSEM('NEWLIST',NEWLIST);
  DSEM('ENLIST',ENLIST);
  DSEM('DECL',DECL);
  DSEM('DECLARE',DECLARE);
  DSEM('SUBBEG',SUBBEG);
  DSEM('SUBEND',SUBEND);
  DSEM('SUBPR0',SUBPR0);
  DSEM('REMOT',REMOT);
  DSEM('ASSEMC',ASSEMC);
  DSEM('CALLME',CALLME);
  DSEM('SWITCH',SWITCH);
  DSEM('STACKUP',STACKUP);
  DSEM('REG2S',REG2S);
 DSEM('FCON',FCON);
 DSEM('ERROR',ERRSRT);
 FRELOT(REMO,'REMOT',3,0);
 FRELOT(SUBPAR,'SUBRP',5,0); NSUBPAR_0;
 FRELOT(REGDEC,'RGDEC',5,0); NREGDEC_0;
 FRELOT(LOCV,'LOCV',5,0); NLOCV_0;
 FRELOT(LISTS,'LISTS',50,0); LISTB_LISTE_0;
 FRELOT(ARR,'ARRYS',5,0); NARR_0;
 FRELOT(RG,'REGS',300,0); REGN_65;
  FREES(RG+I+1,(10000B AND I LS 7) OR 101B*I AND 37B) FOR I TO 63;
  IMPM_DIR('IMPM.');
  SUBTMPN_0; SUBTMP_NEWNAME('PAR');
  RETURN 0; IMPSMQ: 0); 0);

SUBR ASSEMC(A) IS (FINAM IS COMMON;
  FINAM[5] AND 200000000B=>FMAP(0);
  ANYCODE(0) => (SUBTMPF(0);
                 GRAPHF(0); PARSEF(0);
                 RNTRNT_FINAM[5] AND 400000B;
                 RNTRNT=>(E_FREE(A+2) RS 18;
                          F_FREE(REMO+2) RS 18)
                     ELSE(HOOK(A,A,REMO);
                          E_0; F_FREE(A+2) RS 18);
                 RELNM=0 => RELNM_DIR(FINAM);
                 ASSEMB(E,F,REGN,IMPM,RELNM));
  0);

SUBR REMOT(A) IS (HOOK(REMO,REMO,A);
                  FREES(A+2,0); A);

SUBR CALLME(A) IS (RELNM_FREE(A) RS 18; A);

SUBR FCON(A,B,E) IS (
 LH,RH,TEN ARE REAL;
 LH_RH_0; TEN_10;
 BP_BYTEP FREE(DPROP('NAME',FREE(A)<L>))<7,36>;
 WHILE (CH_<+BP>) DO (
	CH<R'0'=>(FCERR: ERROR(1,'ILLEGAL CHARACTER IN FLOATING CONSTANT.');
		LC_RC_0; GO TO FCEXIT);
	CH>R'9'=>GO TO FCERR;
	LH_(CH-R'0')+LH*TEN);
 BP_BYTEP FREE(DPROP('NAME',FREE(B)<L>))<7,36>;
 SCA IS REAL; SCA_1; TEN_1/TEN;
 WHILE (CH_<+BP>) DO (
	CH<R'0'=>GO TO FCERR; CH>R'9'=>GO TO FCERR;
	RH_RH+(CH-R'0')*SCA_SCA*TEN);
 FCEXIT: LH_LH+RH;
 E=>(FREE(E)<6,0> NE 4=>GO TO FCERR;
	EXPT_FREE(E+1); (EX_EXPT)<0=>EX_-EXPT;
	EX>127=>(ERROR(1,'EXPONENT GREATER THEN 127.'); EX_0);
	XPT IS REAL;
	XPT_1;
	WHILE EX>9 DO (EX_EX-10; XPT_XPT*10000000000.0);
	WHILE EX>0 DO (EX_EX-1; XPT_XPT*10.0);
	EXPT<0=>XPT_1/XPT;
	LH_LH*XPT);
 LH IS INTEGER;
 FREES(A,204B);
 FREES(A+1,LH);
 A);

SUBR STACKUP(V) IS (T_ENSTACK(0);
                    FREES(T,4); FREES(T+1,V);
                    T);

SUBR NAME(S) IS (
 ((D_FREE(S)) AND 77B) NE 1 => GO TO NAMEX;
 D_D RS 18;
 J_DNAME(D,0);
 ATY_DPROP('ATYPE',D) LS 6;
 ATY=0=>(DPROPS('ATYPE',D,1); ATY_1 LS 6);
 (K_TSTRN(J)) GE 0=>(FREES(S,2 OR ATY);
                     K_AREG(K+40B);
                     FREES(S+1,K LS 18);
                     GO TO NAMEX);
 CONVC(D) => (CONST IS COMMON;
              FREES(S,ATY OR 4 OR D LS 18);
              FREES(S+1,CONST);
              GO TO NAMEX);
 NLOCV=>((J_FREE(LOCV+I);
	    D=J<L>=>(D_J<R>; ATY_DPROP('ATYPE',D) LS 6;
		     GO TO NM1)) FOR I FROM NLOCV-1);
 GO TO NM2;
 NM1:  NSUBPAR=>((J_FREE(SUBPAR+I);
            D=J=>(#SUBROUTINE PARAMETER NUMBER I #
                  FREES(S,ATY OR 20B);
                  R16_AREG(16B);
                  FREES(S+1,400000000000B OR I OR R16 LS 18);
                  GO TO NAMEX)) FOR I FROM NSUBPAR-1);
 NM2:  NREGDEC=>((J_FREE(REGDEC+I);
            D=(J AND 777777B)=>(#WAS DECLARED REGISTER#
                                FREES(S,ATY OR 2);
                                FREES(S+1,J AND NOT 777777B);
                                GO TO NAMEX)) FOR I FROM NREGDEC-1);
 # JUST PLAIN IDENTIFIER. (HERE IS WHERE ONE MAY INSERT CHECKS TO IMPLEMENT
   EQUIVALENCING, SUBR PARAMETERS, AND SO FORTH). #
 FREES(S,10B OR ATY OR D LS 18);
 FREES(S+1,0);
 NAMEX: S);

SUBR TSTRN(J) IS (
 (J AND 303777777777B)='0R'=>(K_(J RS 29)-60B;
                              K GE 0=>K<10=>GO TO TSTX);
 (J AND 775417777777B)='10R'=>(K_(177B AND J RS 22)-46B;
                               K GE 10=>K<16=>GO TO TSTX);
 K_-1;
 TSTX: K);

SUBR NSUBP(NIL) IS NSUBPAR;

SUBR SVAL(N) IS (J_ENSTACK(0); FREES(J+1,N); J);

SUBR VAL(S) IS (FREE(S+1) AND 777777B);

SUBR SWITCH(N) IS (FINAM[5]_FINAM[5] OR 1 LS N-1; ENSTACK(0));

SUBR SUBBEG(A) IS  (
 SUBRTN=>ERROR(1,'NESTED SUBROUTINES.'); SUBRTN_1;
 J_FREE(A); J_J RS 18;
 DPROPS('COM',J,2);
 ANYCODE(0)=0 => IMPM_0;
 RNTRNT_FINAM[5] AND 400000B;
 RNTRNT=>(K_ENSTACK(0);
          ADDCODE(K,200000000000B OR J,0);
          ADDCODE(K,0,J);
          J_SUBTAG(J);
          ADDCODE(K,254B LS 24,J);
          ADDCODE(A,200000000000B OR J,0);
          REMOT(FREEZE(K)))
     ELSE(ADDCODE(A,200000000000B OR J,0);
          ADDCODE(A,0,J));
 K_ENSTACK(0);
WHILE GETLIST(K) DO (I_FREE(K)<L>; J_NEWNAME(DNAME(I,0));
		FADD(LOCV,NLOCV,J OR I LS 18);
		FADD(SUBPAR,NSUBPAR,J));
 SUBTMPF(0);
 A);

SUBR SUBEND() IS (SUBRTN_NLOCV_NSUBPAR_0);

SUBR SUBTAG(N) IS (
 LCL IS 7 LONG;
 OP_BYTEP LCL<7,36>;
 IP_BYTEP [GNAME(N)]<7,36>;
 L_1; <+OP>_045B;
 SBTG1: M_<+IP>;
 M=>L<30=>(<+OP>_M; L_L+1; GO TO SBTG1);
 <+OP>_0 FOR L FROM 4;
 DIR(LCL));

SUBR SUBTMPF(NIL) IS (
 SUBTMPN=>(FADD(ARR,NARR,SUBTMP OR SUBTMPN LS 18);
           SUBTMP_NEWNAME('PAR');
           SUBTMPN_SUBTMPK_0));

SUBR SUBPR0(I) IS (I=>((SUBCNT_SUBCNT-1)=0=>SUBTMPK_0)
                    ELSE (SUBCNT_SUBCNT+1); 0);

SUBR SUBPRM(I) IS (
 J_ENSTACK(0);
 FREES(J,10B OR SUBTMP LS 18);
 FREES(J+1,SUBTMPK);
 (SUBTMPK_SUBTMPK+1)>SUBTMPN=>SUBTMPN_SUBTMPK;
 J);

SUBR AREG1(I,J) IS (
 # ASSIGNS A REGISTER BETWEEN I AND J.  REGISTER ASSIGNMENTS ARE
   STORED IN ARRAY RG IN THE FOLLOWING FORMAT:

     BIT     35  INDICATES HARDWARE REGISTER HAS BEEN ASSIGNED.
     BITS 29-18  REGISTER REFERENCE COUNT MADE BY ASSEMBLER.
     BITS 17-13  HARDWARE REGISTER ASSIGNED BY RMOD.
     BIT     12  INDICATES THIS IS NOT A TEMPORARY REGISTER.
     BIT     11  INDICATES SUBROUTINE CALL - REGISTER MAY BE REASSIGNED
                   IF SAME REGISTER IS REQUESTED AGAIN.
     BITS  10-6  LOWER LIMIT FOR REGISTER NUMBER.
     BIT      5  INDICATES TWO SUCCESSIVE REGISTERS ARE REQUIRED.  THE SECOND
                   GOES IN THE NEXT WORD OF RG.
     BITS   4-0  UPPER LIMIT FOR REGISTER NUMBER. #

 ((I OR J) AND NOT 177B)=>(ERROR(1,'IN AREG1 - I OR J OUT OF RANGE.');
                           I_0; J_37B);
 S_REGN;
 FADD(RG,REGN,J OR I LS 6);
 (J AND 40B)=>FADD(RG,REGN,(J AND 37B) OR I LS 6);
 S);

SUBR AREG(I) IS (I+1);

SUBR REG2(N) IS (N+1);

SUBR REG2S(S) IS (J_FREE(S+1); J<11,18>_REG2(J<11,18>);
      FREES(S+1,J); S);

SUBR HISREG(I) IS (10000B AND FREE(RG+I));

SUBR SUBREG(J) IS (4000B AND FREE(RG+J));
SUBR SAMEREG(J) IS (
 TMPREG(J)=0 => RETURN J;
 K_FREE(RG+J);
 AREG1(77B AND K RS 6,77B AND K));

SUBR TMPREG(J) IS (V_1; J LE 64 => V_0;
                        FREE(RG+J) AND 14040B => V_0; V);

SUBR RMATCH(I,J,RN) IS (K_FREE(RG+RN);
 VAL_0;
 J GE (37B AND K)=>I LE (37B AND K RS 6)=>VAL_1;
 VAL);

SUBR REGEQ(I,J) IS (
 VAL_1; I=J=>GO TO RXIT;
 VAL_0; I=0=>GO TO RXIT;
 J=0=>GO TO RXIT;
 II_FREE(RG+I); JJ_FREE(RG+J);
 (37B AND II)=(37B AND II RS 6)=>II=JJ=>VAL_1;
 RXIT: VAL);

SUBR REGSIM(I,J) IS (
 VAL_1; I=J=>GO TO RXIS;
 VAL_0; I=0=>GO TO RXIS;
 J=0=>GO TO RXIS;
 II_FREE(RG+I); JJ_FREE(RG+J);
 II=JJ=>VAL_1;
 RXIS: VAL);

SUBR REG0(I) IS (
  VAL_0; I=>(J_FREE(RG+I); (J AND 3700B)=0=>VAL_1); VAL);

SUBR DECL(I,S) IS (
 I>1 => (PROPS_PROPS OR 1 LS I; GO TO L10);
 GO TO (L8,L9) I;
 L8: PREGSYN => ERROR(1,'TWO REGISTERS IN SAME DECLARATION.');
     J_FREE(S) RS 18; J_FREE(DPROP('NAME',J));
     (K_TSTRN(J)) GE 0 => PREGSYN_AREG(K+40B) ELSE
        ERROR(1,'ANTECEDENT NOT A HARDWARE REGISTER IN SYNONYM DECLARATION.');
     GO TO L10;
 L9: PLONG=>ERROR(1,'TWO LENGTHS IN SAME DECLARATION. ');
     (77B AND FREE(S))=4 => PLONG_FREE(S+1) ELSE
        ERROR(1,'N NOT A CONSTANT IN N LONG.');
 L10: 0);

SUBR DECLARE(S) IS (
 T_ENSTACK(0);
 L7: (J_GETLIST(S)) => (
        J_FREE(S) RS 18; JJ_0;
	NLOCV=>((K_FREE(LOCV+I);
		J=K<L>=>(J_K<R>; GO TO D1)) FOR I FROM NLOCV-1); D1:
	(PROPS AND 2048)=>(I_J; J_NEWNAME(DNAME(J,0));
		FADD(LOCV,NLOCV,J OR I LS 18)); #LOCAL#
        NREGDEC => ((K_FREE(REGDEC+I);
                     J=K AND 777777B => (JJ_K RS 18; GO TO D2))
                                           FOR I FROM NREGDEC-1);
	D2: K_DNAME(J,0);
        (K_TSTRN(K)) GE 0 => JJ_AREG(K+40B);
        L11: PREGSYN => (JJ_PREGSYN; FADD(REGDEC,NREGDEC,J OR JJ LS 18));
        (PROPS AND 4)  => JJ=0 => DPROPS('COM',J,1);   #COMMON#
        (PROPS AND 8)  =>DPROPS('ATYPE',J,2); #REAL#
        (PROPS AND 16) =>DPROPS('ATYPE',J,1); #INTEGER#
        (PROPS AND 32) => (JJ=0 => (JJ_AREG1(101B,15B);
                                    FADD(REGDEC,NREGDEC,J OR JJ LS 18));
                           DEWFUN(T,5,JJ));            #REGISTER#
        (PROPS AND 64)  => JJ => DEWFUN(T,6,JJ);       #RESERVED#
        (PROPS AND 128) => JJ => DEWFUN(T,9,JJ);       #SCRATCH#
        (PROPS AND 256) => JJ => DEWFUN(T,10,JJ);      #PROTECTED#
        (PROPS AND 512) => JJ => DEWFUN(T,8,JJ);       #AVAILABLE#
        (PROPS AND 1024)=> JJ => (NREGDEC => ((J=FREE(REGDEC+I) AND 777777B =>
                                       FREES(REGDEC+I,0)) FOR I FROM NREGDEC-1);
                                  DEWFUN(T,8,JJ));     #RELEASED#
        PLONG => JJ=0 => FADD(ARR,NARR,J OR PLONG LS 18);
        JJ => (PLONG OR PROPS AND 28) =>
                  ERROR(1,'PROPERTY DECLARED IS NOT APPLICABLE TO REGISTER.');
        JJ=0 => (PROPS AND 1984) =>
                  ERROR(1,'PROPERTY MAY ONLY BE DECLARED FOR REGISTERS.');
        GO TO L7);
 PROPS_PLONG_PREGSYN_0; T);

SUBR LETSYN(S) IS (MAX_FREE(S+1);

 SYNT(ENSTACK(DIR('VBL')),0);
 SYTRM(ENSTACK(-FREE(MAX)));
 SYNTAX(1);
 J_MAX; WHILE K_FREE(J+1) DO (FREES(J,K); J_J+1); FREES(J,0);
 EQUOSE(S,NEWLIST(0)); SEMANTICS(); ENSTACK(0));
SUBR NEWLIST(S) IS (
  FREES(LISTS+LISTE,LISTB);
  FREES(LISTS+LISTE+1,LISTE);
  FREES(LISTS+LISTE+2,BLIST);
  BLIST_LISTB_LISTE_LISTE+3;
  S=>ENLIST(S);
  S);

SUBR ENLIST(S) IS (
  FADD(LISTS,LISTE,FREE(S));
  FADD(LISTS,LISTE,FREE(S+1));
  FADD(LISTS,LISTE,FREE(S+2)); 0);

SUBR GETLIST(S) IS (
  (J_LISTE-BLIST)=>(FREES(S,FREE(LISTS+BLIST));
                  FREES(S+1,FREE(LISTS+BLIST+1));
                  FREES(S+2,FREE(LISTS+BLIST+2));
                  BLIST_BLIST+3;
                  GO TO L6);
  BLIST_FREE(LISTS+LISTB-1);
  LISTE_FREE(LISTS+LISTB-2);
  LISTB_FREE(LISTS+LISTB-3);
  L6: J_J/3);

SUBR ERRSRT(N,E) IS (ERROR(N,FREE(DPROP('NAME',-E)));
	NAME(ENSTACK(DIR('0'))))%%%