;;=============================================================================
;;################### SDB #####################################################
;;=============================================================================
;;AUTOLOAD: sdb
;;AUTODOC: sdb "a simple line-oriented debugger based on dbtk"
;;sdb provides a simpler debugger than kdb
;;(sdb) enter debugger, to set breakpoints for instance
;;(sdb t) further errors will enter debugger
;;(sdb t :fast t) do not put any overhead if no watchpoints are set, but
;;    in this case you will no be able to examine returned value of breakpointed
;;    statements
;;(sdb ()) removes completely debugging.

(require 'dbtk)

;(dbdb t)

(setq *package* 'sdb)

(setq sdb:help-text "***** sdb help:
NOTE: all command are one letter, no space needed after them
      comma-prefixed arguments are evaluated, otherwise they are quoted
h, ?  This help
c     Continue with all breakpoints active
q     Quit (disables all breakpoints)
Q     Quit forcibly (totally remove breakpoints)
m, M  Prints current error message (M = more info)
w, W  where = stack dump, terse version (w), or long one (W)
      can be followed by a number to limit the number of frames printed
p <expressions> print expressions
      p can be replaced by <space> and is optional before a (
s     step once, recursively inside evaluated expression
n     next, step in the same stack frame
b <expression>    sets a breakpoint, <expression> can be:
      a function name, function or generic function: a breakpoint is set
      a list of (Class selector): breaks when this method is called 
      any expression: this expression is watched and sdb called when true
      breakpoints can be put in your code by 
      (break [ <expr-to-eval> [ condition [ label ]]] )
B num <conditions>    sets the list of conditiosn for a breakpoint
i     lists breakpoints
I     lists all breakpoints, even the disabled ones
d nums     disables breakpoints by their number. D destroys them
e nums     re-enable breakpoints
f num      stop when re-entering frame num
r <value>  makes the current statement return this value"
)

(setq sdb:is-in? ())

(defun sdb:debugger (%errorcode &rest %args &aux
    %stop %line %expr (%result :true) %cmd %cmdargs
;    (*error-handlers* 'dbtk:handler-in-debugger)
    (*error-handlers* 'dbdb:debugger)	;PV
  )
  (if sdb:is-in? (progn (dbtk:print-error-message %errorcode %args) :true)
    (progn
      (if (and (/= %errorcode 'Errors:DbtkBreak) (= 'watch (1 %args)))
	(print-format dbtk:out "***** entering sdb (? for help) : \n"))
      (dbtk:print-error-message %errorcode %args)
      (dbtk:BP-clean)
      
      ;; interactive loop
      (while (not %stop)
	(write-string "sdb> " dbtk:out)
	(setq %line (dbtk:read-line))
	(if (dbtk:parse-command %line %cmd %cmdargs)
	  (catch 'ALL
	    (eval (get sdb:command-table %cmd
		''(print-format "sdb: Unknown command %r0 (? or h for help)\n"
		  (String (list %cmd))
	)))))
      )
      (if (= %stop #\q)
	(dolist (bp dbtk:BPs) (dbtk:BP-unset bp))
	(= %stop #\Q) (progn
	  (dolist (bp dbtk:BPs) (dbtk:BP-unset bp))
	  (setq dbtk:disabled-BPs (list))
	  (sdb ())
      ))
      (dbtk:BP-ready)
      (if (= %stop #\r)
	%result
	(if (= %errorcode 'Errors:DbtkBreak);continue, step & next
	  'Errors:DbtkBreak
	  :true
)))))

;; command table: expr to be evaluated indexed by command char ascii code

(setq sdb:command-table (Hashtable #(
      #\q (setq %stop #\q)		;quit, disable all breaks
      #\c (setq %stop #\c)		;continue
      #\Q (setq %stop #\Q)		;remove everything
      #\r (if (getn Errors:Unrecoverable %errorcode)
	(print-format dbtk:out "Cannot return from errors of type: %0\n"
	  %errorcode)
	(progn (setq %stop #\r) (setq %result (0 %cmdargs)))
      )
      #\m (dbtk:print-error-message %errorcode %args)
      #\M (with (print-margin:width ())
	(dbtk:print-error-message %errorcode %args)
	(print-format dbtk:out "Error  code: %r0\nParameters: %r1\n"
	  %errorcode %args
      ))
      #\w (dbtk:print-stack-dump (dbtk:dump-stack :to (0 %cmdargs)))
      #\W (dbtk:print-stack-dump (dbtk:dump-stack :to (0 %cmdargs))
	:whole t :vars t)
      #\b (dolist (bp %cmdargs) (sdb:list-breakpoint (dbtk:BP-set bp)))
      #\B (sdb:list-breakpoint
	(sdb:set-conditions (Int (0 %cmdargs)) (subseq %cmdargs 1))
      )
      #\d (dolist (bp %cmdargs) (dbtk:BP-unset-num (Int bp)))
      #\D (dolist (bp %cmdargs) (dbtk:BP-unset-num (Int bp) :destroy t))
      #\e (dolist (bp %cmdargs) (sdb:enable (Int bp)))
      #\i (sdb:list-breakpoints ())
      #\I (sdb:list-breakpoints t)
      #\f (sdb:list-breakpoint
	(dbtk:BP-set (dbtk:frame-rel2abs (Int (0 %cmdargs))))
      )
      #\s (progn (dbtk:BP-set dbtk:step-frame) (setq %stop #\c))
      #\n (progn (dbtk:BP-set *:stackptr) (setq %stop #\c))
      #\p (dolist (%:expr %cmdargs) (sdb:print-expr %:expr))
      #\space (dolist (%:expr %cmdargs) (sdb:print-expr %:expr))
      #\newline ()
      #\h (write-line sdb:help-text dbtk:out)
      #\? (write-line sdb:help-text dbtk:out)
)))

;; print an expression from inside the debugger

(defun sdb:print-expr (%:e &aux
    (sdb:is-in? t)
    (dbtk:print-error-message:terse t)
    (*error-handlers* 'sdb:debugger)
  )
  (catch 'ALL (print-format dbtk:out ">> %n0 = %r1" %:e (eval %:e)))
  (write-line "")
)

; main routine to set/unset test debugger

(defvar sdb:previous-error-handler (list *error-handlers-orig*))

;; (sdb t) sets debugger with runtime overhead
;; (sdb t :fast t) sets debugger with no overhead for func breaks
;; (sdb ()) remove all debugging code

(defun sdb (&optional (flag :nil) &key (fast :nil))
  (if (/= :nil fast) (setq dbtk:fast-runtime fast))
  (if (= flag :nil)
    (progn 
      (sdb t)
      (print-format dbtk:out "Entering sdb debugger%0. help by h or ?.\n"
	(if dbtk:fast-runtime " (fast mode)")
      )
      (dbtk:breakq () () () (t)))
    flag
    (progn (if (/= *error-handlers* '(sdb:debugger)) (progn
	  (setq sdb:previous-error-handler *error-handlers*)
	  (setq *error-handlers* '(sdb:debugger))
      ))
      (dbtk:runtime-hooks (not dbtk:fast-runtime))
      flag
    )
    (progn (if (= *error-handlers* '(sdb:debugger)) ;disable
	(setq *error-handlers* sdb:previous-error-handler)
      )
      (dbtk:runtime-hooks ())
      flag
)))


;;=============================================================================
;;                    commands
;;=============================================================================

(defun sdb:list-breakpoints (disabled? &aux
  )
  (dolist (bp dbtk:BPs)
    (sdb:list-breakpoint bp)
  )
  (when (and disabled? dbtk:disabled-BPs)
    (print-format dbtk:out "Disabled Breakpoints:\n")
    (dolist (bp dbtk:disabled-BPs)
      (sdb:list-breakpoint bp)
))))

(defun sdb:list-breakpoint (bp &aux (n 0))
  (if bp (progn
      (print-margin dbtk:out "%0[%1] %3 (%2)   %r4\n"
	(make-string (- 3 (length (String (dbtk:BP-number bp)))))
	(dbtk:BP-number bp)
	(dbtk:BP-type bp)
	(dbtk:BP-tag bp)
	(dbtk:BP-contents bp)
      )
      (if (/= '(t) (dbtk:BP-conditions bp))
	(dolist (condition (dbtk:BP-conditions bp))
	  (print-margin dbtk:out "    | Condition#%1: %0\n" condition (incf n))
)))))

(defun sdb:enable (num &aux bp)
  (if (setq bp (catch 'Found (dolist (b dbtk:disabled-BPs)
	  (if (= num (dbtk:BP-number b)) (throw 'Found b))
    )))
    (sdb:list-breakpoint (dbtk:BP-set bp))
))

(defun sdb:set-conditions (num conds &aux 
    (bp (catch 'Found (dolist (b dbtk:BPs)
          (if (= num (dbtk:BP-number b)) (throw 'Found b))
    )))
  )
  (if bp (dbtk:BP-exec 'set-conditions bp conds)
    (print-format dbtk:out "no such breakpoint: [%0]\n" num)
  )
  bp
)

