
;; An error handler which dumps all info and sends it to user

;;AUTOLOAD: print-stack-dump
;;AUTODOC: print-stack-dump "prints a stack dump"
;;USAGE: either standalone, as in (print-stack-dump), or can be used as an 
;;error-handler
;;
;;Prints a classic stack dump, as in:
;;? (+ (- (* (= 12 (print-stack-dump)) 1) 2) 3)
;;[0] (stack-frame 0)
;;[1] (print-stack-dump)
;;[2] (= 12 (print-stack-dump))
;;[3] (* (= 12 (print-stack-dump)) 1)
;;[4] (- (* (= 12 (print-stack-dump)) 1) 2)
;;[5] (+ (- (* (= 12 (print-stack-dump)) 1) 2) 3)
;;
;;Uses the following global variables:
;;    print-stack-dump:max-level  integer limiting the size of the dump
;;                                default: unlimited (*maxint*)
;;    print-stack-dump:exit-after if t (default ()), performs an exit just 
;;                                after dumping with code 1, or N if set
;;                                to an integer N
;;    print-stack-dump:print-local-vars if t (default ()), prints also the value
;;                                of local variables outside of their current 
;;                                environnement
;;    print-stack-dump:print-all-vars if t (default ()), prints the value of ALL
;;                                symbols after the stack dump
;;    print-stack-dump:output     if set to a stream (defaults to 
;;                                *standard-error*), prints here

(setq *package* 'print-stack-dump)

(defvar %max-level *maxint*)
(defvar %exit-after ())
(defvar %print-local-vars ())
(defvar %output ())
(defvar %print-all-vars ())

(defunq print-stack-dump (&rest %:args &aux
    (%:frame (stack-frame 0))
    (%:level 0)
    %:stack-ptr
    %:line
    (%:in-file? (loadinfo))
    %:vars
    (%:allvars (list))
    %:i
    (%:output (if %output %output *standard-error*))
  )
  (write "\n*** STACK DUMP:\n\n" %:output) ;to start on a fresh line
  
  ;; when called as an error handler, describe the error
  (if %:args 
    (progn
      (print-format %:output "*** Klone Error:\n")
      (if %:in-file?
	(print-format %:output
	  "\"%0\", line %1: " (getn %:in-file? 0) (getn %:in-file? 1))
      )
      (apply print-format (+ (list %:output) %:args))
      (print-format %:output "\n\n")
    )
  )
  
  (if %print-local-vars	(progn		;stack dump with local vars
      (while %:frame
	(print-format %:output "[%n0/%n1] %r2\n" %:level (getn %:frame 1)
	  (getn %:frame 0))
	(setq %:vars (getn %:frame 3))
	(setq %:i 0)
	(while (getn %:vars %:i)
	  (if (regexec {regcomp "^print-stack-dump::"} (getn %:vars %:i))
	    ()				;exclude our internal symbols
	    (progn
	      (print-format %:output "%n0| %n1 = %r2\n"
		(if (< %:level 10) "  " (< %:level 100) "   " (< %:level 1000) "    "
		  (< %:level 10000) "     " "      ")
		(getn %:vars %:i)
		(getn %:vars (+ 1 %:i))
	      )
	      (put %:allvars (getn %:vars %:i) t)
	  ))
	  (incf %:i 2)
	)
	(incf %:level)
	(setq %:frame (stack-frame (getn %:frame 2)))
      )
					;print current values of stack vars
      (print-format %:output 
	"\n\n*** CURRENT VALUES OF STACK VARIABLES:\n*********************\n\n"
      )
      (dohash (%:v %:dummy %:allvars)
	(print-format %:output " || %n1 = %r2\n" () %:v (eval %:v))
      )
      (setq %:allvars ())
    )
					;normal stack dump
    (while (and %:frame (< %:level %max-level))
      (print-format %:output "[%0] %r1\n" %:level (getn %:frame 0))
      (incf %:level)
      (setq %:frame (stack-frame (getn %:frame 2)))
    )
  )
  (if %print-all-vars (with (%:l (copy ())) ;now dump EVERYTHING!
      (print-format %:output 
	"\n\n*** DUMP OF ALL VARIABLES:\n**************************\n\n"
      )
      (do-all-symbols (%:s) 
	(if (or				;exclude our internal symbols
	    (regexec {regcomp "^print-stack-dump::"} %:s) 
	    (= 'print-stack-dump %:s)
	  )
	  ()				
	  (lappend %:l %:s)
      ))	
      (sort %:l				;list of all symbols, sorted
	(lambda (%:s1 %:s2) (compare (String %:s1) (String %:s2))) ;bug waround
      )
      (dolist (%:s %:l)
	(if 
	  (not (boundp %:s))
	  (print-format %:output "%n0 *UNDEFINED*\n" %:s)
	  
	  (print-format %:output "%n0 = %r1\n" %:s (trap-error 'ALL (eval %:s)))
      ))
      (print-format %:output "*** End of dump!\n\n")
  ))
  
  (if %exit-after 
    (if (typep %exit-after Int)
      (exit %exit-after)
      (exit 1)
  ))
  :true
)
     
;;AUTOLOAD: print-whole-stack-dump
;;AUTODOC: print-whole-stack-dump "prints a complete dump of the system"
;;print-whole-stack-dump is print-stack-dump with max-level set to *maxint*
;;and printing local and all variables

(defun print-whole-stack-dump (&rest args)
  (with (
      print-stack-dump:max-level *maxint*
      print-stack-dump:print-local-vars t
      print-stack-dump:print-all-vars t
    )
    (apply print-stack-dump args)
))
