(FILECREATED " 7-Aug-86 18:44:57" {ERIS}<LISPCORE>LIBRARY>CMLDEBUG.;5 19088
changes to: (VARS CMLDEBUGCOMS)
(FNS COMMONLISP-BREAKLOOP)
(COMMANDS OK STOP ↑ ~)
previous date: " 6-Aug-86 17:36:18" {ERIS}<LISPCORE>LIBRARY>CMLDEBUG.;3)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLDEBUGCOMS)
(RPAQQ CMLDEBUGCOMS
((* * "CMLDebug - a CommonLisp debugger")
(FILES CMLEXEC)
(FNS BREAKLOOP2 COMMONLISP-BREAKLOOP FIND-COMMONLISP-ENV INTERLISP-BREAKLOOP)
(P (MOVD (QUOTE BREAKLOOP)
(QUOTE \SAVED.BREAKLOOP)))
(FUNCTIONS DEBUG-ON DEBUG-OFF)
(COMMANDS ?= @ BT BT! BTV BTV! CL:EVAL DBT DBT! OK PR RETURN REVERT STOP UB ↑ ~)
(VARS BREAK-COMMANDS)
(PROP FILE-TYPE CMLDEBUG)))
(* * "CMLDebug - a CommonLisp debugger")
(FILESLOAD CMLEXEC)
(DEFINEQ
(BREAKLOOP2
[LAMBDA (NBREAKS) (* hdj "31-Jul-86 18:00")
(DECLARE (SPECIAL *CURRENT-EXECUTIVE-TYPE*))
(if (AND (BOUNDP (QUOTE *CURRENT-EXECUTIVE-TYPE*))
(EQ *CURRENT-EXECUTIVE-TYPE* (QUOTE COMMON-LISP)))
then (COMMONLISP-BREAKLOOP NBREAKS)
else (INTERLISP-BREAKLOOP NBREAKS])
(COMMONLISP-BREAKLOOP
[LAMBDA (NBREAKS) (* hdj " 7-Aug-86 18:41")
(PROG ((TYPE-IN (NULL BRKCOMS))
(HELPFLAG BREAKHELPFLAG)
BRKID BRKVALUES LASTPOS BRKRDBUF BRKBUFS BREAKRESETVALS \BREAKRESETEXPR BRKORIGFLG
BRKLISPXHIST BRKLINE !VALUES \USEBREAKRESETFORMS)
(DECLARE (SPECIAL TYPE-IN BRKFIL HELPFLAG BRKID BRKVALUES LASTPOS BRKRDBUF BRKBUFS
BREAKRESETVALS \BREAKRESETEXPR \USEBREAKRESETFORMS BRKORIGFLG BRKLISPXHIST
BRKLINE !VALUES)) (* ;; "")
(* ;; " HELPFLAG is bound so that calls to ERROR with a NOBREAK of T will not break because the user has set HELPFLAG to BREAK!")
(* ;; "")
(SETQ \USEBREAKRESETFORMS T)
(BREAKRESETFN (QUOTE ENTERING))
(SELECTQ BRKTYPE
(REVERT (AND (LISTP (STKNAME LASTPOS))
(LITATOM BRKFN)
(SETSTKNAME LASTPOS BRKFN)))
(NIL)
(PROGN (* ;;
" Not a user BREAK. the buffers will be restored when the BREAK is left.")
(SETQ BRKRDBUF READBUF)
[SETQ BRKBUFS (CLBUFS (EQ BRKTYPE (QUOTE INTERRUPT]
(SETQ READBUF NIL)
(AND (EQ BRKTYPE (QUOTE ERRORX))
(EQ ERRORN 2)
(SETQ LASTPOS (STKNTH -1 LASTPOS)))(* This to avoid garbage backtraces.)
))
[COND
(ERRORN (* print error message)
(COND
((AND (NUMBERP (CAR ERRORN))
(NEQ (CADDR ERRORN)
(QUOTE help!))) (* normal errorn)
(ERRORMESS ERRORN))
(T (* ERRORN is a list of args to
ERRORMESS1 as from HELP)
(ERRORMESS1 (CAR ERRORN)
(CADR ERRORN)
(CADDR ERRORN]
(if (EQ BRKTYPE (QUOTE INTERRUPT))
then (FORMAT *TERMINAL-IO* "~%%Interrupted below ~S~2%%" BRKFN)
else (if (AND (NULL BRKFN)
(NLISTP BRKTYPE))
then (* ;; "The message (NIL broken) only makes sense for U.D.F. NIL breaks, in which case BRKTYPE is a list. For all others, the message is just %"Breakpoint%"")
(FORMAT *TERMINAL-IO* "~%%Breakpoint~2%%")
else (FORMAT *TERMINAL-IO* "~%%Breakpoint at ~S~2%%" BRKFN)))
(CMLEXEC :PROMPT ": " :COMMANDS BREAK-COMMANDS :ENVIRONMENT (FIND-COMMONLISP-ENV LASTPOS)
:FUNCTION
(FUNCTION (LAMBDA (INPUT ENV)
(LET ((NBREAKS (- NBREAKS)))
(EVAL-INPUT INPUT ENV])
(FIND-COMMONLISP-ENV
[LAMBDA (STACKPOS) (* hdj "31-Jul-86 19:06")
(DECLARE (SPECVARS LASTPOS))
(LET [(POS (STKPOS (QUOTE CL:EVAL)
NIL
(OR STACKPOS LASTPOS]
(AND POS (STKARG 2 POS])
(INTERLISP-BREAKLOOP
[LAMBDA (NBREAKS) (* lmm "26-Jul-86 23:24")
(PROG ((TYPE-IN (NULL BRKCOMS))
(BRKFIL (OR (NULL BRKCOMS)
BRKFILE))
(HELPFLAG BREAKHELPFLAG)
BRKID BRKVALUES LASTPOS BRKRDBUF BRKBUFS BREAKRESETVALS \BREAKRESETEXPR BRKORIGFLG
BRKLISPXHIST BRKLINE !VALUES) (* HELPFLAG is bound so that calls to
ERROR with a NOBREAK of T will not
break because the user has set
HELPFLAG to BREAK!)
(* BRKFIL is used for output only when BRKCOMS are not NIL, e.g.
for tracing. In this case, by setting BRKFILE to the name of a file, the user
can redirect the output to a file.)
[COND
[(AND (NULL BRKFN)
(NLISTP BRKTYPE))
(* The message (NIL broken) only makes sense for U.D.F.
NIL breaks, in which case BRKTYPE is a list.
For all others, the message is just (broken))
(SETQ BRKID (QUOTE (broken]
[(LISTP BRKFN)
(SETQ BRKID (APPEND BRKFN (QUOTE (broken]
(T (SETQ BRKID (LIST BRKFN (QUOTE broken]
(BREAKRESETFN (QUOTE ENTERING))
(SELECTQ BRKTYPE
(REVERT (AND (LISTP (STKNAME LASTPOS))
(LITATOM BRKFN)
(SETSTKNAME LASTPOS BRKFN)))
(NIL)
(PROGN (* Not a user BREAK.
the buffers will be restored when the
BREAK is left.)
(SETQ BRKRDBUF READBUF)
[SETQ BRKBUFS (CLBUFS (EQ BRKTYPE (QUOTE INTERRUPT]
(SETQ READBUF NIL)
(AND (EQ BRKTYPE (QUOTE ERRORX))
(EQ ERRORN 2)
(SETQ LASTPOS (STKNTH -1 LASTPOS)))(* This to avoid garbage backtraces.)
))
(COND
((AND LISPXHISTORY (NEQ CLEARSTKLST T)) (* moved to after LASTPOS is set up)
(SETQ CLEARSTKLST (CONS LASTPOS CLEARSTKLST)) (* In case user control-D's out of the
break, this will RELSTK LASPOS.)
(AND (STACKP BRKTYPE)
(SETQ CLEARSTKLST (CONS BRKTYPE CLEARSTKLST)))
(* occurs on ERRORX breaks. BRKTYPE will be used by the RETFROM that is waiting
to be called with the value returned by BREAK1 as its second argument.)
))
(* BREAKRESETFORMS are a list of forms suitable for use in a rsetform which are
to be executed, bt their execution made transparent to the evaluation of the
break expression. thus they are restored before doing an EVAL, OK, GO, RETURN,
or REVERT, aand then reexecuted when entering or returning into a break.
especially useful for debugging ppograms that fool around with i/o)
(COND
((EQ (CAR BRKCOMS)
(QUOTE TRACE)) (* handle TRACE specially.)
[COND
((NOT (OPENP BRKFIL (QUOTE OUTPUT)))
(OUTPUT (OUTFILE BRKFIL]
(TERPRI BRKFIL)
(BREAK2) (* Indents appropriate number of
spaces.)
(PRIN2 BRKFN BRKFIL T)
(PRINT (QUOTE :)
BRKFIL T)
(SETQ BRKCOMS (CDR BRKCOMS)))
(T (COND
[ERRORN (* print error message)
(COND
((AND (NUMBERP (CAR ERRORN))
(NEQ (CADDR ERRORN)
(QUOTE help!))) (* normal errorn)
(ERRORMESS ERRORN))
(T (* ERRORN is a list of args to
ERRORMESS1 as from HELP)
(ERRORMESS1 (CAR ERRORN)
(CADR ERRORN)
(CADDR ERRORN]
((EQ BRKTYPE (QUOTE INTERRUPT)) (* print the interrupted message)
(PRIN1 (SELECTQ (SYSTEMTYPE)
(D (QUOTE "interrupted below "))
(QUOTE "interrupted before "))
T)
(PRINT BRKFN T T)))
(TERPRI BRKFIL)
(BREAK2)
(PRINT BRKID BRKFIL T)))
LP (SETQ BRKLINE NIL)
[COND
[BRKCOMS (COND
((ERSETQ (BREAKCOM (CAR BRKCOMS)))
(SETQ BRKCOMS (CDR BRKCOMS))
(GO LP]
(T (NLSETQ (PROMPTCHAR (QUOTE :)
T LISPXHISTORY))
(COND
((ERSETQ (PROG (BRKLISPXHIST (LISPXID (QUOTE :))
BRKCOM)
(SETQ BRKCOM (LISPXREAD T T))
(BREAKCOM BRKCOM T)))
(GO LP]
ERROR
(SETQ LISPXBUFS (OR (CLBUFS)
LISPXBUFS)) (* For a CONTINUE command WITHIN this
BREAK.)
(SETQ READBUF NIL) (* We don't worry about saving READBUF
on user induced interruptions, e.g.
control-d control-e since he can
always use REDO or RETRY.)
(SETQ BRKCOMS NIL)
(SETQ BRKFIL T)
(BREAKRESETFN (QUOTE REENTERING)) (* E.g. error occurred inside of an
EVAL or OK, like from a lower break
exited via ↑.)
(PRIN2 BRKID T T)
(TERPRI T)
(GO LP])
)
(MOVD (QUOTE BREAKLOOP)
(QUOTE \SAVED.BREAKLOOP))
(DEFUN DEBUG-ON NIL (/MOVD (QUOTE BREAKLOOP2)
(QUOTE BREAKLOOP)))
(DEFUN DEBUG-OFF NIL (/MOVD (QUOTE \SAVED.BREAKLOOP)
(QUOTE BREAKLOOP)))
(DEFCOMMAND (?= :BREAK) (&REST PLACE) (STKPOZ PLACE)
(PRINT-ARGLIST (SMARTARGLIST (STKNAME LASTPOS)
T)
(STKARGS LASTPOS)
T 0)
(VALUES))
(DEFCOMMAND (@ :BREAK) (&REST PLACE) (LET ((NAME (STKNAME (STKPOZ PLACE))))
(PRINTOUT T "@ = " NAME T))
(VALUES))
(DEFCOMMAND (BT :BREAK) (&OPTIONAL FOO) (BAKTRACE LASTPOS NIL (QUOTE (DUMMYFRAMEP))
0 T)
(VALUES))
(DEFCOMMAND (BT! :BREAK) (&OPTIONAL FOO) (BAKTRACE LASTPOS NIL NIL 0 T)
(VALUES))
(DEFCOMMAND (BTV :BREAK) NIL (BAKTRACE LASTPOS NIL NIL 1 T)
(VALUES))
(DEFCOMMAND (BTV! :BREAK) NIL (BAKTRACE LASTPOS NIL NIL 39 T)
(VALUES))
(DEFCOMMAND (CL:EVAL :BREAK) (&ENVIRONMENT ENV) (UNWIND-PROTECT (PROGN (BREAKRESETFN (QUOTE
EVALUATING
))
(SETQ !VALUES (CL:EVAL BRKEXP
ENV)))
(BREAKRESETFN (QUOTE REENTERING))))
(DEFCOMMAND (DBT :BREAK) NIL (DISPBAKTRACE (WINDOWPROP (TTYDISPLAYSTREAM)
(QUOTE BREAKPOS))
NIL
(QUOTE (DUMMYFRAMEP)))
(VALUES))
(DEFCOMMAND (DBT! :BREAK) NIL (DISPBAKTRACE (WINDOWPROP (TTYDISPLAYSTREAM)
(QUOTE BREAKPOS))
NIL NIL)
(VALUES))
(DEFCOMMAND (OK :BREAK :QUIET) (&ENVIRONMENT ENV) (DECLARE (SPECIAL NBREAKS BRKEXP !VALUES))
(BREAKRESETFN (QUOTE LEAVING))
(LET ((NBREAKS (- NBREAKS)))
(SETQ !VALUES (MULTIPLE-VALUE-LIST
(CL:EVAL BRKEXP ENV))))
(RETAPPLY (QUOTE BREAK1A)
(FUNCTION VALUES-LIST)
(LIST !VALUES)))
(DEFCOMMAND (PR :BREAK) NIL (PROCEED-FROM-BREAK))
(DEFCOMMAND (RETURN :BREAK) (&OPTIONAL (EXPRESSION NIL)
&ENVIRONMENT ENV) (DECLARE (SPECIAL NBREAKS))
(BREAKRESETFN (QUOTE LEAVING))
(LET ((VALUES (MULTIPLE-VALUE-LIST (CL:EVAL
EXPRESSION
ENV))))
(RETAPPLY (QUOTE BREAK1A)
(FUNCTION VALUES-LIST)
(LIST VALUES))))
(DEFCOMMAND (REVERT :BREAK) (&REST PLACE) (LET ((PLACE-SPEC (OR PLACE (QUOTE (@)))))
(STKPOZ PLACE-SPEC)
(RESETFORM (PRINTLEVEL (QUOTE (2 . 3)))
(PRINT (STKNAME LASTPOS)
T T))
(BREAKRESETFN (QUOTE REVERTING))
(BREAKREVERT LASTPOS)))
(DEFCOMMAND (STOP :BREAK :QUIET) NIL (RELSTK LASTPOS)
(AND (STACKP BRKTYPE)
(RELSTK BRKTYPE))
(BREAKRESETFN (QUOTE LEAVING))
(RETEVAL (QUOTE BREAK1A)
(QUOTE (ERROR!))))
(DEFCOMMAND (UB :BREAK) (&OPTIONAL (FN BRKFN)) (DECLARE (SPECIAL BRKFN))
(APPLY (FUNCTION UNBREAK)
FN))
(DEFCOMMAND (↑ :BREAK :QUIET) NIL (RELSTK LASTPOS)
(AND (STACKP BRKTYPE)
(RELSTK BRKTYPE))
(BREAKRESETFN (QUOTE LEAVING))
(RETEVAL (QUOTE BREAK1A)
(QUOTE (ERROR!))))
(DEFCOMMAND (~ :BREAK :QUIET) NIL (RELSTK LASTPOS)
(AND (STACKP BRKTYPE)
(RELSTK BRKTYPE))
(BREAKRESETFN (QUOTE LEAVING))
(RETEVAL (QUOTE BREAK1A)
(QUOTE (ERROR!))))
(RPAQQ BREAK-COMMANDS ((↑ break-↑ :QUIET NIL)
(↑ break-↑ :EVAL NIL)
(OK break-OK :QUIET NIL)
(~ break-~ :QUIET NIL)
(↑ break-↑ :QUIET NIL)
(STOP break-STOP :QUIET NIL)
(@ break-@ :EVAL NIL)
(@ break-@ :EVAL NIL)
(?= break-?= :EVAL NIL)
(?= break-?= :EVAL NIL)
(?= break-?= :EVAL NIL)
(?= break-?= :EVAL NIL)
(@ break-@ :EVAL NIL)
(BT break-BT :EVAL NIL)
(BT! break-BT! :EVAL NIL)
(BTV break-BTV :EVAL NIL)
(BTV! break-BTV! :EVAL NIL)
(CL:EVAL break-CL:EVAL :EVAL NIL)
(DBT break-DBT :EVAL NIL)
(DBT! break-DBT! :EVAL NIL)
(OK break-OK :EVAL NIL)
(PR break-PR :EVAL NIL)
(RETURN break-RETURN :EVAL NIL)
(REVERT break-REVERT :EVAL NIL)
(STOP break-STOP :EVAL NIL)
(UB break-UB :EVAL NIL)
(↑ break-↑ :EVAL NIL)
(~ break-~ :EVAL NIL)))
(PUTPROPS CMLDEBUG FILE-TYPE COMPILE-FILE)
(PUTPROPS CMLDEBUG COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (916 11799 (BREAKLOOP2 926 . 1314) (COMMONLISP-BREAKLOOP 1316 . 4630) (
FIND-COMMONLISP-ENV 4632 . 4931) (INTERLISP-BREAKLOOP 4933 . 11797)))))
STOP