(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