;;AUTOLOAD: dbtk
;;=============================================================================
;;################### DBTK - debugtoolkit #####################################
;;=============================================================================
;; DBTK is a low-level layer intended to build high-level debuggers on top
;; of it. See sdb.kl for an exemple.
;; part of these functions may be implemented later in C for speeding up
;; operation
;;
;; PRINCIPLES
;; * all functions print on dbtk:out (defaults to *standard-error*)
;; * all interactive functions read a line by the dbtk:read-line function
;;   (defaults to read-line), which defaults to reading in dbtk:in
;;   (defaults to *standard-input*)
;; * most functions use print-margin, set print-margin:width to something
;;   else than 79 if needed


(require 'print-margin)
(require 'defstruct)

(provide 'dbtk)
(setq *package* 'dbtk)

(defvar dbtk:out *standard-error*)
(defvar dbtk:read-line (lambda () (read-line dbtk:in))) ;can be redefined
(defvar dbtk:in *standard-input*)	;can be redefined

;; private values

(setq dbtk:re-private-var (regcomp "^dbtk:")) ;dont print those!
(setq dbtk:eval-break apply)

;;=============================================================================
;;                    emulation of obsolete break function
;;=============================================================================
;;AUTOLOAD: break

(defunq break (&optional break:expr (break:condition t) break:data)
  (dbtk:break break:expr 'break break:data (list break:condition))
)

;;=============================================================================
;;                    printing functions
;;=============================================================================

;; dbtk:print-error-message
;; prints an error message the "natural" way
;; should be given the parameters of the error
;; optional arg frame is the frame the current function is at
;; Global variable dbtk:print-error-message:terse, if set to t do not print 
;; file/func info

(defvar dbtk:print-error-message:terse ())

(defun dbtk:print-error-message (errorcode args &optional frame &aux
    (in-file? (loadinfo))
    curfunc
    (*print-readably* ())
    goto-line
  )
  (if (not dbtk:print-error-message:terse) (progn
      (if in-file? (progn
	  (print-margin dbtk:out "\"%0\", line %1: "
	    (get in-file? 0 ()) (get in-file? 1 ()))
	  (setq goto-line t)
      ))
      
      (if (and (/= errorcode 'kdb:Eval) (/=  errorcode 'Errors:Break)
	  (/=  errorcode 'Errors:DbtkBreak)
	)
	(progn
	  (setq curfunc (dbtk:current-function frame))
	  (if curfunc (progn
	      (print-margin dbtk:out "In function: %0 " curfunc)
	      (setq goto-line t)
      ))))
      (if goto-line (write-line ""))
      (setq goto-line t)
  ))
  
  (if (=  errorcode 'Errors:DbtkBreak)
    (if					; the break errors, complex case
      (= 'watch (1 args))
      (dbtk:print-error-message-watch errorcode args)
      
      (= 'break (1 args)) (progn
	(print-margin dbtk:out "** break %0 on %1" (if (2 args) (2 args) "")
	  (0 args)
	)
	(if (/= '(t) (3 args))
	  (print-margin dbtk:out "\n%0 was returned by: %1" (5 args)
	    (getn (3 args) (4 args))
      )))
      
      (= '(t) (3 args)) 
      (if (1 args) 
	(print-margin dbtk:out "Breakpoint encountered: %0" (1 args))
	(setq goto-line ())
      )
      (print-margin dbtk:out
	"Breakpoint encountered: %0, cond #%1 evaluated to %l2"
	(1 args) (4 args) (5 args)
    ))
    (apply print-margin (+ (list dbtk:out (eval errorcode)) args))
  )
  (if goto-line (write-line "" dbtk:out))
)

;; special function for the watch case

(defun dbtk:print-error-message-watch (errorcode args &aux
    (expr (0 args))
    (tag (1 args))
    (what (2 args))
    (conditions (3 args))
    (cond-num (4 args))
    (cond-val (5 args))
    (bp (cond-num dbtk:watchpoints-bp))
  )
  ;; do not print anything for step and next
  (if 
    ;; entering/leaving a step or next
    (or (= 'step (dbtk:BP-tag bp)) (= 'next (dbtk:BP-tag bp)))
    (if (eq expr what)			;enter
      (print-margin dbtk:out "  [%0> ==> %l1" *:stackptr expr)
      (print-margin dbtk:out "  <%0] %l1 <== %l2" 
	*:stackptr dbtk:result
	(if (and (typep what List) (= 'dbtk:breakq (0 what)) (eq () (1 what)))
	  'breakpoint what
    )))
    
    ;; entering/leaving some frame
    (and (typep (dbtk:BP-tag bp) String)
      (match "frame#" (dbtk:BP-tag bp))) 
    (print-margin dbtk:out "Breakpoint [%0] : entering %1"
      (dbtk:BP-number bp) (dbtk:BP-tag bp)
    )
    
    ;; breakpoint on function entry
    (= (dbtk:BP-tag bp) 'func)
    (print-margin dbtk:out "Breakpoint [%0] : entering function %1"
      (dbtk:BP-number bp) what
    )
    
    what
    (if (eq expr what)
      (print-margin dbtk:out "Breakpoint [%0] before evaluating %l1"
	(dbtk:BP-number bp) what
      )
      (print-format dbtk:out 
	"Breakpoint [%0] after evaluating %l1, which returned: %2"
	(dbtk:BP-number bp) what dbtk:result
    ))
    
    (print-format dbtk:out "Breakpoint [%0], condition %1 became %2"
      (dbtk:BP-number bp) (cond-num conditions) cond-val
)))

;; find the current function, optionally down from some frame

(defun dbtk:current-function (&optional frame)
  (if (not frame) (setq frame (stack-frame 0)))
  (while (and frame (not (get frame 0 ())))
    (setq frame (stack-frame (get frame 2 ())))
  )
  (get (get frame 0 ()) 0 ())
)

;; print stack in a default way from the output of dbtk:dump-stack

(defun dbtk:print-stack-dump (sd &key whole vars &aux
    local-vars
    varnums
    (level 0)
    (varlist (list))
  )
  (dolist (frame sd)
    (if whole (progn
	(print-margin dbtk:out "[%0]<%1>  %l2\n" level
	  (getn frame 1) (getn frame 0))
	(setq local-vars (getn frame 3))
	(setq varnum 0)
	(dohash (var val local-vars)
	  (if (not (regexec dbtk:re-private-var var))
	    (print-margin dbtk:out "%0| %1 was: %l2\n"
	      (make-string (+ 1 (length (String level)))) var
	      (if (boundp 'val) val '*undefined*) ;trick to access val if undef!
	  ))
	  (if (and vars (not (seek varlist var)))
	    (append-to-list varlist var))
	  (incf varnum)
	)
      )
      (print-margin dbtk:out "[%0] %l1\n" level (getn frame 0))
    )
    (incf level)
  )
  (if (and vars varlist) (progn				;print current values
      (print-format dbtk:out
	"==|== current value of local variables: ===========================\n")
      (incf level -1)
      (dolist (var varlist)
	(if (not (regexec dbtk:re-private-var var))
	  (print-margin dbtk:out "%0| %1 is: %l2\n"
	    (make-string (+ 1 (length (String level))))
	    var (if (boundp var) (eval var) '*undefined*)
  )))))
)
  
;;=============================================================================
;;                    stack handling
;;=============================================================================
  
;; a comprehensive stack dumping function
;; returns a list of frames
;; TODO: hide the 2 stack frames made by wrapper code on breaked functions
  
(defun dbtk:dump-stack (&key
    :to					;number of listed frames
    :from				;prints only before call to name
    :all				;prints also debugger code
    &aux
    frame
    (doprint t)
    (result (list))
    (level 0)
    (*:dsp all)
  )
  (if to (setq to (Int to)))
  (setq frame (stack-frame 0))
  (if (not (typep to Number)) (setq to *maxint*))
  (if from (setq doprint ()))
  (catch 'Done
    (while frame
      (if (>= level to) (throw 'Done))
      (if (and doprint (dbtk:not-break-frame (0 frame))) (progn
	  (append-to-list result frame)
	  (incf level)
      ))
      (if (and from (or (= from (getn (getn frame 0) 0))
	    (= from (getn (getn (getn frame 0) 0) 0))))
	(setqn doprint t from ())
      )
      (setq frame (stack-frame (getn frame 2)))
  ))
  result
)
  
(defvar dbtk:re-old-func (regcomp "^dbtk:old:"))

(defun dbtk:not-break-frame (call &aux l)
  (and call
    (not (and (= (getn call 0) 'dbtk:breakq) (= (getn call 1) ())))
    (not (and (typep (getn call 0) Expr)
	(setq l (List (getn call 0)))
	(= (0 l) 'lambda) (= (1 l) '(&rest dbtk:breaked-func-args))
	(typep (2 l) List) (= 'dbtk:breakq (0 (2 l)))
    ))    
    (not (and (typep call Expr)	(setq l (List call))
	(= (0 l) 'lambda) (= (1 l) '(&rest dbtk:breaked-func-args))
	(typep (2 l) List) (= 'dbtk:breakq (0 (2 l)))
    ))
    (/= '(dbtk:break break:expr 'break break:data (list break:condition))
      call
    )
    (not (and (= 'apply (0 call)) (= 'dbtk:breaked-func-args (2 call))
	(typep dbtk:re-old-func String) (regexec dbtk:re-old-func (1 call))
    ))
))
  
;; attemps to find a function name in the stack and returns the
;; innermost stack where it appears, or ()
  
(defun dbtk:frame-of-function (name &aux (frame (stack-frame 0)))
  (catch 'Done
    (while frame
      (if (or (= name (getn (getn frame 0) 0))
	  (= name (getn (getn (getn frame 0) 0) 0))
	)
	(throw 'Done frame)
      )
      (setq frame (stack-frame (getn frame 2)))
)))
  
;; from relative number of frame to absolute number, or ()

(defun dbtk:frame-rel2abs (num &aux 
    (stack (dbtk:dump-stack :to (+ num 1)))
    (frame (getn stack num))
  )
  (1 frame)
)

;; from absolute number to relative number of frame, or ()

(defun dbtk:frame-abs2rel (num &aux 
    (stack (dbtk:dump-stack))
  )
  (catch 'Found
    (dotimes (n (length stack))
      (if (= num (1 (n stack))) (throw 'Found n))
)))

;;=============================================================================
;;                    High-level interface to breakpoints
;;=============================================================================
;; these are the routines to be used from a debugger
  
;; first thing to do when coming into a debugger: clean structures from
;; obsolete breakpoints (step, next) 
  
(defun dbtk:BP-clean ()
  (dolist (bp (copy dbtk:BPs))
    (if (and (= 'frame (dbtk:BP-type bp))
	(<= *:stackptr (dbtk:BP-what bp))
      )
      (delete-item-eq dbtk:BPs bp)
)))
  
;; before continuing, a debugger should set up the runtime  support to trace
;; things
;; This will build 2 lists:
;; dbtk:watchpoints is the list of tests to be performed
;; dbtk:watchpoints-bp is the corresponding list of breakpoints
  
(defun dbtk:BP-ready (&aux
    (dbtk:break-at-frame -1)
    dbtk:break-at-frame-bp
  )
  (setq dbtk:watchpoints (list))	;watchpoints
  (setq dbtk:watchpoints-bp (list))
					;frame: only take the biggest
  (dolist (bp dbtk:BPs)
    (if (= 'frame (dbtk:BP-type bp))
      (if (> (dbtk:BP-what bp) dbtk:break-at-frame) (progn
	  (setq dbtk:break-at-frame (dbtk:BP-what bp))
	  (setq dbtk:break-at-frame-bp bp)
  ))))
  (if (/= dbtk:break-at-frame -1) (progn
      (append-to-list dbtk:watchpoints `(<= *:stackptr ,dbtk:break-at-frame))
      (append-to-list dbtk:watchpoints-bp dbtk:break-at-frame-bp)
  ))
  
  (dolist (bp dbtk:BPs)
    (if (= 'watch (dbtk:BP-type bp)) (progn
	(append-to-list dbtk:watchpoints (dbtk:BP-what bp))
	(append-to-list dbtk:watchpoints-bp bp)
  )))
  
  (if (and (not dbtk:watchpoints) dbtk:fast-runtime)
    (dbtk:runtime-hooks ())
    (dbtk:runtime-hooks t)
  )
  
  (setq dbtk:genfuncs (list))		;genfuncs
  (dolist (bp dbtk:BPs)
    (if (= 'genfunc (dbtk:BP-type bp)) (progn
	(append-to-list dbtk:genfuncs (dbtk:BP-what bp))
	(if (dbtk:BP-conditions bp)
	  (append-to-list dbtk:genfuncs (dbtk:BP-conditions bp))
	  (append-to-list dbtk:genfuncs '(t))
  ))))
  (if (not dbtk:genfuncs) (setq dbtk:genfuncs ()))
  
  (if dbtk:genfuncs (progn
      (*:mhook GenericFunction dbtk:execute-offset dbtk:genfunc-executor)
      (*:mhook GenericFunction dbtk:apply-offset dbtk:genfunc-applier)
    ) 
    (if (boundp 'GenericFunction ) (progn
	(*:mhook GenericFunction dbtk:execute-offset ())
	(*:mhook GenericFunction dbtk:apply-offset ())
    ))
  )
)
  
;; when you set a debugger (put it in *error-handlers*), you should call
;; (dbtk:runtime-hooks t), and (dbtk:runtime-hooks ())

(defun dbtk:runtime-hooks (flag)
  (if flag
    (dolist (type dbtk:watched-eval-types)
      (*:mhook type dbtk:watched-eval-offset dbtk:runtime-hook-eval)
    )
    (dolist (type dbtk:watched-eval-types)
      (*:mhook type dbtk:watched-eval-offset ())
)))
  
  
;; (dbtk:BP-set name)
;; generic dispatcher to set a breakpoint. The Worhouse of this package
;; to be applied from the main loop
;; name can be:
;;  - symbol with functional value: break function
;;  - list (Class symbol) break only on call to this method for this type
;;  - genfunc or system method: break the corresponding info
;;  - a number: frame num or dbtk:step-frame for step
;;  - a breakpoint: re-enables it
;;  - other = watchpoint
;; return bp or () if error
  
(defun dbtk:BP-set (name &aux
    bp
  )
  (if
    ;; frame (step or next)
    (typep name Int) (progn (setq bp (make-dbtk:BP :type 'frame
	  :tag (if (= name dbtk:step-frame) 'step (= name *:stackptr) 'next
	    (with (n (dbtk:frame-abs2rel name)) (if n (+ "frame#" (String n))
		'frame
	  )))
	  :number dbtk:BP-size :what name :conditions (list)
      ))
    )
    ;; normal function 
    (and (typep name Atom) (boundp name) (typep (eval name) Function))
    (setq bp (make-dbtk:BP :type 'func
	:tag name :number dbtk:BP-size :what (eval name) :conditions (list)
    ))
    ;; lambda
    (typep name Function)
    (setq bp (make-dbtk:BP :type 'func
	:tag (gensym "lambda") :number dbtk:BP-size :what name
	:conditions (list)
    ))
    ;; generic function
    (and (typep name Atom) (boundp name) (boundp 'GenericFunction)
      (typep (eval name) GenericFunction))
    (setq bp (make-dbtk:BP :type 'genfunc
	:tag name :number dbtk:BP-size :what (eval name)
	:conditions (list)
    ))
    ;; method call
    (and (typep name List) (= 2 (length name))
      (or (typep (0 name) ExClass)
	(and (boundp (0 name)) (typep (eval (0 name)) ExClass))
      )
      (typep (1 name) Atom)
    )
    (with (method (apply find-method (list (eval (0 name)) (1 name))))
      (if method (setq bp (make-dbtk:BP :type 'func
	    :tag name :number dbtk:BP-size :conditions (list)
	    :what method
    ))))
    ;; breakpoint to re-enable
    (list-partial-equal #( # dbtk:BP) name) (progn
      (delete-item-eq dbtk:disabled-BPs name)
      (setq bp name)
    )
    ;; an atom at this point means an error
    (typep name Atom)
    (setq bp ())
    
    ;; ignore nils
    (not name)
    (setq bp ())
    
    ;; other: watchpoint
    t (setq bp (make-dbtk:BP :type 'watch
	:tag "" :number dbtk:BP-size :what name :conditions (list)
      )
    )
  )
  (if bp (progn
      (dbtk:BP-exec 'enable bp)
      (append-to-list dbtk:BPs bp)
      (dbtk:BP-sort-lists)
      bp
  ))
)
  
;; (dbtk:BP-unset bp)
;; disables a breakpoint
;; can be re-enabled by calling dbtk:BP-set on it
  
(defun dbtk:BP-unset (bp &key destroy)
  (if bp (progn
      (delete-item-eq dbtk:BPs bp)
      (if (and (not destroy) (/= 'frame (dbtk:BP-type bp))) 	;forgets frames
	(append-to-list dbtk:disabled-BPs bp)
      )
      (dbtk:BP-sort-lists)
      (dbtk:BP-exec 'disable bp)
)))
  
;; same but give number
(defun dbtk:BP-unset-num (num &key destroy)
  (dbtk:BP-unset
    (catch 'Found
      (dolist (bp dbtk:BPs)
	(if (= (dbtk:BP-number bp) num) (throw 'Found bp))
    ))
    :destroy destroy
))
  
;;=============================================================================
;;                    breakpoints
;;=============================================================================
  
;;===================================================================== general
  
;; Uses (dbtk:break expr tag data list-of-conditions)
  
;; What is a breakpoint: 
(defstruct dbtk:BP
  type					;func frame watch genfunc
  tag					;meaningful name for the user
  what					;what is monitored? 
  number				;order number
  conditions				;list of conditions
)

;; ** func breakpoint:
;; tag is the name of the fonction or a list (class selector)
;; what is the body of the function
;; ** frame breakpoint:
;; tag is 'step 'net or 'frame
;; what is the number of the frame stack to stop
;; ** watch breakpoint:
;; tag is ""
;; what is the watched expression
;; ** genfunc breakpoint:
;; tag is name of the genfunc
;; what is the genfunc itself
  
;;=============================================================================
;;                    misc defvars
;;=============================================================================
  
(defvar dbtk:BPs (list))		;the list of enabled breakpoints
(defvar dbtk:disabled-BPs (list))	;the list of disabled breakpoints
(defvar dbtk:BP-size 0)			;number of breakpoints
(defvar dbtk:watchpoints ())		;need to install general monitor?
(defvar dbtk:genfuncs ())
(defvar dbtk:fast-runtime t)		;if t low overhead

(defvar dbtk:breakpointed-functions (Hashtable ()))
(defvar dbtk:break-function-types (list FSubr FExpr Macro Macro FExpr FExpr))
(defvar dbtk:system-methods (with (i (*:mhook-number "eval") l (list))
    (while (*:mhook-number i) (append-to-list l (*:mhook-number i))(incf i))l)
)
(defvar dbtk:watched-eval-offset (*:mhook-number "eval"))
(defvar dbtk:execute-offset (*:mhook-number "execute"))
(defvar dbtk:apply-offset (*:mhook-number "apply"))
(defvar dbtk:comma (intern ","))
(defvar dbtk:step-frame 2000000000)
(defvar dbtk:result :nil)

;; small object model to be able to run dbtk without the obj model
(setq dbtk:BP-exec-base (Hashtable ()))
(defun dbtk:BP-exec (selector &rest args)
  (apply
    (getn dbtk:BP-exec-base (list (dbtk:BP-type (getn args 0)) selector))
    args
))
(defmacro dbtk:BP-define-exec (selector type &rest args)
  `(put dbtk:BP-exec-base '(,type ,selector)
    (lambda ,@args)
))  

;; user-visible "contents" of a breakpoint

(defun dbtk:BP-contents (bp)
  (if 
    ;; func: contents is the original function
    (= 'func (dbtk:BP-type bp))
    (if (dbtk:not-break-frame (dbtk:BP-what bp))
      (dbtk:BP-what bp)			;disabled
      (eval (get (get (List (dbtk:BP-what bp)) 3) 1)) ;enabled
    )

    (= 'frame (dbtk:BP-type bp))
    (+ "<" (String (dbtk:BP-what bp)) ">")

    (dbtk:BP-what bp)
))

;;========================================================= breaks on functions

;; dbtk:break-function
;; sets a breakpoint on a functional expression, lambda or subr
;; you must give a symbolic name (which can be anything, not just an atom)
;; and the function itself
;; will replace the call by a call to:
;; (dbtk:eval-break dbtk:old:<function-name> dbtk:breaked-func-args)
;; dbtk:eval-break is apply
  
(defun dbtk:break-function (name func &aux
    (saved-func (copy func))
    old-name
  )
  (if (not (typep func Function))
    (error 'Errors:BadArgType func 1 (type-name Function)))
  
  (if (not (hash-get-eq dbtk:breakpointed-functions func ())) (progn
      (setq old-name (intern (+ "dbtk:old:"
	    (if (typep name List) (+ (String (0 name)) "." (String (1 name)))
	      name)))
      )
      (set old-name saved-func)
      (replace-lambda func (eval
	  `(lambda (&rest dbtk:breaked-func-args)
	    (dbtk:breakq () ,name ,saved-func (t))
	    (dbtk:eval-break ,old-name dbtk:breaked-func-args)
      )))
      (hash-put-eq dbtk:breakpointed-functions func saved-func)
      (type-replace func (get dbtk:break-function-types (type-of saved-func)
	  Expr
      ))
)))
  
(defun dbtk:unbreak-function (func &aux
    func-expanded
    saved-func
  )
  (if (/= :nil (hash-get-eq dbtk:breakpointed-functions func :nil)) (progn
      (setq func-expanded (List func))
      (setq saved-func (eval (get (get func-expanded 3) 1)))
      (makunbound (get (get func-expanded 3) 1))
      (if (typep saved-func Function) (progn
	  (replace-lambda func saved-func)
	  (hash-delete-eq dbtk:breakpointed-functions func)
      ))
      func
)))

(defun dbtk:break-function-list (&aux
    (res (list))
  )
  (dohash (func tag dbtk:breakpointed-functions)
    (append-to-list res list 'lambda tag func))
  res
)
  
;;======================================================== enabling breakpoints
  
(dbtk:BP-define-exec enable func (bp)
  (dbtk:break-function (dbtk:BP-tag bp) (dbtk:BP-what bp))
)
  
;;======================================================== disabling breakpoints
  
(dbtk:BP-define-exec disable func (bp)
  (dbtk:unbreak-function (dbtk:BP-what bp))
)
  
;;========================================================== setting conditions

(dbtk:BP-define-exec set-conditions func (bp conds &aux
    (func (dbtk:BP-what bp))
    (def (List func))
    (breakpoint (2 def))
  )
  (dbtk:BP-conditions bp conds)
  (put breakpoint 4 (if conds conds '(t)))
)

(dbtk:BP-define-exec set-conditions genfunc (bp conds)
  (dbtk:BP-conditions bp conds)
)

;;============================================================== lists managing
  
(defun compare-bp (bp1 bp2) 
  (compare (dbtk:BP-number bp1)(dbtk:BP-number bp2)))

(defun dbtk:BP-sort-lists ()
  (dbtk:BP-check-list dbtk:BPs)
  (dbtk:BP-check-list dbtk:disabled-BPs)
  (sort dbtk:BPs compare-bp)
  (sort dbtk:disabled-BPs compare-bp)
  (setq dbtk:BP-size 0)
  (if dbtk:BPs
    (setq dbtk:BP-size (+ 1 (dbtk:BP-number (get dbtk:BPs -1))))
  )
  (if dbtk:disabled-BPs
    (setq dbtk:BP-size (max dbtk:BP-size (+ 1 (dbtk:BP-number
	    (get dbtk:disabled-BPs -1)))
      )
)))
  
(defun dbtk:BP-check-list (l)
  (dolist (bp (copy l))
    (if (not (and (typep bp Vector) (= (0 bp) '#) (= (1 bp) 'dbtk:BP)))
      (delete-item-eq l bp)
)))

;;=============================================================================
;;                    runtime support
;;=============================================================================
  
(defvar dbtk:watched-eval-types #(Atom Active Constant QuotedExpr List
    ExActive
))
(if (boundp 'ExObject) (lappend dbtk:watched-eval-types ExObject))

;; Warning: this is old code, now the same function is coded in C for 
;; performance, see klerror.c, function KlDbtkRuntimeHookEval
;; NOTE: The C function has some enhancements, to hide debugging frames to
;; the user.

(if (not (boundp 'dbtk:runtime-hook-eval)) ;maybe defined in C
  (defun dbtk:runtime-hook-eval (dbtk:expr &aux
      (dbtk:result :nil)			;result is :nil befor eval
    )
    ;; first check before evaluating dbtk::expr, dbtk:result = :nil
    (setq dbtk:result (dbtk:break dbtk:expr 'watch dbtk:expr dbtk:watchpoints))
    ;; second, check after evaluating dbtk::expr which returned dbtk:result
    (dbtk:break 'dbtk:result 'watch dbtk:expr dbtk:watchpoints)
))
  
(defun dbtk:genfunc-executor (%:obj %:list)
  (dbtk:break '(*:mhook-apply dbtk:execute-offset %:obj %:list)
    'genfunc %:obj (getn dbtk:genfuncs %:obj))
)
  
(defun dbtk:genfunc-applier (%:obj %:list)
  (dbtk:break '(*:mhook-apply dbtk:apply-offset %:obj %:list)
    'genfunc %:obj (getn dbtk:genfuncs %:obj))
)
  
;;============================================= handler to be used in debuggers
  
;; only message
(defun dbtk:handler-in-debugger (%:errorcode &rest %:args)
  (dbtk:print-error-message %:errorcode %:args)
  :true
)
  
;; with stack dump
(defun dbtk:handler-in-debugger-stack-dump (%:errorcode &rest %:args)
  (dbtk:print-error-message %:errorcode %:args)
  (dbtk:print-stack-dump (dbtk:dump-stack :all t) :whole t :vars t)
  :true
)
  
;;=============================================================================
;;                    command line parsing
;;=============================================================================
  
;; read line, and parses it into command (a character, returned in %:cmd)
;; and the rest of args which are parsed into a list %:cmdargs)
;; if no command, %:cmd = #\newline, if begin with space or '(' cmd is #\space
;; return () if error
;; if arg is prefixed by comma ',' it is evaluated inline
  
(defunq dbtk:parse-command (%:line %:cmd %:cmdargs &aux
    (%:command-line-args-offset 0)
    %:arg
    (%res t)
    (*error-handlers* 'dbtk:handler-in-debugger) ;trap parse errors!
  )
  (if (= #\( (set %:cmd (getn (eval %:line) 0)))
    (set %:cmd #\space)
    (setq %:command-line-args-offset 1)
  )
  (if (eval %:cmd) (with  (
	result (list)
	line-stream (open (eval %:line) :type :string)
	*last-caught-tag* ()
      )
      (catch 'ALL
	(file-position line-stream %:command-line-args-offset 0)
	(while (setq %:arg (read line-stream))
	  (if (and (typep %:arg QuotedExpr) (= (0 %:arg) dbtk:comma))
	    (setq %:arg (eval %:arg))
	  )
	  (append-to-list result %:arg)
      ))
      (if (= *last-caught-tag* 'ERROR) (setq %res ()))
      (set %:cmdargs result)
    )
    (progn
      (set %:cmd #\newline)
      (set %:cmdargs ())
  ))
  %res
)
  
;;=============================================================================
;;                    dbdb
;;=============================================================================
;; is a lightweight debugger used to debug debugging code
;; To be placed at the tail of the *error-correctors* list
;; by: (dbdb t), removed by (dbdb ()), and (dbdb) returns state, t ou ()

(defun dbdb (&optional (flag :nil))
  (if (= flag :nil)
    (if (seek *error-correctors* 'dbdb:debugger) t ()) ;get value
    flag
    (if (not (seek *error-correctors* 'dbdb:debugger)) ;enable
      (insert *error-correctors* 0 'dbdb:debugger))
    (if (seek *error-correctors* 'dbdb:debugger) ;disable
      (delete-item *error-correctors* 'dbdb:debugger)
)))
  
(setq *package* 'dbdb)

(setq dbdb:is-in? ())
(setq dbdb:help "***** dbdb help:
h, ?  This help
c, q  Continue
m     Prints current error message
w, W  where = stack dump, terse version (w), or long one (W)
p <expression> print expression
      p can be replaced by <space> and is optional before a (")

(defun dbdb:debugger (%errorcode &rest %args &aux
    (dbtk:break-enabled ())
     %frame %stop %line %expr %it
  )
  (if dbdb:is-in? (progn
      (dbtk:print-error-message %errorcode %args ())
      :true
    )
    (if (> *:stacked-errors 1) (progn	;only activate if error in error
	(print-format dbtk:out
	  "*** Error in an error handler or corrector, entering dbdb : ")
	(with (*:dsp t %frame (dbtk:frame-of-function 'dbdb:debugger))
	  (if %frame (setq %frame (stack-frame (getn %frame 2))))
	  (dbtk:print-error-message %errorcode %args %frame)
	  ;; interactive loop to test variables
	  
	  (while (and (not %stop) (not dbdb:is-in?))
	    (write-string "dbdb> " dbtk:out)
	    (setq %line (dbtk:read-line))
	    (if (match "^[cq]" %line)
	      (setq %stop t)
	      (match "^m" %line)
	      (dbtk:print-error-message %errorcode %args %frame)
	      (match "^w" %line)
	      (dbtk:print-stack-dump
		(dbtk:dump-stack :from 'dbdb:debugger :all t :to
		  (if (setq %it (match "^w[ \t]*([0-9]+)" %line 1)) (Int %it))
	      ))
	      (match "^W" %line)
	      (dbtk:print-stack-dump
		(dbtk:dump-stack :from 'dbdb:debugger :all t :to
		  (if (setq %it (match "^W[ \t]*([0-9]+)" %line 1)) (Int %it))
		) :whole t :vars t
	      )
	      (or (setq %expr (match "^p[ \t]*(.*)$" %line 1))
		(setq %expr (match "^[ ][ \t]*(.*)$" %line 1))
		(setq %expr (match "^([(].*)$" %line 1))
	      )
	      (catch 'ALL (with (dbdb:is-in? t *error-handlers* ())
		  (print-format dbtk:out ">> %n0 = %l1\n"
		    %expr (eval (read (Stream %expr))))
	      ))
	      t
	      (write-line dbdb:help dbtk:out)
	  ))
	)
	:true
      )
      :nil
)))

;;=============================================================================
;;                    error trace
;;=============================================================================
;; (dbtr t) sets an error handler printing all Errors
;; Note: (dbtr t) should be re-issued each time a new handler/corrcetor is added
;; (dbtr ()) removes it

(defun dbtr:handler (errorcode &rest args)
  (print-format "ERROR CALLED: %r0, with args:\n%l1\n" errorcode args)
  ;;moves ourselves to the end, if we aren't already there
  (if (/= 'dbtr:handler (getn  *error-correctors* -1))
    (dbtr t)
  )
  :nil					;do not interfere
)

(defun dbtr (flag)		   
  (if flag (progn
      (delete-item-eq *error-correctors* 'dbtr:handler)
      (put *error-correctors* -1 'dbtr:handler)
    )
    (delete-item-eq *error-correctors* 'dbtr:handler) 
))
      
