;;; -*-Scheme-*-
;;;
;;; A simple debugger (needs much work)

(define (backtrace . args)
  (if (> (length args) 1)
      (error 'backtrace "too many arguments"))
  (if (not (null? args))
      (if (not (eq? (type (car args)) 'control-point))
	  (error 'backtrace "argument must be a control point")))
  (let ((trace
	 (apply backtrace-list args))
	(maxlen 28))
    (if (null? args)
	(set! trace (cdddr trace)))
    (for-each
     (lambda (frame)
       (let* ((func
	      (format #f "~s" (vector-ref frame 0)))
	     (indent 
	      (- maxlen (string-length func))))
	 (display func)
	 (if (negative? indent)
	     (begin
	       (newline)
	       (set! indent maxlen)))
	 (do ((i indent (1- i)))
	     ((> 0 i))
	   (display " ")))
       (fluid-let
	   ((print-depth 2)
	    (print-length 3))
	 (display (vector-ref frame 1)))
       (newline))
     trace))
  #v)

(define (show env)
  (fluid-let
      ((print-length 2)
       (print-depth 2))
    (do ((f (environment->list env) (cdr f)))
	((null? f))
      (do ((b (car f) (cdr b)))
	  ((null? b))
	(format #t "~s\t~s~%" (caar b) (cdar b)))
      (print '-------)))
  #v)

(define inspect)

(let ((frame)
      (trace)
      (help-text
       '("q   -- quit inspector"
	 "f   -- print current frame"
	 "u   -- go up one frame"
	 "d   -- go down one frame"
	 "^   -- go to top frame"
	 "$   -- go to bottom frame"
	 "e   -- eval expressions in environment"
	 "p   -- pretty-print procedure"
	 "v   -- show environment"
	 "<n> -- pretty-print n-th argument"
         "o   -- obarray information")))
  
  (define (inspect-command-loop)
    (let ((input) (done #f))
      (display "inspect> ")
      (set! input (read))
      (case input
	(q
	 (set! done #t))
	(? 
	 (for-each
	  (lambda (msg)
	    (display msg)
	    (newline))
	  help-text))
	(f
	 (print-frame))
	(^
	 (set! frame 0)
	 (print-frame))
	($
	 (set! frame (1- (length trace)))
	 (print-frame))
	(u
	 (if (zero? frame)
	     (format #t "Already on top frame.~%")
	     (set! frame (1- frame))
	   (print-frame)))
	(d
	 (if (= frame (1- (length trace)))
	     (format #t "Already on bottom frame.~%")
	     (set! frame (1+ frame))
	   (print-frame)))
	(v
	 (show (vector-ref (list-ref trace frame) 2)))
	(e
	 (format #t "Type ^D to return to Inspector.~%")
	 (let loop ()
	   (display "eval> ")
	   (set! input (read))
	   (if (not (eof-object? input))
	       (begin
		 (write (eval input
			      (vector-ref (list-ref trace frame) 2)))
		 (newline)
		 (loop))))
	 (newline))
	(p
	 (pp (vector-ref (list-ref trace frame) 0))
	 (newline))
	(o
	 (let ((l (map length (oblist))))
	   (let ((n 0))
	     (for-each (lambda (x) (set! n (+ x n))) l)
	     (format #t "~s symbols " n)
	     (format #t "(maximum bucket: ~s).~%" (apply max l)))))
	(else
	 (cond
	  ((integer? input)
	   (let ((args (vector-ref (list-ref trace frame) 1)))
	     (if (or (< input 1) (> input (length args)))
		 (format #t "No such argument.~%")
		 (pp (list-ref args (1- input)))
	       (newline))))
	  ((eof-object? input)
	   (set! done #t))
	  (else
	   (format #t "Invalid command.  Type ? for help.~%")))))
      (if (not done)
	  (inspect-command-loop))))

  (define (print-frame)
    (format #t "~%Frame ~s of ~s:~%~%" (1+ frame) (length trace))
    (let* ((f (list-ref trace frame)) (args (vector-ref f 1)))
      (format #t "Procedure:    ~s~%" (vector-ref f 0))
      (format #t "Environment:  ~s~%" (vector-ref f 2))
      (if (null? args)
	  (format #t "No arguments.~%")
	  (fluid-let
	      ((print-depth 2)
	       (print-length 3))
	    (do ((i 1 (1+ i)) (args args (cdr args))) ((null? args))
	      (format #t "Argument ~s:   ~s~%" i (car args))))))
    (newline))
  
  (set! inspect
	(lambda ()
	  (set! frame 0)
	  (set! trace (backtrace-list))
	  (set! trace (cddr trace))
	  (do ((t trace (cdr t)) (f 1 (1+ f))) ((null? t))
	    (if (not (null? (vector-ref (car t) 1)))
		(let ((last (last-pair (vector-ref (car t) 1))))
		  (if (not (null? (cdr last)))
		      (begin
			(format #t
 "[inspector: fixing improper arglist in frame ~s]~%" f)
			(set-cdr! last (cons (cdr last) '())))))))
	  (format #t "Inspector (type ? for help):~%")
	  (let loop ()
	    (if (call-with-current-continuation
		 (lambda (control-point)
		   (push-frame control-point)
		   (inspect-command-loop)
		   #f))
		(begin
		  (pop-frame)
		  (loop))))
	  (newline)
	  (pop-frame)
	  (let ((next-frame (car rep-frames)))
	    (next-frame #t)))))
