reduce-historical/r30/debug.red

COMMENT MODULE DEBUG;

COMMENT TRACE FUNCTIONS;

COMMENT functions defined in REDUCE but not Standard LISP;

SYMBOLIC PROCEDURE LPRI U;
   BEGIN
    A:	IF NULL U THEN RETURN NIL;
	PRIN2 CAR U;
	PRIN2 " ";
	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE LPRIW (U,V);
   BEGIN SCALAR X;
	U := U . IF V AND ATOM V THEN LIST V ELSE V;
	IF OFL!* AND (!*FORT OR NOT !*NAT OR !*DEFN) THEN GO TO C;
	TERPRI();
    A:	LPRI U;
	TERPRI();
	IF NULL X THEN GO TO B;
	WRS CDR X;
	RETURN NIL;
    B:	IF NULL OFL!* THEN RETURN NIL;
    C:	X := OFL!*;
	WRS NIL;
	GO TO A
   END;

SYMBOLIC PROCEDURE LPRIM U;
   !*MSG AND LPRIW("***",U);

SYMBOLIC PROCEDURE LPRIE U;
   BEGIN SCALAR X;
	IF !*INT THEN GO TO A;
	X:= !*DEFN;
	!*DEFN := NIL;
    A:	ERFG!* := T;
	LPRIW ("*****",U);
	IF NULL !*INT THEN !*DEFN := X
   END;

SYMBOLIC PROCEDURE MKQUOTE U;
   LIST('QUOTE,U);

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


COMMENT if we knew how many arguments a function had we could use
	EMBED mechanism;

GLOBAL '(TRACEFLAG!* !*COMP !*MODE);

TRACEFLAG!* := T;

SYMBOLIC FEXPR PROCEDURE TRACE L;
   BEGIN SCALAR COMP,FN,G1,G2,LST,DEFN;
      COMP := !*COMP;
      !*COMP := NIL;   %we don't want TRACE FEXPR compiled;
      WHILE L DO BEGIN
	FN := CAR L;
	L := CDR L;
	G1 := GENSYM();   %trace counter;
	G2 := GENSYM();   %used to hold original definition;
	DEFN := GETD FN;
	IF GET(FN,'TRACE) THEN RETURN LPRIM LIST(FN,"ALREADY TRACED")
	 ELSE IF NOT DEFN THEN RETURN LPRIM LIST(FN,"UNDEFINED");
	LST := FN . LST;
	TR!-PUTD(G2,CAR DEFN,CDR DEFN);
	REMD FN;
	TR!-PUTD(FN,'FEXPR,LIST('LAMBDA,'(!-L),
		LIST('TRACE1,'!-L,MKQUOTE G1,
			MKQUOTE(CAR DEFN . G2),MKQUOTE FN)));
	PUT(FN,'TRACE,G1 . DEFN);
	SET(G1,0);
	PUT('TRACE,'CNTRS,G1 . GET('TRACE,'CNTRS));
       END;
      !*COMP := COMP;
      RETURN REVERSIP LST
   END;

SYMBOLIC PROCEDURE TR!-PUTD(U,V,W);
   %PUTD even if U is flagged LOSE;
   BEGIN SCALAR BOOL;
      IF FLAGP(U,'LOSE) THEN <<BOOL := T; REMFLAG(LIST U,'LOSE)>>;
      PUTD(U,V,W);
      IF BOOL THEN FLAG(LIST U,'LOSE)
   END;

SYMBOLIC PROCEDURE TRACE1(ARGS,CNTR,DEFN,NAME);
   BEGIN SCALAR BOOL,COUNT,VAL,X;
      SET(CNTR,EVAL CNTR+1);   %update counter;
      COUNT := EVAL CNTR;
      IF TRACEFLAG!*
	THEN <<PRIN2 "*** ENTERING ";
		IF NOT COUNT=1 THEN <<PRIN2 COUNT; PRINC " ">>;
		PRIN2 NAME;
		PRIN2 ": ">>;
      BOOL := CAR DEFN MEMQ '(FEXPR FSUBR);
      IF NULL BOOL THEN ARGS := EVAL('LIST . ARGS);
      IF TRACEFLAG!* THEN PRINT ARGS;
      VAL :=
	IF BOOL THEN EVAL(CDR DEFN . ARGS) ELSE APPLY(CDR DEFN,ARGS);
      IF TRACEFLAG!*
	THEN <<PRIN2 "*** LEAVING ";
		IF NOT COUNT=1 THEN <<PRIN2 COUNT; PRINC " ">>;
		PRIN2 NAME;
		PRIN2 ": ";
		PRINT VAL>>;
      SET(CNTR,COUNT-1);
      RETURN VAL
   END;

SYMBOLIC FEXPR PROCEDURE UNTRACE L;
   BEGIN SCALAR COMP,FN,LST,DEFN;
      COMP := !*COMP;
      !*COMP := NIL;
      WHILE L DO BEGIN
	FN := CAR L;
	L := CDR L;
	DEFN := GET(FN,'TRACE);
	IF NULL DEFN THEN RETURN LPRIM LIST(FN,"NOT TRACED");
	REMD FN;
	TR!-PUTD(FN,CADR DEFN,CDDR DEFN);
	REMPROP(FN,'TRACE);
	LST := FN . LST;
	PUT('TRACE,'CNTRS,DELETE(CAR DEFN,GET('TRACE,'CNTRS)))
       END;
      !*COMP := COMP;
      RETURN REVERSIP LST
   END;

SYMBOLIC PROCEDURE TR U; TR1(U,'TRACE);

SYMBOLIC PROCEDURE UNTR U; TR1(U,'UNTRACE);

FLUID '(!*NOUUO);

SYMBOLIC PROCEDURE TR1(U,V); 
   BEGIN SCALAR X; 
      !*NOUUO := T; 
      X := EVAL (V . U); 
      IF NOT !*MODE EQ 'SYMBOLIC THEN <<TERPRI(); PRINT X>> ELSE RETURN X
   END;

DEFLIST ('((TR RLIS) (UNTR RLIS)),'STAT);

FLAG('(TR UNTR),'IGNORE);

%PUT('TR,'ARGMODE,'(((ARB!-NO SYMBOLIC) TR . NOVAL)));

%PUT('UNTR,'ARGMODE,'(((ARB!-NO SYMBOLIC) UNTR . NOVAL)));


COMMENT TRACESET FUNCTIONS;

SYMBOLIC PROCEDURE TRSET1(U,V); 
   FOR EACH X IN U DO
      BEGIN DCL Y:SYMBOLIC;
   	Y := GETD X;
	IF NULL Y OR NOT CAR Y MEMQ '(EXPR FEXPR MACRO)
	  THEN LPRIM LIST(X,"CANNOT BE TRACESET")
	 ELSE IF V AND FLAGP(X,'TRST)
	  THEN LPRIM LIST(X,"ALREADY TRACESET")
	 ELSE IF NULL V AND NOT FLAGP(X,'TRST)
	  THEN LPRIM LIST(X,"NOT TRACESET")
	 ELSE <<IF V THEN FLAG(LIST X,'TRST)
		 ELSE REMFLAG(LIST X,'TRST);
		TRSET2(CDR Y,V)>>
      END;

SYMBOLIC PROCEDURE TRSET2(U,!*S!*); 
   IF ATOM U THEN NIL
    ELSE IF CAR U EQ 'QUOTE THEN NIL
    ELSE IF CAR U EQ 'SETQ
     THEN RPLACD(CDR U,
                 IF !*S!*
                   THEN LIST SUBLIS(LIST('VBL . CADR U,
                                         'X . GENSYM(),
                                         'EXP . CADDR U),
                                    '((LAMBDA
                                       (X)
                                       (PROG
                                        NIL
                                        (SETQ VBL X)
                                        (PRIN2 (QUOTE VBL))
                                        (PRIN2 (QUOTE ! !=! ))
                                        (PRIN2 X)
                                        (TERPRI)
                                        (RETURN X)))
                                      EXP))
                  ELSE CDADDR U)
    ELSE FOR EACH J IN U COLLECT TRSET2(J,!*S!*);

SYMBOLIC PROCEDURE TRST U; TRSET1(U,T);

SYMBOLIC PROCEDURE UNTRST U; TRSET1(U,NIL);

DEFLIST('((TRST RLIS) (UNTRST RLIS)),'STAT);

FLAG('(TRST UNTRST),'IGNORE);

%PUT('TRST,'ARGMODE,'(((ARB!-NO SYMBOLIC) TRST . NOVAL)));

%PUT('UNTRST,'ARGMODE,'(((ARB!-NO SYMBOLIC) UNTRST . NOVAL)));


COMMENT EMBED FUNCTIONS;

SYMBOLIC PROCEDURE EMBFN(U,V,W);
   BEGIN SCALAR NNAME,X,Y;
      IF !*DEFN THEN OUTDEF LIST('EMBFN,MKQUOTE U,MKQUOTE V,MKQUOTE W);
      X := GETD U;
      IF NULL X THEN REDERR LIST(U,"NOT DEFINED")
       ELSE IF NOT CAR X MEMQ '(FEXPR FSUBR EXPR SUBR)
	THEN REDERR LIST(U,"NOT EMBEDDABLE");
      NNAME := GENSYM();
      Y := NNAME . X . LIST('LAMBDA,V,SUBST(NNAME,U,W));
      PUT(U,'EMB,Y);
      RETURN MKQUOTE U
   END;

SYMBOLIC PROCEDURE EMBED U;
   %U is a list of function names;
   WHILE U DO
      BEGIN SCALAR TYPE,X,Y;
	X := CAR U;
	U := CDR U;
	Y := GET(X,'EMB);
	IF NULL Y THEN RETURN LPRIM LIST(X,"NOT EMBEDDED");
	PUT(X,'UNEMB,Y);
	REMPROP(X,'EMB);
	TR!-PUTD(CAR Y,CAADR Y,CDADR Y);
	TYPE := IF CAADR Y MEMQ '(FSUBR FEXPR) THEN 'FEXPR ELSE 'EXPR;
	TR!-PUTD(X,TYPE,CDDR Y)
      END;

SYMBOLIC PROCEDURE UNEMBED U;
   WHILE U DO
      BEGIN SCALAR X,Y;
	X := CAR U;
	U := CDR U;
	Y := GET(X,'UNEMB);
	IF NULL Y THEN RETURN LPRIM LIST(X,"NOT EMBEDDED");
	PUT(X,'EMB,Y);
	REMPROP(X,'UNEMB);
	REMD CAR Y;
	TR!-PUTD(X,CAADR Y,CDADR Y)
   END;

DEFLIST('((EMBED RLIS) (UNEMBED RLIS)),'STAT);


END;