(FILECREATED " 8-Aug-86 13:53:41" {ERIS}<LISPCORE>LIBRARY>CMLDEBUG.;6 12343
changes to: (VARS CMLDEBUGCOMS)
(FNS COMMONLISP-BREAKLOOP)
(COMMANDS OK STOP ↑ ~)
previous date: " 7-Aug-86 18:44:57" {ERIS}<LISPCORE>LIBRARY>CMLDEBUG.;5)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLDEBUGCOMS)
(RPAQQ CMLDEBUGCOMS
((* * "CMLDebug - a CommonLisp debugger")
(FILES CMLEXEC)
(P (MOVD (QUOTE BREAKLOOP)
(QUOTE INTERLISP-BREAKLOOP)))
(FNS BREAKLOOP2 COMMONLISP-BREAKLOOP FIND-COMMONLISP-ENV)
(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)
(MOVD (QUOTE BREAKLOOP)
(QUOTE INTERLISP-BREAKLOOP))
(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])
)
(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 (1037 5054 (BREAKLOOP2 1047 . 1435) (COMMONLISP-BREAKLOOP 1437 . 4751) (
FIND-COMMONLISP-ENV 4753 . 5052)))))
STOP