Artifact 9a75ff9ea23fbf5ac4cf795b19553d68ec5df4edf3870fad43c61c936a630824:

• File r30/debug.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6605) [annotate] [blame] [check-ins using] [more...]

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;