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;