;;AUTOLOAD: kdb
(setq *package* 'kdb)

(defun kdb:debugger-help ()
  (kdb:output "***** kdb help:
h, ?  This help
c     continue
m     print current error message
w     where = stack dump (terse)
W     Whole stack dump, long format + previous variable values
s     steps: do one eval, then re-enter debugger
s <expr> makes current expr returns <exprs>, and steps
n     next: continue and stop a next same-level form
i     info: shows kdb state: current breakpoints, stack frame,...
b <expr>     sets breakpoint to enter debugger when <expr> is true
b <name>     breakpoint at entry in function <name>
b <N>        stop when entering stack frame <N>
d <N> deletes breakpoint <N>
a (or b+)    adds a symbolic breakpoint around the current expression
A (or b-)    disables the current symbolic breakpoint
p <exprs>... prints expressions one per line
p <N> <exprs> prints expressions as evaluated in frame #N
      p can be replaced by <space> and is optional before a (
P same as p but do not use pretty printer pp for printing exprs
r <expr>     makes debugger return the result of evaluating <expr>
R <expr>     replaces top stack frame by expr
q     quit: clears all breakpoint and continue
Q     quit and do not re-enter on error (does a (kdb ()))
(break [expression [condition [data]]]) in source for symbolic breakpoints
"))

;******************************************************** user-settable options
;******************************************************************************

(if (not (boundp '*evalhook*)) (load 'evalhook))

;; useful functions

(if (not (boundp 'default))
  (defunq default (var value)
    (if (not (boundp var)) (set var (eval value)))
))

(defvar symbol-plist object-plist)

;; used to put traces in the code

;(setq DD-on ())
(setq DD-on t)

;; {DD tracing-code [expr]} 
;; expr is a normal code, used to avoid putting a progn around expr
(defunq DD (DD:trace-expr &optional (DD:expr :nil))
  (if DD-on
    (if (= :nil DD:expr)
      DD:trace-expr
      (list 'progn DD:trace-expr DD:expr)
    )
    (if (= :nil DD:expr)
      ()
      DD:expr
)))  

(defun dd (&rest args)
  (apply kdb:print-format (+ 
      (+ "*** " (getn args 0) "\n")
      (subseq args 1)))
)


(default kdb:page-width 79)		; truncate long lines
(setq MaxPageWidth (** 2 30))
(if (not (typep kdb:page-width Int))
  (setq kdb:page-width MaxPageWidth)	; if width nil set to max
)
(default kdb:CR '())		; what does just entering CR

(default kdb:stream-in *standard-input*) ; debuggeur window
(default kdb:stream-out *standard-error*)


;;************************************************ Input/Output Functions
;;***************************************************************************
;;
;; All input and output operations are made with:
;;     - "kdb:read-line" for input,
;;     - "kdb:ouput", "kdb:?", and "kdb:print-format" for output.
;;
;; To redefine I/O operations, just modify the two functions:
;; "kdb:read-line" and "kdb:ouput"
;;

(default kdb:read-line '(lambda () (read-line kdb:stream-in)))
(default kdb:output
  '(lambda (s)
    (with (*print-readably* ())
      (write s kdb:stream-out)))
)

(defun kdb:print-format (&rest args)
  (with (tempStream (coerce "" Stream))
    (apply print-format (append (list tempStream) args))
    (kdb:output (coerce tempStream String))
    )
  )

(defun kdb:? (&rest args)
  (with (tempStream (coerce "" Stream))
    (with (*standard-output* tempStream)
	  (apply ?  args))
    (kdb:output (coerce tempStream String))
    )
  )

;************************************************************ usage & main loop
;******************************************************************************

(defunq break-set (&rest expr)
  (kdb:set-breakpoint expr)
  (setq *evalhook* kdb:evaluator)
  ()
)

(defun break-list ()
  (kdb:info-breakpoint)
  ()
)

(defun break-remove (&rest l)
  (kdb:delete-breakpoint l)
  (if (kdb::breakpoints?)
    (setq *evalhook* kdb:evaluator)
    (setq *evalhook* kdb:old-evaluator)
  )
  ()
)

(defun kdb:debugger (%:errorcode &rest %:args &aux
    (%:top-frame (stack-frame 0))
    (%:frame %:top-frame)
    (%:level 0)
    %:stack-ptr
    %:line
    %:command-char
    %:line-stream
    %:result
    (%:result? ())
    %:previous-command
    %:value-to-eval
  )
  (with (
      *error-handlers* kdb:handler-in-handler
      *print-readably* ()
    )
    (if (/= *evalhook* kdb:evaluator)
      (setq kdb:old-evaluator *evalhook*)
    )
    (if (not (seek '(kdb:Eval Errors:Break kdb:BreakPoint) %:errorcode)
      )
      (progn
	(kdb:? %:errorcode ", entering klone debugger kdb. (? for help)\n")
	(delete kdb:breakpoints 'step)
	(setq kdb:CR '())
      )
      (setq kdb:CR 'kdb:step)
    )
    (kdb:print-error-message kdb:page-width %:errorcode %:args)
    (setq %:result (catch 'Done
	(while t
	  (kdb:output "kdb> " )
	  (if (not (catch 'EOF		; ^D ==> EOF = quit
		(setq %:line (kdb:read-line))
	      )
	    )
	    (kdb:quit)
	  )
	  (setq kdb:Quit-command ())
	  (setq %:command-char (get %:line 0 ()))
	  (setq %:command-line-args-offset 0)
	  (if (= %:command-char #\()
	    (setq %:command-char #\space)
	    (if %:command-char
	      (setq %:command-line-args-offset 1)
	    )
	  )
	  (setq %:command-line (kdb:parse-command-line
	      %:line %:command-line-args-offset))
	  (if
	    
	    (or (= %:command-char #\h)(= %:command-char #\?))
	    (kdb:debugger-help)
	    
	    (= %:command-char ())		; <CR>
	    (progn
	      (kdb:CR)		; dynamically settable
	    )
	    
	    (= %:command-char #\w)	; w=where
	    (kdb:stack-dump 0 0 0)
	    
	    (= %:command-char #\W)	; w=Where
	    (kdb:whole-stack-dump 0 0 0)
	    
	    (= %:command-char #\s)	; s = step
	    (kdb:step)
	    
	    (= %:command-char #\n)	; n = next
	    (if (= %:errorcode 'Errors:Break)
	      (kdb:next t)
	      
	      (kdb:next ())
	    )
	    
	    (= %:command-char #\i)	; i = info
	    (kdb:info-breakpoint)
	    
	    (= %:command-char #\a)	; a = add breakpoint
	    (kdb:add-current-breakpoint)
	    
	    (= %:command-char #\A)	; A = remove breakpoint
	    (kdb:remove-current-breakpoint)
	    
	    (= %:command-char #\c)	; c=continue
	    (kdb:continue)
	    
	    (= %:command-char #\q)	; q=quit
	    (kdb:quit)

	    (= %:command-char #\Q)	; q=quit and do not re-enter
	    (kdb:Quit)
	    
	    (= %:command-char #\r)	; r=return argument
	    (if (getn (symbol-plist %:errorcode) 'correctable)
	      (throw 'Done (get %:command-line 0 ()))
	      (kdb:? "cannot return from error: " %:errorcode "\n")
	    )
	    
	    (= %:command-char #\R)	; r=return argument and replace
	    (kdb:replace-expr (getn %:command-line 0))
	    
	    (= %:command-char #\m)	; m=error message
	    (kdb:print-error-message MaxPageWidth %:errorcode %:args)
	    
	    (= %:command-char #\d)	; d=delete breakpoint
	    (kdb:delete-breakpoint %:command-line)
	    
	    (= %:command-char #\b)	; b=set breakpoint
	    (kdb:set-breakpoint %:command-line)
	    
	    (or (= %:command-char #\p)
	      (= %:command-char #\P)
	      (= %:command-char #\space)) ; p=print
	    (kdb:print-command %:command-line)
	    
	    (kdb:? "Unknown kdb command. "
	      "type ? or h for in-line help, q to resume computing\n")
	  )
	  (setq %:previous-command %:command-char)
	  (setq kdb:CR ())
	)
	:true
    ))
  )
  (if (kdb::breakpoints?)
    (setq *evalhook* kdb:evaluator)
    (setq *evalhook* kdb:old-evaluator)
  )
  (if (seek		; step & break return a value
      '(kdb:Eval Errors:Break kdb:BreakPoint) %:errorcode)
    (progn
      	; return value overriden
      (setq %:value-to-eval (if (= %:result :true)
	  (get kdb::args 0 ())
	  kdb::result)
      )
      (setq %:result (evalhook %:value-to-eval))
					; print return value
      (%print-format-truncated %page-width kdb:Result %:result
	%:stack-level %:value-to-eval)
    )
  )
  (if kdb:Quit-command (kdb ()))
  %:result
)

;************************************************************************ INITS
;******************************************************************************

;; kdb:breakpoints: p-list of monitored events by the kdb:evaluator
;;    'step    is the stepper active?
;;    'conditions what are the conditional tests active?

(if (not (boundp 'kdb:old-error-handler)) (progn
    (defun %:FF (n p) (+ "[" (coerce n String) "/" (coerce p String) "]"))
    (setq kdb:old-error-handler *error-handlers*)
    (setq kdb:tmpstring "")
    (defun kdb:reset-tmpstream ()
      (setq kdb:tmpstream (open kdb:tmpstring
	  :type :string :direction :output :if-exists :supersede
    )))
    (setq kdb:atom-equal (intern " = "))	; printing aids
    (setq kdb:atom-newline (intern "\n"))
    
    (defmacro %print-readably (&rest args)
      `(with (*print-readably* t) (kdb:? ,@args)))
    (setq kdb:error-text "")
    (setq kdb:Eval   "[%1> %r0")
    (setq kdb:Result "<%1] %r0 <== %r2\n")
    (setq kdb:BreakPoint "Breakpoint %2 (returned %1): evaluating %0")
    (setq kdb:old-evaluator *evalhook*)
    (setq kdb:breakpoints (list 'break (list) 'Frame (list)))
    (setq kdb::printing-depth 0)	; for prints up into the stack
    (setq kdb:do-not-step-into	; types self-evaluating 
      (coerce (list Expr t FExpr t Subr t FSubr t Macro t
	  Int t Real t String t Regexp t Keyword t Link t
	  Type t Stream t Hashtable t Collection t
	)
	Hashtable
      )
    )
    (if (boundp 'ExObject)
      (dohash (type v (list ExObject t ExClass t GenericFunction t))
	(put kdb:do-not-step-into type v)
    ))

    (setq %:MinLevel 1000000000)
    (setq %:stack-level 0)
    (setq kdb:Errors:Break-old Errors:Break)
    (setq Errors:Break 'kdb:Errors:Break-lambda)

    (if (not (boundp 'kdb:steppable-types))
      (setq kdb:steppable-types (list))
    )
    (nconc kdb:steppable-types (list Atom List Constant Active))

    (setq kdb:B:n 0)

    (put (symbol-plist 'Errors:Break) 'correctable t)
    (put (symbol-plist 'Errors:ErrorCannotLoadFile) 'correctable t)
    (put (symbol-plist 'Errors:UndefinedFunction) 'correctable t)
    (put (symbol-plist 'Errors:UndefinedVariable) 'correctable t)
    (put (symbol-plist 'Errors:NoCoercion) 'correctable t)

))

;************************************************************* code of commands
;******************************************************************************


(defun kdb:print-command (%:line &aux (%:use-pp t))
  (if (= %:command-char #\P) (setq %:use-pp ()))
  (setq %:command-char #\p)
  (if (and (> (length %:line) 1)
      (typep (get %:line 0 ()) Int)
    )
    (progn				; then we set the printing depth
      (setq %:printing-depth (abs (get %:line 0 ())))
      (setq %:line (subseq %:line 1))
    )
    (if (/= %:command-char #\p)
      (setq %:printing-depth 0)
    )
  )
  
  (map () (lambda (%:e &aux
	(%:last-error t)
	%:print-result
	%:eval-e
	(*print-readably* ())
      )
      (setq %:print-result
	(catch 'ALL
	  (setq %:eval-e (if (= 0 %:printing-depth)
	      (eval %:e)
	      (kdb:eval-at-stack-level kdb::e %:printing-depth)
	  ))
	  (%print-readably %:e)
	  (kdb:? kdb:atom-equal)
	  (if (and (typep %:eval-e Function) %:use-pp)
	    (pp %:eval-e)
	    (%print-readably %:eval-e)
	  )
	  (kdb:? kdb:atom-newline)
	  (setq %:last-error ())))
      (if %:last-error
	(if (= *last-caught-tag* 'ERROR)
	  (kdb:? "ERROR: " kdb:error-text)
	  (kdb:? %:e " ===> Throwed " %:print-result
	    " to tag: " *last-caught-tag* "\n")
      ))
    )
    %:line)
))

(defun kdb:info-breakpoint (&aux
    (bl (get kdb:breakpoints 'break ()))
    (fl (get kdb:breakpoints 'Frame ()))
    (num 0)
    bp
  )
  (if (/= 0 %:printing-depth)
    (kdb:print-format "Current stack frame: [%0]\n" %:printing-depth)
  )
  (if bl
    (kdb:output "Current Breakpoints:\n")
    (kdb:output "No Breakpoints set.\n")
  )
  (dolist (bp bl)
    (kdb:print-format  "[%0] %r1\n" num bp)
    (setq num (+ num 1))
  )
  (if fl
    (progn
      (kdb:print-format
	"Stop on entering frames (current = %0): "
	(%:FF 0 (kdb:current-frame-num))
      )
      (dolist (bp fl)
	(kdb:? (%:FF (kdb:internal-to-frame-num bp) bp) " ")
      )
      (kdb:output "\n")
  ))
  (dotimes (num kdb:B:n)
    (with
      (symb (intern (+ "B:" (coerce (+ num 1) String ))))
      (if (and (boundp symb) symb (> (kdb:ref symb) 5))
	(kdb:print-format "Symbolic breakpoint %0 set\n" symb)
  )))
)

(defun kdb:delete-breakpoint (l &aux
    (bl (get kdb:breakpoints 'break ()))
  )
  (dolist (num l)
    (if (typep num Int)
      (delete bl num)
)))
    
(defun kdb:set-breakpoint (l &aux
    (bl (get kdb:breakpoints 'break ()))
  )
  (dolist (bp l)
    (if (typep bp Int)
      (kdb:frame bp)
      
      (or (eq bp '+)(eq bp '=)(eq bp '.))
      (kdb:add-current-breakpoint)

      (eq bp '-)
      (wbd:remove-current-breakpoint)

      (progn
	(put bl -1 bp)
	(kdb:print-format "[%0] %r1\n" (- (length bl) 1) bp)
))))

(defun kdb:replace-expr (kdb:expr &aux
    (Frame (stack-frame 0))
    (curexpr (getn Frame 0))
  )
  (if (and (typep curexpr List) (typep kdb:expr List)) (progn
      (kdb:print-format "replacing %0 by %1\n"
	curexpr kdb:expr
      )
      (replace-list curexpr kdb:expr)
    )
    (kdb:print-format "Error: R command can only replace a list by a list\n")
))

(defun kdb:add-current-breakpoint (&aux
    (Frame (stack-frame 0))
    (curexpr (getn Frame 0))
    (dsymb (intern (+ "B:" (coerce (setq kdb:B:n (+ kdb:B:n 1)) String ))))
  )
  (set dsymb t)
  (if (and (typep curexpr List) (= 'break (getn curexpr 0)))
    (if (and (typep (getn curexpr 2) Atom)
	(match "B:[0-9]+" (getn curexpr 2))
      )
      (progn
	(set (getn curexpr 2) ())
	(setq kdb:B:n (- kdb:B:n 1))
	(kdb:print-format "symbolic breakpoint %0 enabled\n" (getn curexpr 2))
      )
      (kdb:print-format "symbolic breakpoint %0 added\n" dsymb
	(put curexpr 2 dsymb)
      )
    )
    (with (new-expr (copy curexpr)
      )
      (replace-list curexpr (list 'break new-expr dsymb))
      (kdb:print-format "symbolic breakpoint %0 added\n" dsymb)
)))

(defun kdb:remove-current-breakpoint (&aux
    (Frame (stack-frame 0))
    (curexpr (getn Frame 0))
  )
  (if (and (typep curexpr List) (= 'break (getn curexpr 0)))
    (if (and (typep (getn curexpr 2) Atom)
	(match "B:[0-9]+" (getn curexpr 2))
      )
      (progn
	(set (getn curexpr 2) ())
	(kdb:print-format "symbolic breakpoint %0 disabled\n" (getn curexpr 2))
      )
      (progn
	(put curexpr 2 ())
	(kdb:output "breakpoint disabled\n")
      )
)))



(defunq kdb:stack-dump (errorcode &rest args &aux
    (Frame (stack-frame 0))
    (level 0)
    stack-ptr
    line
  )
  (while Frame
    (with (kdb:cut-stream (coerce "" Stream))
      (print-format kdb:cut-stream "[%0] %r1" level (get Frame 0 ()))
      (setq level (+ level 1))
      (setq Frame (stack-frame (get Frame 2 ())))
      (kdb:print-truncated-to-page-width (coerce kdb:cut-stream String))
)))

(defunq kdb:whole-stack-dump (errorcode &rest args &aux
    (%:Frame (stack-frame 0))
    (%:level 0)
    %:stack-ptr
    %:vars
    %:i
  )
  (while %:Frame
    (kdb:? (%:FF %:level (getn %:Frame 1)) " ")
    (%print-readably (get %:Frame 0 ()))
    (kdb:output "\n")
    (setq %:vars (get %:Frame 3 ()))
    (setq %:i 0)
    (while (get %:vars %:i ())
      (kdb:? (if (< %:level 10) "  " (< %:level 100) "   " (< %:level 1000) "    "
	  (< %:level 10000) "     " "      ")
	"| " (get %:vars %:i ()) " = " (get %:vars (+ 1 %:i) ()) "\n")
      (setq %:i (+ 2 %:i))
    )
    (setq %:level (+ %:level 1))
    (setq %:Frame (stack-frame (get %:Frame 2 ()))))
  ()
)

(defun kdb:frame-num-to-internal (n &aux
    (Frame (stack-frame 0))
    (level 0)
  )
  (catch 'Found
    (while Frame
      (if (= n level)
	(throw 'Found  (getn Frame 1))
	(progn
	  (setq level (+ level 1))
	  (setq Frame (stack-frame (get Frame 2 ())))
)))))

   
(defun kdb:internal-to-frame-num (n &aux
    (Frame (stack-frame 0))
    (level 0)
  )
  (catch 'Found
    (while Frame
      (if (= n (getn Frame 1))
	(throw 'Found level)
	(progn
	  (setq level (+ level 1))
	  (setq Frame (stack-frame (get Frame 2 ())))
)))))

   

(defun kdb:eval-at-stack-level (%:expr %:at &aux
    (%:frame (stack-frame 0))
    (%:level 0)
    %:stack-ptr
    %:vars
    %:i
    (%:with-list (list))
  )
  (while (and %:frame (< %:level %:at))
    (setq %:vars (get %:frame 3 ()))
    (setq %:i 0)
    (while (get %:vars %:i ())
      (put %:with-list -1 (get %:vars %:i ()))
      (put %:with-list -1 `(quote ,(get %:vars (+ %:i 1) ())))
      (setq %:i (+ 2 %:i))
    )
    (setq %:level (+ %:level 1))
    (setq %:frame (stack-frame (get %:frame 2 ()))))
  (if (/= %:level %:at)
    (with (*print-readably* ())
      (kdb:? "kdb: frame # " %:at " doesn't exist, printing at upmost frame # "
	%:level ":\n")
      (setq %:printing-depth %:level)
  ))
  (with-eval %:with-list (eval %:expr))
)))

(defun kdb:print-error-message (kdb:page-width errorcode args &aux
    curfunc
    (*print-readably* ())
  )
  (if (not (boundp 'kdb:in-file?)) (setq kdb:in-file? (loadinfo)))
  (with (kdb:cut-stream (coerce "" Stream)
      goto-line ()
    )
    (if kdb:in-file?
      (progn
	(kdb:print-format "\"%0\", line %1: "
	  (get kdb:in-file? 0 ()) (get kdb:in-file? 1 ()))
	(setq goto-line t)
	(setq kdb:in-file? ())		;print file pos only once
      )
    )
    (if (and (/= errorcode 'kdb:Eval)
	(/=  errorcode 'Errors:Break)
      )
      (progn
	(setq curfunc (kdb:current-function))
	(if curfunc (progn
	    (kdb:print-format "In function: %0 " curfunc)
	    (setq goto-line t)
	))
      )
    )
    (if goto-line
      (kdb:output "\n")
    )
    (eval `(print-format kdb:cut-stream (eval errorcode)
	,@(map List (lambdaq (x) `(quote ,x)) args))
    )

    (write kdb:atom-newline kdb:cut-stream)

    (kdb:print-truncated-to-page-width (coerce kdb:cut-stream String))
))

(defun kdb:step ()
  (put kdb:breakpoints 'step %:MinLevel)
  (setq kdb:CR 'kdb:step)
  (if %:command-line
    (if (getn (symbol-plist %:errorcode) 'correctable)
      (throw 'Done (get %:command-line 0 ()))
      (kdb:? "cannot return from error: " %:errorcode "\n")
    )
    (throw 'Done :true)
  )
)

;; (break) ==> alone = t
;; (break expr) ==> alone = ()
;; difference in behavior on next
(defun kdb:next (alone)
  (put kdb:breakpoints 'step (if alone (+ %:stack-level 1) %:stack-level))
;;{DD (dd "NEXT: set step to %0 (%:stack-level = %1, alone = %2, %:args = %3, %:errorcode = %4)"
;;  kdb:breakpoints %:stack-level alone %:args %:errorcode)}
(if %:command-line
    (throw 'Done (get %:command-line 0 ()))
    (throw 'Done :true)
  )
)

(defun kdb:frame (frameu &aux
    frame-to-stop
    (cf (stack-frame 0))
    (not-found t)
    Frame
  )
  (if (<= frameu 0) (setq frameu (kdb:next-frame-num)))
  (setq Frame (kdb:frame-num-to-internal frameu))
  (if (not Frame)
    (setq cf ())
  )
  
  (while (and cf not-found)
    (if
      (< (get cf 1 ()) Frame)
      (progn
	(kdb:? "No such frame: [" Frame "], using [" (get cf 1 ()) "]\n")
	(setq Frame (get cf 1 ()))
	(setq not-found (setq cf ()))
      )
      (= (get cf 1 ()) Frame)
      (setq not-found (setq cf ()))
      (setq cf (stack-frame (get cf 2 ())))
  ))
  (if not-found
    (kdb:? "Frame too deep: [" Frame "], not set\n")
    (if (not (seek (get kdb:breakpoints 'Frame ()) Frame))
      (put (get kdb:breakpoints 'Frame ()) -1 Frame)
    )
))

(defun kdb:quit ()
  (setq kdb:breakpoints (list 'break (list) 'Frame (list)))
  (throw 'Done :true)
)

(defun kdb:Quit ()
  (setq kdb:breakpoints (list 'break (list) 'Frame (list)))
  (setq kdb:Quit-command t)
  (throw 'Done :true)
)

(defun kdb:continue ()
  (put kdb:breakpoints 'step ())
  (throw 'Done :true)
)

(defun kdb:Errors:Break-lambda (expr cond val &optional data &rest args)
  (if (not (and (= cond t)(= val ())))
    (if data
      "* break on %0, condition %1 became %2 [%3]"
      "* break on %0, condition %1 became %2"
    )
    (if expr
      "* break on %0"
      "* break"
  ))
)

;******************************************************************** evaluator
;******************************************************************************

; the run-time evalutor, in charge of performing tests on each eval

(defunq kdb:evaluator (kdb::expr)
  (with (kdb::result ()
      *error-handlers* '(kdb:debugger)
      kdb::level-to-stop ()
      kdb::bl (get kdb:breakpoints 'break ())
      kdb::fl (get kdb:breakpoints 'Frame ())
      kdb::break-value ()
      kdb::fn ()
      kdb::stop-in-frame ()
      %:n ()
      %:stack-level (+ 1 %:stack-level)
    )
    
    (catch 'Evaluated
      (if kdb::fl (progn		; stop in frame examined
	  (setq kdb::fn (kdb:current-frame-num))
	  (setq %:n (length kdb::fl))
	  (while (> %:n 0)
	    (setq %:n (- %:n 1))
	    (if (<= kdb::fn (get kdb::fl %:n ())) (progn
		(kdb:print-format 
		  "Entering frame %0, breakpoint was set at %1 frame\n"
		  (%:FF
		    (kdb:internal-to-frame-num kdb::fn)
		    kdb::fn
		  )
		  (if (= (getn kdb::fl %:n) kdb::fn)
		    "this"
		    (%:FF "-" (getn kdb::fl %:n))
		))
		(setq kdb::stop-in-frame t)
		(delete kdb::fl %:n)	; delete entered frames
      )))))
      
      (dolist (kdb::bp kdb::bl)	;look for breakpoints
	
	(if				; examine types of breakpoints
	  (typep kdb::bp Atom)	; ATOMS: entry in function
	  (if (and (typep kdb::expr List) (= kdb::bp (get kdb::expr 0 ())))
	    (throw 'Evaluated
	      (apply kdb:debugger
		(list 'kdb:BreakPoint kdb::expr
		  kdb::bp "current-function"))
	  ))	  
	  
					; REST: evaluate conditionals
	  (setq break-value (kdb:eval-safe kdb::bp))
	  (throw 'Evaluated
	    (apply kdb:debugger
	      (list 'kdb:BreakPoint kdb::expr
		kdb::break-value kdb::bp))
      )))
					;step and next breakpoints	
      (if (setq kdb::level-to-stop
	  (get kdb:breakpoints 'step ()))
	(progn
	  (setq kdb::result
	    (if
	      (> %:stack-level kdb::level-to-stop) ; next
	      (throw 'Evaluated		;no stop
		(evalhook kdb::expr)
	      )
	      
	      (if (%is-steppable kdb::expr)
;;		(progn (dd "STEP: %:stack-level = %0" %:stack-level)
		(throw 'Evaluated		;stop
		  (apply kdb:debugger
		    (list 'kdb:Eval kdb::expr
		      %:stack-level kdb::level-to-stop))
		)
;;	      )
		(throw 'Evaluated		;no stop
		  (evalhook kdb::expr)
		)
	      )
	    )
	  )
	  
	  (print-format-truncated kdb:page-width kdb:Result
	    kdb::result %:stack-level kdb::expr)
	  kdb::result
      ))
      
      (if kdb::stop-in-frame		; stop due to entry in frame
	(throw 'Evaluated 
	  (apply kdb:debugger
	    (list 'kdb:Eval kdb::expr kdb::fn kdb::fn))
      ))      
      
      (evalhook kdb::expr)
)))
  
(defun kdb:eval-safe (kdb::expr &aux kdb::res kdb::noerr)
  (catch 'ALL (setq kdb::res
      (eval kdb::expr))
    (setq kdb::noerr t))
  (if kdb::noerr
    kdb::res
))

;; is there nothing more to do?

(defun kdb::breakpoints? ()
  (or
    (get kdb:breakpoints 'break ())
    (get kdb:breakpoints 'Frame ())
    (get kdb:breakpoints 'step ())
))      
 
;******************************************************************* misc utils
;******************************************************************************

(defun kdb:is-steppable (expr)
  (if (seek kdb:steppable-types (type-of expr))
    (if (or (= () expr) (= t expr))
      ()
      t
    )
    ()
))

(defun kdb:current-frame-num ()
  (get (stack-frame 0) 1 ())
)

(defun kdb:next-frame-num ()
  (get (stack-frame 0) 2 ())
)


(defun kdb:do-print-result (kdb:result kdb:expr)
  (with (
      *error-handlers* kdb:handler-in-handler
      *print-readably* ()
      )
	(kdb:print-format "<< %r0 <== %1\n" kdb:result kdb:expr)
	)
  )

    
(defun kdb:print-truncated-to-page-width (line &aux
    pos
  )
  (if (> (length line) kdb:page-width)
    (kdb:? (subseq line 0 kdb:page-width) "\n")
    (progn
      (kdb:? line)
      (if (/= #\newline (get line -1 ()))
	(kdb:output "\n")
    ))
  )
)

(defun kdb:parse-command-line (s offset &aux
    (result (list))
    (line-stream (open s :type :string))
  )
  (setq *last-caught-tag* ())
  (catch 'ALL
    (file-position line-stream offset 0)
    (while t
      (put result -1 (read line-stream))
  ))
  (if (= *last-caught-tag* 'ERROR)
    (kdb:? "kdb command error: " kdb:error-text)
  )
  result
)
  
(defunq kdb:handler-in-handler (errorcode &rest args)
  (setq xx errorcode)
  (with (*error-handlers* '(kdb:null-handler)
      kdb:stream-out (open kdb:error-text
	:type :string  :direction :output :if-exists :supersede)
      kdb:current-function ()
    )
    (kdb:print-error-message 10000 errorcode args)
;    (with (*standard-output* kdb:stream-out
;	*print-readably* ()
;	*:dsp 0
;      )
;      (kdb:whole-stack-dump errorcode args)
;    )
    (setq kdb:last-error errorcode)
  )
  :true
)

(defunq kdb:null-handler (errorcode &rest args)
  :true
)

(defun kdb:print-format-truncated (kdb:page-width format &rest args)
  (with (%:trace-tmpstream (coerce "" Stream))
    (apply print-format (+ (list %:trace-tmpstream format) args))
    (kdb:print-truncated-to-page-width (coerce %:trace-tmpstream String))
))

;; current-function

(defun kdb:current-function (&aux
    (Frame (stack-frame 0))
  )
  (while (and Frame (not (get Frame 0 ())))
    (setq Frame (stack-frame (get Frame 2 ())))
  )
  (get (get Frame 0 ()) 0 ())
)
 
;; the reference count of an object

(defunq kdb:ref (kdb:ref:adr &aux
    (kdb:ref:ptr-to (C:& (eval kdb:ref:adr)))
  )
  (C:* (+ C:ptr-size kdb:ref:ptr-to) Int)
)

;********************************************************************** tracing
;******************************************************************************

(defunq kdb:traceall (%:e &aux %:result)
  (with (kdb:trace-level (+ kdb:trace-level 1)
      %:line ()
      %:trace-tmpstream (coerce "" Stream)
    )
    (print-format %:trace-tmpstream "%0> %1 ==> %r2\n"
      kdb:trace-level %:e (setq %:result (evalhook %:e))
    )
    
    (kdb:print-truncated-to-page-width (coerce kdb:cut-stream String))
  )
  %:result
)
  
(setq kdb:trace-level -1)

(defun traceon ()
  (setq *evalhook* kdb:traceall)
  t
)

(defun traceoff ()
  (setq *evalhook* ())
)

;************************************************************************* Done
;******************************************************************************

(defun kdb (&optional (on :nil))
  (if
    (= :nil on) (progn			; (kbd) ==> enters debugger
      (kdb t)
      (break)
    )
    
    (= t on)				; (kdb t) ==> arms debugger
    (if (/= *error-handlers* '(kdb:debugger)) (progn
	(setq kdb:old-error-handler *error-handlers*)
	(setq *error-handlers* '(kdb:debugger))
    ))
    
    (= () on)				; (kdb ()) ==> disarms debugger
    (if (not (or (/= *error-handlers* '(kdb:debugger))
	  (not (boundp 'kdb:old-error-handler))
      ))
      (setq *error-handlers* kdb:old-error-handler)
)))

(kdb t)

;;; DEBUG
(setq kdb:null-handler kdb:old-error-handler)

;************************************************************************** EOF
