reduce-historical/r30/fend.red

COMMENT R E D U C E PREPROCESSOR FOR DECSYSTEMS 10 AND 20;


COMMENT Standard LISP Functions Defined in LISP 1.6:

   ABS AND APPEND APPLY ATOM CAR ... CDDDDR COND CONS DIVIDE EQ EQUAL
   EVAL FIX GENSYM GET GO LENGTH LINELENGTH MEMBER MEMQ MINUS NCONC
   NOT NULL NUMBERP OR PRINC PRIN1 PROG QUOTE READCH REMAINDER
   RETURN REVERSE RPLACA RPLACD SET SETQ SUBST TERPRI;


COMMENT compiler support functions needed for DEC-10 implementation;

REMFLAG('(LIST2 LIST3 LIST4 LIST5 REVERSIP),'LOSE);

SYMBOLIC PROCEDURE LIST2(U,V); U . V . NIL;

SYMBOLIC PROCEDURE LIST3(U,V,W); U . V . W . NIL;

SYMBOLIC PROCEDURE LIST4(U,V,W,X); U . V . W . X . NIL;

SYMBOLIC PROCEDURE LIST5(U,V,W,X,Y); U . V . W . X . Y . NIL;

SYMBOLIC PROCEDURE REVERSIP U; 
   BEGIN SCALAR X,Y; 
      WHILE U DO <<X := CDR U; Y := RPLACD(U,Y); U := X>>; 
      RETURN Y
   END;


COMMENT Primitive Standard LISP Functions Defined in terms of LISP 1.6;

SYMBOLIC PROCEDURE EQN(M,N); M EQ N OR NUMBERP M AND M=N;

SYMBOLIC PROCEDURE EXPLODE2 U; EXPLODEC U;

SYMBOLIC PROCEDURE FLUID U;
   BEGIN
    A:	IF NULL U THEN RETURN NIL;
	IF GETD 'MODBIND AND NOT GET(CAR U,'MODE)
	 THEN PUT(CAR U,'MODE,'SYMBOLIC);   %interface to mode system;
	IF GETD CAR U
	  THEN ERROR(10,LIST("Function",CAR U,"cannot be fluid"));
	FLAG(LIST CAR U,'FLUID);
	IF NULL !*DEFN THEN QSET(CAR U,NIL);
	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE QSET(U,V); IF ATOM ERRORSET(U,NIL,NIL) THEN SET(U,V);

!*DEFN := NIL;

SYMBOLIC PROCEDURE FLUIDP U; FLAGP(U,'FLUID);

SYMBOLIC PROCEDURE GLOBAL U;
   BEGIN
    A:	IF NULL U THEN RETURN NIL;
	IF GETD 'MODBIND AND NOT GET(CAR U,'MODE)
	 THEN PUT(CAR U,'MODE,'SYMBOLIC);   %interface to mode system;
	IF GETD CAR U
	  THEN ERROR(10,LIST("Function",CAR U,"cannot be global"));
	FLAG(LIST CAR U,'GLOBAL);
	IF NULL !*DEFN THEN QSET(CAR U,NIL);
	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE GLOBALP U; FLAGP(U,'GLOBAL);

GLOBAL '(OBLIST);

FLUID '(!*PI!*);

GLOBAL '(FTYPES!*);

FTYPES!* := '(EXPR FEXPR MACRO);

FLAG('(EXPR FEXPR),'COMPILE);

PUTD('!%PUTD,'EXPR,CDR GETD 'PUTD);

SYMBOLIC PROCEDURE PUTD(NAME,TYPE,BODY);
   BEGIN
	IF TYPE EQ 'SUBR THEN TYPE:='EXPR
	 ELSE IF TYPE EQ 'FSUBR THEN TYPE:='FEXPR
         ELSE GO NOWARN;
	WARNING "(F)SUBR converted to (F)EXPR in PUTD";
  NOWARN:
	IF FLAGP(NAME,'LOSE) THEN RETURN NIL
	 ELSE IF TYPE MEMQ FTYPES!* AND GETD NAME
	   AND NULL !*DEFN THEN <<WARNING LIST(NAME,"redefined");
					REMPROP(NAME,'TRACE);
					REMPROP(NAME,'TRACECNT)>>;
	IF !*COMP AND FLAGP(TYPE,'COMPILE) AND NOT CODEP BODY
	  THEN COMPD(NAME,TYPE,BODY)
         ELSE IF TYPE MEMQ FTYPES!* THEN !%PUTD(NAME,TYPE,BODY)
	 ELSE PUT(NAME,TYPE,BODY);
	RETURN NAME
   END;

!*COMP := NIL;

SYMBOLIC PROCEDURE UNFLUID U;
   <<FOR EACH X IN U DO REMPROP(X,'MODE); REMFLAG(U,'FLUID)>>;


COMMENT COMPOSITE STANDARD LISP FUNCTIONS NOT DEFINED IN LISP 1.6;

SYMBOLIC PROCEDURE ASSOC(U,V);
   %looks for U in association list V using an EQUAL test;
   IF NULL V THEN NIL
    ELSE IF U=CAAR V THEN CAR V
    ELSE ASSOC(U,CDR V);

FEXPR PROCEDURE DE U; PUTD(CAR U,'EXPR,'LAMBDA . CADR U . CDDR U);

SYMBOLIC PROCEDURE DEFLIST(L,V);
   IF NULL L THEN NIL
    ELSE PROGN(PUT(CAAR L,V,CADAR L),CAAR L) . DEFLIST(CDR L,V);

SYMBOLIC PROCEDURE DELETE(U,V);
   IF NULL V THEN NIL
    ELSE IF U = CAR V THEN CDR V
    ELSE CAR V . DELETE(U,CDR V);

FEXPR PROCEDURE DF U; PUTD(CAR U,'FEXPR,'LAMBDA . CADR U . CDDR U);

FEXPR PROCEDURE DM U; PUTD(CAR U,'MACRO,'LAMBDA . CADR U . CDDR U);

SYMBOLIC PROCEDURE EXPAND(L,FN);
   IF NULL L THEN NIL
    ELSE IF NULL CDR L THEN CAR L
    ELSE LIST(FN,CAR L,EXPAND(CDR L,FN));

SYMBOLIC PROCEDURE M**N;
   BEGIN SCALAR P,Q;
	IF N<0 THEN RETURN (1.0/M**(-N))
	 ELSE IF N=0 OR M=1 THEN RETURN 1;
	P := 1;
  A:	Q := DIVIDE(N,2);
	IF CDR Q = 0 THEN GO TO B;
	P := M*P;
	IF CAR Q = 0 THEN RETURN P;
  B:	N := CAR Q;
	M := M*M;
	GO TO A
   END;

SYMBOLIC PROCEDURE MAPOBL !*PI!*;
   FOR EACH X IN OBLIST DO FOR EACH Y IN X DO !*PI!* Y;

SYMBOLIC MACRO PROCEDURE MAX U; EXPAND(CDR U,'MAX2);

SYMBOLIC PROCEDURE MAX2(U,V); IF U<V THEN V ELSE U;

SYMBOLIC MACRO PROCEDURE MIN U; EXPAND(CDR U,'MIN2);

SYMBOLIC PROCEDURE MIN2(U,V); IF U>V THEN V ELSE U;

SYMBOLIC PROCEDURE ONEP U; U=1 OR U=1.0;

SYMBOLIC PROCEDURE PAIR(U,V);
   IF NULL U AND NULL V THEN NIL
    ELSE IF NULL U OR NULL V 
     THEN ERROR(171,LIST(LIST(U,V),"mismatched - PAIR"))
    ELSE (CAR U . CAR V) . PAIR(CDR U,CDR V);

SYMBOLIC MACRO PROCEDURE PLUS U; EXPAND(CDR U,'PLUS2);

SYMBOLIC PROCEDURE SASSOC(U,V,!*PI!*);
   %looks for U in association list V using an EQUAL test.
   %If U is not found, !*PI!*() is returned;
   IF NULL V THEN !*PI!*()
    ELSE IF U=CAAR V THEN CAR V
    ELSE SASSOC(U,CDR V,!*PI!*);

SYMBOLIC PROCEDURE SUBLIS(X,Y);
   BEGIN SCALAR U;
	IF NULL X THEN RETURN Y;
	U := X;
   A:	IF NULL U THEN RETURN IF ATOM Y
		OR (U := SUBLIS(X,CAR Y) . SUBLIS(X,CDR Y)) = Y
	     THEN Y
	    ELSE U
	 ELSE IF Y = CAAR U THEN RETURN CDAR U;
	U := CDR U;
	GO TO A
   END;

SYMBOLIC MACRO PROCEDURE TIMES U; EXPAND(CDR U,'TIMES2);

SYMBOLIC PROCEDURE QUIT; FREEZE T;


END;