(FILECREATED "16-Apr-84 15:16:05" {PHYLUM}<LISPUSERS>TRACEIN.;4 14603
changes to: (FNS WATCH)
(VARS TRACEINVARS)
previous date: "19-Apr-83 11:04:19" {PHYLUM}<LISPUSERS>TRACEIN.;3)
(PRETTYCOMPRINT TRACEINCOMS)
(RPAQQ TRACEINCOMS [(ALISTS * TRACEINALISTS)
(ADVISE * TRACEINADVICE)
(BLOCKS * TRACEINBLOCKS)
(VARS * TRACEINVARS)
(FNS * TRACEINFNS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS
(NLAMA TRACEIN)
(NLAML WATCH-EVAL)
(LAMA])
(RPAQQ TRACEINALISTS ((BREAKMACROS STEP TRACEALL)))
(ADDTOVAR BREAKMACROS [STEP (SETQ BRKVALUE (CONS (SETQ !VALUE (WATCH BRKEXP]
[TRACEALL (SETQ BRKVALUE (CONS (SETQ !VALUE (WATCH BRKEXP T])
(RPAQQ TRACEINADVICE (BREAKIN))
(PUTPROPS BREAKIN READVICE [NIL (BEFORE NIL (OR (LISTP (GETD FN))
(AND (LISTP (GETPROP FN (QUOTE EXPR)))
(UNSAVEDEF FN))
(LOADFNS FN])
(READVISE BREAKIN)
(RPAQQ TRACEINBLOCKS ((TRACEINBLOCK TRACEIN EVL-FIX WATCH-REP EVMATCHER EXPAND-EV EXPAND-EV1
TRACE-CREATE TRACEINX UNWATCH WATCH-EVAL WATCH-EVALHOOK WATCH
(ENTRIES TRACEIN WATCH WATCH-EVAL WATCH-EVALHOOK EVL-FIX UNWATCH)
(BLKAPPLYFNS WATCH-EVAL WATCH-EVALHOOK)
(SPECVARS XPR# INDENT# NOEMBED StepAction))))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: TRACEINBLOCK TRACEIN EVL-FIX WATCH-REP EVMATCHER EXPAND-EV EXPAND-EV1 TRACE-CREATE TRACEINX
UNWATCH WATCH-EVAL WATCH-EVALHOOK WATCH (ENTRIES TRACEIN WATCH WATCH-EVAL WATCH-EVALHOOK
EVL-FIX UNWATCH)
(BLKAPPLYFNS WATCH-EVAL WATCH-EVALHOOK)
(SPECVARS XPR# INDENT# NOEMBED StepAction))
]
(RPAQQ TRACEINVARS (TRACEINALISTS TraceinTable (FORMPRINTER (FUNCTION TRACEINFP))
(VALUEPRINTER (FUNCTION TRACEINVP))
(WATCH-EVALHOOK T)))
(RPAQQ TRACEINALISTS ((BREAKMACROS STEP TRACEALL)))
(RPAQQ TraceinTable ((% " " EXPLAINSTRING "<space> to eval a form you type")
(B "reak")
(E " " EXPLAINSTRING "Eval form silently")
(F " " EXPLAINSTRING "Finish this Break")
(P " " EXPLAINSTRING "PrettyPrint form")
(R " " EXPLAINSTRING "Retry form")
(S " " EXPLAINSTRING "Step On")
(T " " EXPLAINSTRING "Trace Form")
(V " " EXPLAINSTRING "V to Prettyprint Value")
(X " " EXPLAINSTRING "X to set the Exit value")))
(RPAQ FORMPRINTER (FUNCTION TRACEINFP))
(RPAQ VALUEPRINTER (FUNCTION TRACEINVP))
(RPAQQ WATCH-EVALHOOK T)
(RPAQQ TRACEINFNS (EVL-FIX EVMATCHER EXPAND-EV EXPAND-EV1 PRINTUPTO PrintUpTo TRACE-CREATE TRACEIN
TRACEINFP TRACEINVP TRACEINX UNWATCH WATCH-EVAL WATCH-EVALHOOK WATCH
WATCH-REP))
(DEFINEQ
(EVL-FIX
[LAMBDA (EXP PUT-IN)
(PROG (Y NOEMBED)
(SETQ EXP (OR (GETHASH EXP CLISPARRAY)
EXP))
(RETURN (COND
((NLISTP EXP)
(APPEND PUT-IN (LIST EXP)))
[(LITATOM (CAR EXP))
(SETQ Y (GETPROP (CAR EXP)
(QUOTE EVL-FIX)))
(COND
(Y (EXPAND-EV EXP Y PUT-IN))
((EQ (CAR EXP)
(QUOTE WATCH-EVAL))
EXP)
(T (EXPAND-EV EXP [COND
((SELECTQ (CAR EXP)
(GO (QUOTE (LISTP)))
((SETQ SETN SAVESETQ)
(QUOTE (NIL T)))
[COND (QUOTE (TAIL (TAIL T]
((AND OR PROGN PROG1 RPTQ FRPTQ RESETFORM ADD1VAR
SUB1VAR)
(QUOTE (TAIL T)))
[PROG (CONS [for V in (CADR EXP)
collect (COND
((LISTP V)
(QUOTE (NIL T]
(QUOTE (TAIL LISTP]
((FUNCTION *FUNCTION)
(SETQ NOEMBED T)
(QUOTE (LISTP)))
((NLSETQ ERSETQ)
(QUOTE (T TAIL NIL)))
(SELECTQ (QUOTE (T TAIL (NIL TAIL T)
T)))
([LAMBDA LABEL NLAMBDA]
(SETQ NOEMBED T)
(QUOTE (NIL TAIL T)))
NIL))
(T (SELECTQ (FNTYP (CAR EXP))
((SUBR EXPR CEXPR SUBR* EXPR* CEXPR*)
(QUOTE (TAIL T)))
((FEXPR FSUBR CFEXPR FEXPR* FSUBR* CFEXPR*)
(QUOTE (TAIL NIL)))
(PROGN (PRIN1 "Undefined function " T)
(PRIN1 (CAR EXP)
T)
(PRIN1
" - TRACEIN assumes it is a SPREAD LAMBDA"
T)
(TERPRI T)
(QUOTE (TAIL T]
PUT-IN]
((EQ (CAAR EXP)
(QUOTE LAMBDA))
(for X in EXP collect (EVL-FIX X PUT-IN)))
((EQ (CAAR EXP)
(QUOTE NLAMBDA))
(CONS (EVL-FIX (CAR EXP)
PUT-IN)
(CDR EXP)))
(T (PRINT "TRACEIN expects to find a function but finds:" T)
(PRINT (CAR EXP)
T)
EXP])
(EVMATCHER
[LAMBDA (EXP PAT) (* DD: " 1-APR-83 16:33")
(COND
[(ATOM PAT)
(COND
((NULL PAT)
NIL)
((EQ PAT T)
T)
(T (NOT (NOT (APPLY* PAT EXP]
[(ATOM (CAR PAT))
(SELECTQ (CAR PAT)
[TEST (NOT (NOT (EVAL (CADR PAT]
[TAIL (PROG (V)
[PROG NIL
LOOP(COND
([AND (LISTP EXP)
(IGREATERP (LENGTH EXP)
(LENGTH (CDDR PAT]
(SETQ V (CONS (EVMATCHER (CAR EXP)
(CADR PAT))
V))
(SETQ EXP (CDR EXP))
(GO LOOP]
(RETURN (NCONC (DREVERSE V)
(EVMATCHER EXP (CDDR PAT]
(EVAL (EVAL (CADR PAT)))
(COND
[(LISTP EXP)
(CONS (EVMATCHER (CAR EXP)
(CAR PAT))
(EVMATCHER (CDR EXP)
(CDR PAT]
(T (PRIN1 "Tracein warning: missing arguments detected" T)
NIL]
(T (COND
[(LISTP EXP)
(CONS (EVMATCHER (CAR EXP)
(CAR PAT))
(EVMATCHER (CDR EXP)
(CDR PAT]
(T (ERROR "Tracein error: List argument expected"])
(EXPAND-EV
[LAMBDA (EXP PAT PUT-IN)
(SETQ PAT (EVMATCHER (CDR EXP)
PAT))
(SETQ EXP (CONS (CAR EXP)
(EXPAND-EV1 (CDR EXP)
PAT PUT-IN)))
[COND
((NOT NOEMBED)
(SETQ EXP (APPEND PUT-IN (LIST EXP]
EXP])
(EXPAND-EV1
[LAMBDA (EXP PAT PUT-IN) (* DD: " 1-APR-83 16:33")
(COND
((LISTP PAT)
(COND
((NEQ (LENGTH PAT)
(LENGTH EXP))
(PRIN1 "Tracein warning: extra arguments ignored" T)))
(for PAT in PAT as EXP in EXP collect (EXPAND-EV1 EXP PAT PUT-IN)))
(PAT (EVL-FIX EXP PUT-IN))
(T EXP])
(PRINTUPTO
[LAMBDA (Object Limit UsePrin2 IgnoreLst FILE)
(DECLARE (SPECVARS Limit IgnoreLst)) (* DD: "11-FEB-83 13:58")
(PrintUpTo Object UsePrin2 NIL FILE])
(PrintUpTo
[LAMBDA (Object UsePrin2 Tailp FILE) (* DD: "11-FEB-83 13:59")
(COND
((ZEROP Limit))
[(NLISTP Object)
(COND
[Tailp (SELECTQ Limit
(1 (PRIN1 " " FILE)
(SETQ Limit 0))
(2 (PRIN1 " ." FILE)
(SETQ Limit 0))
(PROGN (PRIN1 " . " FILE)
(SETQ Limit (IDIFFERENCE Limit 3))
(PrintUpTo Object UsePrin2 NIL FILE]
(T (PROG ((Size (NCHARS Object UsePrin2)))
(COND
((ILEQ Size Limit)
(APPLY* (COND
(UsePrin2 (FUNCTION PRIN2))
(T (FUNCTION PRIN1)))
Object FILE)
(SETQ Limit (IDIFFERENCE Limit Size)))
(T (PRIN1 (PACK (for i to Limit as Char in (UNPACK Object UsePrin2)
collect Char))
FILE)
(SETQ Limit 0]
((FMEMB (CAR Object)
IgnoreLst)
(PrintUpTo (CADR Object)
UsePrin2 Tailp FILE))
(T (COND
(Tailp (PRIN1 " " FILE))
(T (PRIN1 "(" FILE)))
(SETQ Limit (SUB1 Limit))
(PrintUpTo (CAR Object)
UsePrin2 NIL FILE)
(AND (CDR Object)
(PrintUpTo (CDR Object)
UsePrin2 T FILE))
(OR Tailp (ZEROP Limit)
(AND (PRIN1 ")" FILE)
(SETQ Limit (SUB1 Limit])
(TRACE-CREATE
[LAMBDA (FORM)
(DWIMIFY FORM T)
(CLISPTRAN (OR (GETHASH FORM CLISPARRAY)
FORM)
(EVL-FIX FORM (QUOTE (WATCH-EVAL])
(TRACEIN
[NLAMBDA X
(SETQ X (MKLIST X))
(PROG ((FN (CAR X))
WHEN Trace)
(DECLARE (LOCALVARS . T))
[COND
((LISTP FN)
(SETQ WHEN (CADR FN))
(SETQ FN (CAR FN]
[COND
((EQ T (CADR X))
(SETQ Trace T)
(SETQ X (CDR X]
(RETURN (COND
((NULL (CDR X))
(TRACEINX FN (QUOTE TTY:)
WHEN Trace))
(T (for LOC in (CDR X) collect (TRACEINX FN LOC WHEN Trace])
(TRACEINFP
[LAMBDA (FORM FILE) (* DD: " 1-APR-83 16:38")
(PRINTUPTO FORM [IMAX 20 (IDIFFERENCE (LINELENGTH NIL FILE)
(IPLUS 20 (POSITION FILE]
T
(QUOTE (WATCH-EVAL))
FILE])
(TRACEINVP
[LAMBDA (VAL FILE) (* DD: " 1-APR-83 16:38")
(PRINTUPTO VAL [IMAX 20 (IDIFFERENCE (LINELENGTH NIL FILE)
(IPLUS 20 (POSITION FILE]
T NIL FILE])
(TRACEINX
[LAMBDA (FN WHERE WHEN Trace)
(APPLY* (QUOTE BREAKIN)
FN
(LIST (QUOTE AROUND)
WHERE)
WHEN
(LIST (COND
(Trace (QUOTE TRACEALL))
(T (QUOTE STEP)))
(QUOTE OK])
(UNWATCH
[LAMBDA (XPR)
(COND
[(LISTP XPR)
(COND
((EQ (CAR XPR)
(QUOTE WATCH-EVAL))
(UNWATCH (CADR XPR)))
(T (CONS (UNWATCH (CAR XPR))
(UNWATCH (CDR XPR]
(T XPR])
(WATCH-EVAL
[NLAMBDA (XPR#) (* DD: " 2-APR-83 17:07")
(PROG (!VALUE (INDENT# (IPLUS INDENT# 2)))
(DECLARE (SPECVARS !VALUE INDENT#))
[COND
((EQ StepAction (QUOTE EVAL))
(RETURN (EVAL XPR#]
(SETQ !VALUE (QUOTE NOBIND))
L0 (TAB INDENT# NIL T)
(APPLY* FORMPRINTER XPR# T)
(OR (NLISTP XPR#)
(NULL StepAction)
(TERPRI T))
L1 [COND
((AND (NULL StepAction)
(LISTP XPR#))
(SELECTQ (ASKUSER NIL NIL (COND
((NEQ !VALUE (QUOTE NOBIND))
"<-")
(T "->"))
TraceinTable T)
(% (TERPRI T)
(PRIN1 "eval: " T)
(WATCH-REP)
(GO L1))
(B (BREAK1 NIL T)
(GO L0))
[E (COND
((EQ !VALUE (QUOTE NOBIND))
([LAMBDA (StepAction)
(SETQ !VALUE (EVAL XPR#]
(QUOTE EVAL)))
(T (PRIN1 "Value already exists - do R first" T]
[F (SETQ StepAction (QUOTE EVAL))
(AND (EQ !VALUE (QUOTE NOBIND))
(SETQ !VALUE (EVAL XPR#]
(P (TERPRI T)
(NLSETQ (PRINTDEF (UNWATCH XPR#)
NIL NIL NIL NIL T))
(GO L1))
(R (SETQ !VALUE (QUOTE NOBIND))
(GO L0))
[S (COND
((NEQ !VALUE (QUOTE NOBIND))
(GO L2))
(T (SETQ !VALUE (EVAL XPR#]
[T (COND
((EQ !VALUE (QUOTE NOBIND))
([LAMBDA (StepAction)
(SETQ !VALUE (EVAL XPR#]
T))
(T (PRIN1 "Value already exists - do R first" T]
(V (TERPRI T)
(NLSETQ (PRINTDEF !VALUE NIL NIL NIL NIL T))
(GO L1))
[X (TERPRI T)
(PRIN1 "set exit value: " T)
(NLSETQ (SETQ !VALUE (LISPXEVAL (LISPXREAD T T]
(SHOULDNT)))
(T (SETQ !VALUE (EVAL XPR#]
(OR (NLISTP XPR#)
(TAB INDENT# NIL T))
(PRIN1 " = " T)
(APPLY* VALUEPRINTER !VALUE T)
(OR StepAction (NLISTP XPR#)
(GO L1))
L2 (AND StepAction (TERPRI T))
(RETURN !VALUE])
(WATCH-EVALHOOK
[LAMBDA (XPR#) (* DD: " 2-APR-83 17:07")
(COND
((BOUNDP (QUOTE FormToEval))
(PROG (!VALUE (INDENT# (IPLUS INDENT# 2)))
(DECLARE (SPECVARS !VALUE INDENT#))
(SETQ !VALUE (QUOTE NOBIND))
L0 (TAB INDENT# NIL T)
(APPLY* FORMPRINTER XPR# T)
(OR (NLISTP XPR#)
(NULL StepAction)
(TERPRI T))
L1 [COND
((AND (NULL StepAction)
(LISTP XPR#))
(SELECTQ (ASKUSER NIL NIL (COND
((NEQ !VALUE (QUOTE NOBIND))
"<-")
(T "->"))
TraceinTable T NIL NIL T)
(% (TERPRI T)
(PRIN1 "eval: " T)
(WATCH-REP)
(GO L1))
(B (BREAK1 NIL T)
(GO L0))
[E (COND
((EQ !VALUE (QUOTE NOBIND))
(SETQ !VALUE (EVAL XPR#)))
(T (PRIN1 "Value already exists - do R first" T]
[F (SETQ StepAction (QUOTE EVAL))
(AND (EQ !VALUE (QUOTE NOBIND))
(SETQ !VALUE (EVAL XPR#]
(P (TERPRI T)
(NLSETQ (PRINTDEF XPR# NIL NIL NIL NIL T))
(GO L1))
(R (SETQ !VALUE (QUOTE NOBIND))
(GO L0))
[S (COND
((NEQ !VALUE (QUOTE NOBIND))
(GO L2))
(T (SETQ !VALUE (EVALHOOK XPR# (FUNCTION WATCH-EVALHOOK)))
(SETATOMVAL (QUOTE EVALHOOK)
NIL]
[T (COND
((EQ !VALUE (QUOTE NOBIND))
([LAMBDA (StepAction)
(SETQ !VALUE (EVALHOOK XPR# (FUNCTION WATCH-EVALHOOK)))
(SETATOMVAL (QUOTE EVALHOOK)
NIL]
T))
(T (PRIN1 "Value already exists - do R first" T]
(V (TERPRI T)
(NLSETQ (PRINTDEF !VALUE NIL NIL NIL NIL T))
(GO L1))
[X (TERPRI T)
(PRIN1 "set exit value: " T)
(NLSETQ (SETQ !VALUE (LISPXEVAL (LISPXREAD T T]
(SHOULDNT)))
((EQ StepAction T)
(SETQ !VALUE (EVALHOOK XPR# (FUNCTION WATCH-EVALHOOK)))
(SETATOMVAL (QUOTE EVALHOOK)
NIL))
(T (SETQ !VALUE (EVAL XPR#]
(OR (NLISTP XPR#)
(TAB INDENT# NIL T))
(PRIN1 " = " T)
(APPLY* VALUEPRINTER !VALUE T)
(OR StepAction (NLISTP XPR#)
(GO L1))
L2 (AND StepAction (TERPRI T))
(OR (EQ StepAction (QUOTE EVAL))
(SETATOMVAL (QUOTE EVALHOOK)
(FUNCTION WATCH-EVALHOOK)))
(RETURN !VALUE)))
(T (EVAL XPR#])
(WATCH
[LAMBDA (FormToEval StepAction NoHook)
(DECLARE (SPECVARS StepAction FormToEval)) (* lmm "16-Apr-84 14:37")
(PROG ((INDENT# 0)
VAL)
(DECLARE (SPECVARS INDENT#)
(LOCALVARS VAL))
(TERPRI T)
[SETQ VAL (COND
[(AND (NULL NoHook)
WATCH-EVALHOOK
(GETD (FUNCTION EVALHOOK))
(CCODEP (FUNCTION WATCH-EVALHOOK)))
(PRIN1 "<<evalhook>>" T)
(TERPRI T)
(PROG1 (WATCH-EVALHOOK FormToEval)
(SETATOMVAL (QUOTE EVALHOOK]
(T (PRIN1 "<<watch>>" T)
(TERPRI T)
(EVAL (OR (GETHASH (GETHASH FormToEval CLISPARRAY)
CLISPARRAY)
(GETHASH FormToEval CLISPARRAY)
(TRACE-CREATE FormToEval]
(RETURN VAL])
(WATCH-REP
[LAMBDA NIL (* DD: "11-FEB-83 13:03")
(repeatwhile (LISPXREADP T) do (COND
([LISTP (SETQ $$VAL (NLSETQ (LISPX (LISPXREAD T T)
(QUOTE :]
(SETQ $$VAL (CAR $$VAL)))
(T (PRINT (QUOTE ?)
T])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TRACEIN)
(ADDTOVAR NLAML WATCH-EVAL)
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (2673 14432 (EVL-FIX 2683 . 4570) (EVMATCHER 4572 . 5636) (EXPAND-EV 5638 . 5874) (
EXPAND-EV1 5876 . 6224) (PRINTUPTO 6226 . 6413) (PrintUpTo 6415 . 7587) (TRACE-CREATE 7589 . 7739) (
TRACEIN 7741 . 8196) (TRACEINFP 8198 . 8445) (TRACEINVP 8447 . 8659) (TRACEINX 8661 . 8873) (UNWATCH
8875 . 9079) (WATCH-EVAL 9081 . 11083) (WATCH-EVALHOOK 11085 . 13379) (WATCH 13381 . 14130) (WATCH-REP
14132 . 14430)))))
STOP