reduce-historical/r30/lap.red

COMMENT MODULE LAP;

SYMBOLIC;


COMMENT definition of LAP ops;

SYMBOLIC FEXPR PROCEDURE MACOPS L; 
   BEGIN 
    A: 
      IF NULL L THEN RETURN T; 
      PUT(CAR L,'MACOP,CADR L); 
      L := CDDR L; 
      GO TO A
   END;

MACOPS(PUSHJ,
       176,
       POPJ,
       179,
       PUSH,
       177,
       POP,
       178,
       CALL,
       28,
       JCALL,
       29,
       CALLF,
       30,
       JCALLF,
       31,
       JRST,
       172,
       JSP,
       181,
       CALLF!@,
       15376,
       JCALLF!@,
       15888,
       MOVE,
       128,
       MOVEI,
       129,
       MOVEM,
       130,
       HRRZS,363,
       MOVNI,
       137,
       HLLZS,331,
       CAIE,
       194,
       CAIN,
       198,
       CAME,
       202,
       CAMGE,
       205,
       CAMLE,
       203,
       CAMN,
       206,
       ADD,
       184,
       SUB,
       188,
       IMUL,
       144,
       CLEARM,
       258,
       CLEARB,
       259,
       EXCH,
       168,
       TDZA,
       412,
       JUMP,
       208,
       JUMPE,
       210,
       JUMPN,
       214,
       HRRZ,
       360,
       HLRZ,
       364,
       HRRM,
       354,
       HRLM,
       326,
       HRLI,
       325,
       HRRZ!@,
       184336,
       HLRZ!@,
       186384,
       HRRM!@,
       181264,
       HRLM!@,
       166928,
       HRRZS!@,
       185872,
       HLLZS!@,
       169488,
       JUMPGE,
       213);

MACOPS(NIL,0,A,1,B,2,C,3,TT,7,D,10,R,11,P,12,SP,15);

MACOPS(CARA,
       364,
       CARA!@,
       186384,
       CDRA,
       360,
       CDRA!@,
       184336,
       RPLCA,
       326,
       RPLCA!@,
       166928,
       RPLCD,
       354,
       RPLCD!@,
       181264,
       JSYS,
       68);

MACOPS(SETO,
       316,
       MOVSI,
       133,
       ILDB,
       92,
	IDPB,
	94,
       TRZ,
       400,
       HRRI,
       353,
       HRROI,
       369,
       HRL,
       324,
       HRRZ,
       360,
       TRO,
       432,
       ADDI,
       185,
       AOBJN,
       171,
       CAIL,
       193,
       SKIPA,
       220,
       SKIPE,
       218,
       SETZM,
       258,
       BLT,
       169,
       SUBI,
       189,
       AOJN,
       230,
       SKIPG,
       223,
       LDB,
       93,
       AOJA,
       228,
       SOJA,
       244,
       CAIG,
       199,
       CAILE,
       195,
       LSH,
       162,
       IORM,
       286,
       HRLZ,
       332,
       HRLZM,
       334,
       SOJE,
       242,
       SOJN,
       246,
       DPB,
       95,
       ANDI,
       261);


FLUID '(BPORG BPEND CLIST QLIST);

FLUID '(!*PWRDS
          !*PGWD
          !*SAVECOM
          CONLIST
          GEN
          REMSYMS);

SYMBOLIC PROCEDURE LAP U; LAP10 U;

SYMBOLIC PROCEDURE LAP10 U; 
   BEGIN SCALAR SL,LOC,CONLIST,GEN,REMSYMS,X; 
      GEN := GENSYM();   %entry point for constants;
      CONLIST := LIST NIL; %constant list;
      LOC := BPORG;  %entry point for function;
      WHILE U DO
	<<IF ATOM(X := CAR U)
	    THEN <<IF !*PGWD THEN PRINT X; DEFSYM(X,BPORG)>>
	 ELSE IF CAR X EQ '!*ENTRY 
	  THEN <<IF SL THEN RPLACD(CDAR SL,BPORG);
		 SL := LIST(CDR X,BPORG) . SL;
		 LOC := BPORG;
		 IF !*COUNTMC
		  THEN RPLACD(U,APPEND(
		   <<PUT(CAR X,'MCCOUNT,ADD1 GET(CAR X,'MCCOUNT));
		     COUNTMC CAR X>>,CDR U));
		 IF !*PGWD THEN PRINT X>>
	 ELSE IF CADR X MEMBER '(EXPR FEXPR)
	  THEN <<IF SL THEN RPLACD(CDAR SL,BPORG);
		 SL := LIST(X,BPORG) . SL;
		 LOC := BPORG;
		 IF !*PGWD THEN PRINT X>>
	 ELSE IF NOT NUMBERP CAR X AND FLAGP(CAR X,'MC)
	  THEN RPLACD(U,APPEND(IF !*COUNTMC THEN 
	   <<PUT(CAR X,'MCCOUNT,ADD1 GET(CAR X,'MCCOUNT));
		COUNTMC CAR X>>,
			  APPEND(EVAL(CAR X .
				  FOR EACH J IN CDR X COLLECT MKQUOTE J),
				  CDR U)))
	 ELSE <<DEPOSIT(BPORG,KWD X);
		IF (BPORG := BPORG+1)>BPEND
		  THEN REDERR "BINARY PROGRAM SPACE EXCEEDED">>;
       U := CDR U>>;
      IF SL THEN <<RPLACD(CDAR SL,BPORG);
		   SL := REVERSIP SL;
		   IF !*PWRDS THEN FOR EACH X IN SL DO
				LPRIM LIST(CAAR X,CADR X,'BASE,
					   CDDR X-CADR X,
					   'WORDS,BPEND-CDDR X,'LEFT)>>;
      DEFSYM(GEN,BPORG);  %define entry point for constants;
      WHILE CONLIST := CDR CONLIST DO 
         <<CLIST := (CAR CONLIST . BPORG) . CLIST; 
           DEPOSIT(BPORG,KWD CAR CONLIST); 
           IF (BPORG := BPORG+1)>BPEND 
	     THEN REDERR "BINARY PROGRAM SPACE EXCEEDED">>; 
      FOR EACH X IN REMSYMS DO REMSYM X;
      IF !*SAVECOM
	THEN FOR EACH X IN SL DO 
	   <<REMD CAAR X;
	     !%PUTD(CAAR X,CADAR X,MKCODE(CADR X,CADDAR X))>>;
   END;

SYMBOLIC PROCEDURE KWD U; 
   BEGIN SCALAR X;
      X := GWD U;
      IF !*PGWD
	THEN BEGIN INTEGER N;
	   PRIN1 U;
	   SPACES2 30;
	   N := BASE;
	   BASE := 7+1;
	   PRINT(IF X < 0 THEN X + 68719476736 ELSE X);
	   BASE := N
	 END;
      RETURN X
   END;

SYMBOLIC PROCEDURE SPACES2 N;
   BEGIN SCALAR M;
      M := N-POSN();
      IF M<1 THEN PRIN2 " "
       ELSE WHILE M>0 DO <<PRIN2 " "; M := M-1>>
   END;


% PRINT MACROS FIRST, IF T; 

!*PWRDS := T;

% PRINT SPACE-USAGE, IF T; 

!*PGWD := NIL;

% PRINT EXPANDED CODE IF T; 

!*SAVECOM := T;

% ACTUALLY LOAD IF T; 

!*SAVEDEF := NIL;

% RETAIN EXPR/FEXPR IF T; 

QSET('QLIST,NIL);

QSET('CLIST,NIL);

SYMBOLIC PROCEDURE GWD X; 
   BEGIN SCALAR WRD,FLD; 
      WRD := LAPEVAL CAR X;
      WRD := LSH(WRD,IF WRD<512 THEN 27 ELSE 18); 
      FLD := '((23 . 15) (0 . 262143) (18 . -1)); 
      MAPC(CDR X,
	   FUNCTION LAMBDA ZZ; 
                         <<WRD := 
                            WRD
                              + LSH(BOOLE(1,CDAR FLD,LAPEVAL ZZ),
                                    CAAR FLD); 
                           FLD := CDR FLD>>);
      RETURN WRD
   END;

SYMBOLIC PROCEDURE RELOC L; LAPEVAL CAR L + 96;

SYMBOLIC PROCEDURE LAPEVAL X; 
   IF NUMBERP X THEN X
    ELSE IF ATOM X THEN GVAL X
    ELSE IF CAR X MEMBER '(E QUOTE)
     THEN !*BOX IF (NOT ATOM (X := CADR X)
                      OR NUMBERP X AND NOT INUMP X)
                     OR STRINGP X
                  THEN BEGIN SCALAR Y; 
                          Y := QLIST; 
                        A: 
                          IF NULL Y
                            THEN RETURN CAR (QLIST := X . QLIST)
                           ELSE IF X=CAR Y
                                     AND FLOATP X EQ FLOATP CAR Y
                            THEN RETURN CAR Y; 
                          Y := CDR Y; 
                          GO TO A
                       END
                 ELSE X
    ELSE IF CAR X EQ 'FLUID OR CAR X EQ 'SPECIAL
     THEN <<QSET(CADR X,NIL);
            !*BOX GET(CADR X,'VALUE)>>
    ELSE IF CAR X EQ 'C
     THEN BEGIN SCALAR N,CPTR; 
             CPTR := CLIST; 
           L11: 
             IF NULL CPTR THEN GO TO L12
              ELSE IF CDR X=CAAR CPTR THEN RETURN CDAR CPTR; 
             CPTR := CDR CPTR; 
             GO TO L11; 
           L12: 
             GVAL GEN; 
             N := 0; 
             CPTR := CONLIST; 
           A: 
             IF NULL CDR CPTR THEN RPLACD(CPTR,LIST CDR X); 
             IF CDR X=CADR CPTR THEN RETURN N; 
             N := N + 1; 
             CPTR := CDR CPTR; 
             GO TO A
          END
    ELSE IF CAR X EQ 'RELOC THEN LAPEVAL CADR X + 96
    ELSE IF CAR X EQ 'EXARG AND NOT ATOM CDR X
     THEN LAPEVAL 'EXARG + LAPEVAL CADR X
    ELSE LAPEVAL CAR X + LAPEVAL CDR X;

SYMBOLIC PROCEDURE DEFSYM(SYM,VAL); 
   BEGIN SCALAR Z; 
      IF Z := GET(SYM,'UNDEF) THEN GO TO PATCH; 
      REMSYMS := SYM . REMSYMS; 
    A: 
      RETURN PUT(SYM,'SYM,VAL); 
    PATCH: 
      IF NULL Z THEN <<REMPROP(SYM,'UNDEF); GO TO A>>; 
      DEPOSIT(CAR Z,EXAMINE CAR Z + VAL); 
      Z := CDR Z; 
      GO TO PATCH
   END;

SYMBOLIC PROCEDURE GVAL SYM; 
   BEGIN SCALAR X; 
      IF X := GET(SYM,'MACOP) THEN RETURN X
       ELSE IF X := GET(SYM,'SYM) THEN RETURN X
       ELSE IF GET(SYM,'VALUE) THEN RETURN !*BOX SYM; 
      PUT(SYM,
          'UNDEF,
          BPORG
            . IF X := GET(SYM,'UNDEF) THEN X
               ELSE <<REMSYMS := SYM . REMSYMS; NIL>>); 
      RETURN 0
   END;

SYMBOLIC PROCEDURE REMSYM L; 
   IF GET(L,'UNDEF) THEN LPRIE LIST(L,"UNDEFINED SYMBOL")
    ELSE IF NULL REMPROP(L,'SYM)
     THEN LPRIE LIST(L,"MULTIPLY DEFINED")
    ELSE IF CAADR L EQ 'PNAME THEN REMOB L   %means L has no props;
    ELSE NIL;

BPORG1 := BPORG;

LAP10 '((GWD EXPR 1)
        (PUSH P (C 0))
        (PUSH P 1)
        (PUSHJ P TAG04)
        (CAIG 1 511)
        (LSH 1 9)
        (HLRZ 2 1)
        (HRRZ 3 1)
        (CAIN 2 34816)
        (CAIL 3 512)
        (JRST 0 TAG01)
        (MOVEM 1 -1 P)
        (JUMPN 3 TAG02)
        TAG01
        (HRLZM 1 -1 P)
        (PUSHJ P TAG04)
        (ANDI 1 15)
        (LSH 1 23)
        (IORM 1 -1 P)
        (PUSHJ P TAG04)
        (HRRM 1 -1 P)
        (PUSHJ P TAG04)
        (HRLZ 1 1)
        (IORM 1 -1 P)
        TAG02
        (POP P 1)
        (POP P 1)
        (JCALL 1 (E !*BOX))
        TAG03
        (POP P 1)
        (JRST 0 TAG02)
        TAG04
        (MOVE 2 -1 P)
        (JUMPE 2 TAG03)
        (CARA 1 0 2)
        (CDRA 2 0 2)
        (MOVEM 2 -1 P)
        (CALL 1 (E LAPEVAL))
        (JCALL 1 (E NUMVAL)));

CLIST := NIL;

IF BPEND<131072 THEN BPORG := BPORG1;   %means DECUS version;


END;