#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
    2017, 2018, 2019, 2020, 2021, 2022 Massachusetts Institute of
    Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Browser-style Debug and Where
;;; Package: (edwin debugger)

(declare (usual-integrations))

;;;; Text prop setup stuff

(define (with-output-highlighted port thunk)
  (let ((start (mark-temporary-copy (port/mark port))))
    (thunk)
    (highlight-region (make-region start (port/mark port)) (highlight-face))))

(define (read-only-between start end)
  (region-read-only (make-region start end)))

(define (readable-between start end)
  (region-writeable (make-region start end)))

(define (dehigh-between start end)
  (highlight-region (make-region start end) (default-face)))

(define (debugger-pp-highlight-subexpression expression subexpression
					     indentation port)
  (let ((start-mark #f)
	(end-mark #f))
    (parameterize ((param:pp-no-highlights? #f))
      (debugger-pp
       (unsyntax-with-substitutions
	expression
	(list (cons subexpression
		    (make-pretty-printer-highlight
		     (unsyntax subexpression)
		     (lambda (port)
		       (set! start-mark
			     (mark-right-inserting-copy
			      (output-port->mark port)))
		       unspecific)
		     (lambda (port)
		       (set! end-mark
			     (mark-right-inserting-copy
			      (output-port->mark port)))
		       unspecific)))))
       indentation
       port))
    (if (and start-mark end-mark)
	(highlight-region-excluding-indentation
	 (make-region start-mark end-mark)
	 (highlight-face)))
    (if start-mark (mark-temporary! start-mark))
    (if end-mark (mark-temporary! end-mark))))

;;;; Browsers

(define-record-type <browser>
    (%make-browser buffer object name lines selected-line buffers properties)
    browser?

  ;; The browser's buffer.
  (buffer browser/buffer)

  ;; The object being browsed.
  (object browser/object)

  ;; Name of this browser, a string.  Not necessarily unique.
  (name browser/name)

  ;; Vector of BLINE objects, sorted in order of increasing INDEX.
  (lines browser/lines set-browser/lines!)

  ;; The current selected BLINE object.
  (selected-line browser/selected-line set-browser/selected-line!)

  ;; List of buffers associated with this browser.
  (buffers browser/buffers set-browser/buffers!)

  (properties browser/properties))

(define (make-browser name mode object)
  (let ((buffer (new-buffer name)))
    (buffer-reset! buffer)
    (set-buffer-read-only! buffer)
    (set-buffer-major-mode! buffer mode)
    (add-kill-buffer-hook buffer kill-browser-buffer)
    (let ((browser
	   (%make-browser buffer
			  object
			  name
			  (vector)
			  #f
			  '()
			  (make-1d-table))))
      (buffer-put! buffer 'BROWSER browser)
      browser)))

(define (kill-browser-buffer buffer)
  (let ((browser (buffer-get buffer 'BROWSER)))
    (if browser
	(for-each kill-buffer (browser/buffers browser)))))

(define (buffer-browser buffer)
  (let ((browser (buffer-get buffer 'BROWSER)))
    (if (not browser)
	(error "This buffer has no associated browser:" buffer))
    browser))

(define (browser/new-buffer browser initializer)
  (let ((buffer
	 (create-buffer
	  (let ((prefix (browser/name browser)))
	    (let loop ((index 1))
	      (let ((name
		     (string-append " "
				    prefix
				    "-"
				    (number->string index))))
		(if (find-buffer name)
		    (loop (+ index 1))
		    name)))))))
    (if initializer
	(initializer buffer))
    (enable-group-undo! (buffer-group buffer))
    (add-browser-buffer! browser buffer)
    buffer))

(define (add-browser-buffer! browser buffer)
  (add-rename-buffer-hook
   buffer
   (letrec
       ((hook
	 (lambda (buffer name)
	   name
	   (set-browser/buffers! browser
				 (delq! buffer (browser/buffers browser)))
	   (remove-rename-buffer-hook buffer hook))))
     hook))
  (add-kill-buffer-hook
   buffer
   (lambda (buffer)
     (set-browser/buffers! browser
			   (delq! buffer (browser/buffers browser)))))
  (set-browser/buffers! browser (cons buffer (browser/buffers browser)))
  (buffer-put! buffer 'ASSOCIATED-WITH-BROWSER browser))

(define (browser/new-screen browser)
  (let ((pair (1d-table/get (browser/properties browser) 'NEW-SCREEN #f)))
    (and pair
	 (let ((screen (weak-car pair)))
	   (and (screen? screen)
		screen)))))

(define (set-browser/new-screen! browser screen)
  (1d-table/put! (browser/properties browser)
		 'NEW-SCREEN
		 (weak-cons screen #f)))

;;;; Browser Commands

(define-command browser-select-line
  "Select the current browser line."
  "d"
  (lambda (point)
    (let ((bline (mark->bline point)))
      (if (not bline)
	  (editor-error "Nothing to select on this line."))
      (select-bline bline))))

;;; If the mouse clicks on a bline, select it.
(define-command debugger-mouse-select-bline
  "Select a bline when mouse clicked there."
  ()
  (lambda ()
    ((ref-command mouse-set-point))
    (let ((bline (mark->bline (current-point))))
      (if bline
	  (select-bline bline)))))

(define-command browser-next-line
  "Move down to the next line."
  "p"
  (lambda (argument)
    (let* ((browser (buffer-browser (current-buffer)))
	   (bline
	    (letrec
		((loop
		  (lambda (index argument)
		    (let ((bline (browser/line browser index)))
		      (cond ((bline/continuation? bline)
			     (replace-continuation-bline bline)
			     (loop index argument))
			    ((= argument 0)
			     bline)
			    ((> argument 0)
			     (let ((index (+ index 1)))
			       (if (< index (browser/n-lines browser))
				   (loop index (- argument 1))
				   (begin
				     (select-bline bline)
				     #f))))
			    (else
			     (let ((index (- index 1)))
			       (if (<= 0 index)
				   (loop index (+ argument 1))
				   (begin
				     (select-bline bline)
				     #f)))))))))
	      (let ((point (current-point)))
		(let ((index (mark->bline-index point)))
		  (cond (index
			 (loop index argument))
			((= argument 0)
			 #f)
			(else
			 (let ((n (if (< argument 0) -1 1)))
			   (let find-next ((mark point))
			     (let ((mark (line-start mark n #f)))
			       (and mark
				    (let ((index (mark->bline-index mark)))
				      (if index
					  (loop index (- argument n))
					  (find-next mark))))))))))))))
      (cond (bline
	     (select-bline bline))
	    ((= argument 0)
	     (editor-failure "Nothing to select on this line."))
	    (else
	     (editor-failure))))))

(define-command browser-previous-line
  "Move up to the previous line."
  "p"
  (lambda (argument)
    ((ref-command browser-next-line) (- argument))))

(define (select-bline bline)
  (let ((bline
	 (if (bline/continuation? bline)
	     (replace-continuation-bline bline)
	     bline)))
    (let ((browser (bline/browser bline)))
      (unselect-bline browser)
      (let ((mark (bline/start-mark bline)))
	(with-buffer-open mark
	  (lambda ()
	    (insert-char #\> (mark1+ mark))
	    (delete-right-char mark)
	    (highlight-the-number mark)))
	(set-browser/selected-line! browser bline)
	(set-buffer-point! (mark-buffer mark) mark)))
    (let ((buffer (bline/description-buffer bline)))
      (if buffer
	  (pop-up-buffer buffer #f)))))

(define (highlight-the-number mark)
  (let ((end (re-search-forward "[RSE][0-9]+ " mark (line-end mark 0))))
    (highlight-region (make-region mark
				   (if (mark? end)
				       (mark- end 1)
				       (line-end mark 0)))
		      (highlight-face))))

(define (unselect-bline browser)
  (let ((bline (browser/selected-line browser)))
    (if bline
	(let ((mark (bline/start-mark bline)))
	  (with-buffer-open mark
	    (lambda ()
	      (dehigh-between mark (line-end mark 0))
	      (insert-char #\space (mark1+ mark))
	      (delete-right-char mark)))))))

;;; For any frame with an environment (excluding the mark frame) an
;;; inferior repl is started below the other descriptions.

(define (bline/description-buffer bline)
  (let* ((system?
	  (and (subproblem? (bline/object bline))
	       (system-frame? (subproblem/stack-frame (bline/object bline)))))
	 (buffer
	  (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f))
	 (get-environment
	  (1d-table/get (bline-type/properties (bline/type bline))
			'GET-ENVIRONMENT
			#f))
	 (env-exists? (if (and get-environment (not system?))
			  (let ((environment* (get-environment bline)))
			    (environment? environment*))
			  #f))
	 (environment (if env-exists? (get-environment bline) #f)))
    (if (and buffer (buffer-alive? buffer))
	buffer
	(let ((write-description
	       (bline-type/write-description (bline/type bline))))
	  ((message-wrapper #t "Computing, please wait")
	   (lambda ()
	     (and write-description
		  (let ((buffer (browser/new-buffer (bline/browser bline) #f)))
		    (call-with-output-mark (buffer-start buffer)
		      (lambda (port)
			(write-description bline port)
			(if env-exists?
			    (begin
			      (debugger-newline port)
			      (write-string evaluation-line-marker port)
			      (debugger-newline port)))))
			(set-buffer-point! buffer (buffer-start buffer))
		    (1d-table/put! (bline/properties bline)
				   'DESCRIPTION-BUFFER
				   buffer)
		    (read-only-between (buffer-start buffer)
				       (buffer-end buffer))
		    (buffer-not-modified! buffer)
		    (if env-exists?
			(start-inferior-repl! buffer environment #f))
		    buffer))))))))

(define evaluation-line-marker
  ";EVALUATION may occur below in the environment of the selected frame.")

(define-command browser-quit
  "Exit the current browser, deleting its buffer."
  ()
  (lambda ()
    (let ((buffer (current-buffer)))
      (let ((browser (buffer-browser buffer))
	    (screen (selected-screen)))
	;; Delete all windows that are currently showing buffers that
	;; are associated with this browser.
	(let ((window (screen-selected-window screen))
	      (buffers (browser/buffers browser)))
	  (for-each (lambda (window*)
		      (if (and (not (eq? window* window))
			       (not (typein-window? window*))
			       (memq (window-buffer window*) buffers))
			  (window-delete! window*)))
		    (screen-window-list screen)))
	;; If the browser was popped up in a new screen, and that
	;; screen is the current screen, delete it too.
	(let ((new-screen (browser/new-screen browser)))
	  (if (and (eq? new-screen screen)
		   (other-screen screen 1 #t))
	      (delete-screen! screen))))
      ;; Kill the buffer, then maybe select another browser.
      (let ((browser (get-buffer-browser buffer 'ASSOCIATED-WITH-BROWSER)))
	(kill-buffer-interactive buffer)
	(let ((browser
	       (or browser
		   (let ((buffer (current-buffer)))
		     (or (get-buffer-browser buffer 'BROWSER)
			 (get-buffer-browser buffer
					     'ASSOCIATED-WITH-BROWSER))))))
	  (if browser
	      (let ((buffer (browser/buffer browser)))
		(select-buffer buffer)
		((ref-command browser-select-line) (buffer-point buffer))))))
      (clear-current-message!)
      (maybe-restart-buffer-thread buffer))))

(define (get-buffer-browser buffer key)
  (let ((browser (buffer-get buffer key)))
    (and (browser? browser)
	 (buffer-alive? (browser/buffer browser))
	 browser)))

(define (maybe-restart-buffer-thread buffer)
  (let ((cont (maybe-get-continuation buffer))
	(thread (buffer-get buffer 'THREAD)))
    (if (and thread cont)
	(if (eq? thread editor-thread)
	    (signal-thread-event editor-thread (lambda () (cont unspecific)))
	    (restart-thread thread #f #f)))))

;;;addition for when debugger is called from a break
;;;should quit the debugger, and give the continuation
;;;a value to proceed with (restarting that thread)
;;;if in a normal error debug it will envoke the standard
;;;restarts
(define-command quit-with-restart-value
  "Quit the breakpoint, exiting with a specified value."
  ()
  (lambda ()
    (let* ((buffer (current-buffer))
	   (thread (buffer-get buffer 'THREAD)))
      (if (thread? thread)
	  (let ((value (prompt-for-expression-value
			"Please enter a value to continue with"))
		(cont (maybe-get-continuation buffer)))
	    (buffer-remove! buffer 'THREAD)
	    ((ref-command browser-quit))
	    (cond ((eq? thread editor-thread)
		   (signal-thread-event editor-thread (lambda ()
							(cont value))))
		  (else
		   (set! value? #t)
		   (restart-thread thread #t (lambda ()
					       (cont value))))))
	  (invoke-restarts #f)))))

(define (maybe-get-continuation buffer)
  (let ((object (browser/object (buffer-get buffer 'BROWSER))))
    (and (continuation? object)
	 object)))

;;;Method for invoking the standard restarts from within the
;;;debugger.
(define (invoke-restarts avoid-deletion?)
    (let* ((mark (current-point))
	   (bline (mark->bline mark))
	   (browser (bline/browser bline))
	   (buffer
	    (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f))
	   (condition
	    (browser/object browser)))
      (if (condition? condition)
	  (fluid-let ((prompt-for-confirmation
		       (lambda (prompt #!optional port)
			 port
			 (call-with-interface-port (buffer-end buffer)
			   (lambda (port)
			     port
			     (prompt-for-yes-or-no? prompt)))))
		      (prompt-for-evaluated-expression
		       (lambda (prompt #!optional environment port)
			 port
			 (call-with-interface-port (buffer-end buffer)
			   (lambda (port)
			     port
			     (repl-eval (prompt-for-expression prompt)
					environment)))))
		      (hook/invoke-restart
		       (lambda (continuation arguments)
			 (invoke-continuation continuation
					      arguments
					      avoid-deletion?))))
	    (call-with-interface-port
	     (let ((buff (new-buffer " *debug*-RESTARTS")))
	       (add-browser-buffer! browser buff)
	       (pop-up-buffer buff #f)
	       (buffer-start buff))
	     (lambda (port)
	       (write-string "  " port)
	       (write-condition-report condition port)
	       (debugger-newline port)
	       (command/condition-restart
		(make-initial-dstate condition)
		port))))
	  (message "No condition to restart from."))))

(define (call-with-interface-port mark receiver)
  (let ((mark (mark-left-inserting-copy mark)))
    (let ((value (receiver (make-port interface-port-type mark))))
      (mark-temporary! mark)
      value)))

(define interface-port-type
  (make-port-type
   `((write-char
      ,(lambda (port char)
	 (guarantee 8-bit-char? char)
	 (region-insert-char! (port/state port) char)
	 1))
     (prompt-for-confirmation
      ,(lambda (port prompt)
	 (declare (ignore port))
	 (prompt-for-confirmation? prompt)))
     (prompt-for-expression
      ,(lambda (port prompt)
	 (declare (ignore port))
	 (prompt-for-expression prompt))))
   #f))

(define (invoke-continuation continuation arguments avoid-deletion?)
  (let ((buffer (current-buffer)))
    (if (and (not avoid-deletion?)
	     (ref-variable debugger-quit-on-return?))
	((ref-command browser-quit)))
    ((or (buffer-get buffer 'INVOKE-CONTINUATION) apply)
     continuation arguments)))

;;;; Where

(define-command browser-where
  "Select an environment browser for this line's environment."
  ()
  (lambda ()
    (select-buffer
     (bline/environment-browser-buffer (current-selected-line)))))

(define (bline/environment-browser-buffer bline)
  (let ((environment (bline/evaluation-environment bline)))
    (bline/attached-buffer bline 'ENVIRONMENT-BROWSER
      (lambda ()
	(or (find (lambda (buffer)
		    (let ((browser (buffer-get buffer 'BROWSER)))
		      (and browser (eq? environment (browser/object browser)))))
		  (buffer-list))
	    (environment-browser-buffer environment))))))

(define (bline/attached-buffer bline type make-buffer)
  (let ((buffer (1d-table/get (bline/properties bline) type #f)))
    (if (and buffer (buffer-alive? buffer))
	buffer
	(let ((buffer (make-buffer)))
	  (1d-table/put! (bline/properties bline) type buffer)
	  (add-browser-buffer! (bline/browser bline) buffer)
	  buffer))))

(define (current-selected-line)
  (let ((bline (browser/selected-line (buffer-browser (current-buffer)))))
    (if (not bline)
	(editor-error "There is no selected line; please select one."))
    bline))

(define (bline/evaluation-environment bline)
  (let ((get-environment
	 (1d-table/get (bline-type/properties (bline/type bline))
		       'GET-ENVIRONMENT
		       #f))
	(lose
	 (lambda () (editor-error "The selected line has no environment."))))
    (if get-environment
	(let ((environment (get-environment bline)))
	  (if (environment? environment)
	      environment
	      (lose)))
	(lose))))

;;;; Browser Lines

(define-record-type <browser-line>
    (%make-bline start-mark object type parent depth next prev offset
		 properties)
    bline?

  ;; Index of this bline within browser lines vector.  #F if line is
  ;; invisible.
  (index bline/index set-bline/index!)

  ;; Line start within browser buffer.  #F if line is invisible.
  (start-mark bline/start-mark set-bline/start-mark!)

  ;; Object that this line represents.
  (object bline/object)

  ;; Type of OBJECT.  This type is specific to the browser; it tells
  ;; the browser how to manipulate OBJECT.
  (type bline/type)

  ;; BLINE representing the object that this object is a component of,
  ;; or #F if none.
  (parent bline/parent)

  ;; Nonnegative integer indicating the depth of this object in the
  ;; component nesting.
  (depth bline/depth)

  ;; BLINEs representing the objects that are adjacent to this one in
  ;; the component ordering, or #F if none.
  (next bline/next set-bline/next!)
  (prev bline/prev)

  ;; Nonnegative integer indicating the position of this object in the
  ;; component ordering.
  (offset bline/offset)

  (properties bline/properties))

(define (make-bline object type parent prev)
  (let ((bline
	 (%make-bline #f
		      object
		      type
		      parent
		      (if parent (+ (bline/depth parent) 1) 0)
		      #f
		      prev
		      (if prev (+ (bline/offset prev) 1) 0)
		      (make-1d-table))))
    (if prev
	(set-bline/next! prev bline))
    bline))

(define (bline/browser bline)
  (buffer-browser (mark-buffer (bline/start-mark bline))))

;;;; Browser Line Editing

(define (browser/n-lines browser)
  (vector-length (browser/lines browser)))

(define (browser/line browser index)
  (vector-ref (browser/lines browser) index))

(define (mark->bline mark)
  (let ((blines (browser/lines (buffer-browser (mark-buffer mark))))
	(group (mark-group mark))
	(index (mark-index mark)))
    (let loop ((low 0) (high (vector-length blines)))
      (and (fix:< low high)
	   (let ((middle (fix:quotient (fix:+ low high) 2)))
	     (let ((bline (vector-ref blines middle)))
	       (let ((ls (mark-index (bline/start-mark bline))))
		 (cond ((fix:< index ls) (loop low middle))
		       ((fix:<= index (line-end-index group ls)) bline)
		       (else (loop (fix:+ middle 1) high))))))))))

(define (mark->bline-index mark)
  (let ((bline (mark->bline mark)))
    (and bline
	 (bline/index bline))))

(define (delete-blines browser start end)
  (if (< start end)
      (let ((bv (browser/lines browser)))
	(if (subvector-find-next-element bv start end
					 (browser/selected-line browser))
	    (unselect-bline browser))
	(let ((nbv (vector-length bv)))
	  (let ((bv* (make-vector (- nbv (- end start)))))
	    (do ((i 0 (+ i 1)))
		((= i start))
	      (vector-set! bv* i (vector-ref bv i)))
	    (do ((i end (+ i 1))
		 (j start (+ j 1)))
		((= i nbv))
	      (let ((bline (vector-ref bv i)))
		(set-bline/index! bline j)
		(vector-set! bv* j bline)))
	    (let ((start-mark (bline/start-mark (vector-ref bv start))))
	      (with-buffer-open start-mark
		(lambda ()
		  (delete-string
		   start-mark
		   (if (< end nbv)
		       (bline/start-mark (vector-ref bv end))
		       (buffer-end (browser/buffer browser)))))))
	    (set-browser/lines! browser bv*))))))

(define (insert-blines browser index blines)
  (if (not (null? blines))
      (let ((bv (browser/lines browser))
	    (n-blines (length blines)))
	(let ((nbv (vector-length bv)))
	  (let ((bv* (make-vector (+ nbv n-blines))))
	    (do ((i 0 (+ i 1)))
		((= i index))
	      (vector-set! bv* i (vector-ref bv i)))
	    (do ((blines blines (cdr blines))
		 (i index (+ i 1)))
		((null? blines))
	      (let ((bline (car blines)))
		(set-bline/index! bline i)
		(vector-set! bv* i bline)))
	    (do ((i index (+ i 1))
		 (j (+ index n-blines) (+ j 1)))
		((= i nbv))
	      (let ((bline (vector-ref bv i)))
		(set-bline/index! bline j)
		(vector-set! bv* j bline)))
	    (let ((start-mark
		   (if (< index nbv)
		       (bline/start-mark (vector-ref bv index))
		       (buffer-end (browser/buffer browser)))))
	      (with-buffer-open start-mark
		(lambda ()
		  (let ((mark (mark-left-inserting-copy start-mark))
			(columns 79))
		    (for-each
		     (lambda (bline)
		       (let ((index (mark-index mark))
			     (indentation
			      (+ 1
				 (* summary-indentation-increment
				    (bline/depth bline)))))
			 (insert-horizontal-space indentation mark)
			 (let ((summary
				(call-with-truncated-output-string
				 (max summary-minimum-columns
				      (- columns indentation 4))
				 (lambda (port)
				   (parameterize ((current-output-port port))
				     ((bline-type/write-summary
				       (bline/type bline))
				      bline
				      (current-output-port)))))))
			   (insert-string (cdr summary) mark)
			   (if (car summary)
			       (insert-string " ..." mark)))
			 (insert-newline mark)
			 (set-bline/start-mark!
			  bline
			  (make-permanent-mark (mark-group mark) index #t))))
		     blines)
		    (mark-temporary! mark)))))
	    (set-browser/lines! browser bv*))))))

(define summary-indentation-increment 3)
(define summary-minimum-columns 10)

;;;; Browser Line Types

(define-record-type <browser-line-type>
    (%make-bline-type write-summary write-description selection-mark
		      properties)
    bline-type?

  ;; Procedure that is called to generate the browser line that
  ;; represents this object.  Two arguments: BLINE and PORT.  The
  ;; summary of BLINE is written to PORT.  The summary should fit on
  ;; one line; PORT will limit the number of characters that can be
  ;; printed so that it fits.
  (write-summary bline-type/write-summary)

  ;; Procedure that is called to generate a full description of the
  ;; object.  Two arguments: BLINE and PORT.  This description may use
  ;; multiple lines; it will be presented in its own buffer, so the
  ;; presentation style is not very constrained.  This component may
  ;; be #F to indicate that the object is not normally viewed.
  (write-description bline-type/write-description)

  ;; Procedure that generates the standard mark at which the point
  ;; should be placed when this object is selected.  One argument:
  ;; BLINE.  This component may be a nonnegative exact integer meaning
  ;; an offset from the START-MARK of the bline.
  (selection-mark bline-type/selection-mark)

  (properties bline-type/properties))

(define (make-bline-type write-summary write-description selection-mark)
  (%make-bline-type write-summary
		    write-description
		    selection-mark
		    (make-1d-table)))

(define (make-continuation-bline expander parent prev)
  (make-bline expander bline-type:continuation-line parent prev))

(define (continuation-line/write-summary bline port)
  bline
  (write-string "--more--" port))

(define bline-type:continuation-line
  (make-bline-type continuation-line/write-summary #f 0))

(define (bline/continuation? bline)
  (eq? (bline/type bline) bline-type:continuation-line))

(define (replace-continuation-bline bline)
  (let ((browser (bline/browser bline))
	(index (bline/index bline))
	(expansion ((bline/object bline))))
    (delete-blines browser index (+ index 1))
    (insert-blines browser index expansion)
    (car expansion)))

;;;; Control Variables

(define (boolean-or-ask? object)
  (or (boolean? object)
      (eq? 'ASK object)))

(define-variable debugger-one-at-a-time?
  "Allow only one debugger buffer to exist at a given time.
#T means delete an existing debugger buffer before making a new one.
#F means leave existing buffers alone.
'ASK means ask user what to do each time."
  'ASK
  boolean-or-ask?)

(define-variable debugger-max-subproblems
  "Maximum number of subproblems displayed when debugger starts.
Set this variable to #F to disable this limit."
  10
  (lambda (object)
    (or (not object)
	(and (exact-integer? object)
	     (> object 0)))))

(define-variable debugger-confirm-return?
  "True means prompt for confirmation in \"return\" commands.
The prompting occurs prior to returning the value."
  #t
  boolean?)

(define-variable debugger-quit-on-return?
  "True means quit debugger when executing a \"return\" command.
Quitting the debugger kills the debugger buffer and any associated buffers."
  #t
  boolean?)

(define-variable debugger-quit-on-restart?
  "True means quit debugger when executing a \"restart\" command.
Quitting the debugger kills the debugger buffer and any associated buffers."
  #t
  boolean?)

;;; Limited this because the bindings are now pretty-printed.

(define-variable environment-package-limit
  "Packages with more than this number of bindings will be abbreviated.
Set this variable to #F to disable this abbreviation."
  10
  (lambda (object)
    (or (not object)
	(exact-nonnegative-integer? object))))

(define-variable debugger-show-help-message?
  "True means show the help message, false means don't."
  #T
  boolean?)

(define-variable debugger-start-new-frame?
  "#T means create a new frame whenever the debugger is invoked.
#F means continue in same frame.
'ASK means ask user."
  #T
  boolean-or-ask?)
(define edwin-variable$debugger-start-new-screen?
  edwin-variable$debugger-start-new-frame?)

(define-variable debugger-hide-system-code?
  "True means don't show subproblems created by the runtime system."
  #T
  boolean?)

(define-variable debugger-show-frames?
  "If true show the environment frames in the description buffer.
If false show the bindings without frames."
  #T
  boolean?)

(define-variable debugger-show-inner-frame-topmost?
  "Affects the debugger display when DEBUGGER-SHOW-FRAMES? is true.
If false, frames are displayed with the outer (most global) frame topmost,
like in a 6.001 style environment diagram.  This is the default.
If true, frames are display innermost first."
  #F
  boolean?)

(define-variable debugger-compact-display?
  "If true, the debugger omits some blank lines.
If false, more blank lines are produced between display elements.
This variable is usually set to #F, but setting it to #T is useful
to get more information in a short window, for example, when using
a fixed size terminal."
  #F
  boolean?)

;;; These bindings are included only because they are exported by the
;;; alternate debugger, artdebug, which also lives in this package.
;;; They appear to CREF to be needed yet not bound.

(define edwin-variable$debugger-expand-reductions?)
(define edwin-variable$debugger-open-markers?)
(define edwin-variable$debugger-split-window?)
(define edwin-variable$debugger-verbose-mode?)

;;;; Predicates

;;; Determines if a frame is marked.

(define (system-frame? stack-frame)
  (stack-frame/repl-eval-boundary? stack-frame))

;;; Bad implementation to determine for breaks if a value to proceed
;;; with is desired.

(define value? #f)

(define (invalid-subexpression? subexpression)
  (or (debugging-info/undefined-expression? subexpression)
      (debugging-info/unknown-expression? subexpression)))

(define (invalid-expression? expression)
  (or (debugging-info/undefined-expression? expression)
      (debugging-info/compiled-code? expression)))

;;;; Help Messages

;;; The help messages for the debugger

(define where-help-message
"     COMMANDS:  ? - Help  q - Quit environment browser

This is an environment-browser buffer.

Lines identify environment frames.
The buffer below shows the bindings of the selected environment.
-----------")

(define debugger-help-message
"     COMMANDS:  ? - Help  q - Quit debugger  e - Environment browser

This is a debugger buffer.

Lines identify stack frames, most recent first.

   Sx means frame is in subproblem number x.
   Ry means frame is reduction number y.

The buffer below shows the current subproblem or reduction.
-----------")

;;;; Debugger entry point

(define starting-debugger? #f)

(define (debug-scheme-error error-type condition ask?)
  (if starting-debugger?
      (quit-editor-and-signal-error condition)
      (begin
	(let ((start-debugger
	       (lambda ()
		 (fluid-let ((starting-debugger? #t))
		   (select-continuation-browser-buffer condition)))))
	  (if ask?
	      (if (cleanup-pop-up-buffers
		   (lambda ()
		     (standard-error-report error-type condition #t)
		     (editor-beep)
		     (prompt-for-confirmation? "Start debugger")))
		  (start-debugger))
	      (begin
		(start-debugger)
		(message (string-capitalize (symbol->string error-type))
			 " error")
		(editor-beep))))
	(return-to-command-loop condition))))

(define (select-continuation-browser-buffer object #!optional thread)
  (set! value? #f)
  (let ((buffers (find-debugger-buffers)))
    (if (and (pair? buffers)
	     (null? (cdr buffers))
	     (if (eq? 'ASK (ref-variable debugger-one-at-a-time? #f))
		 (prompt-for-confirmation?
		  "Another debugger buffer exists.  Delete it")
		 (ref-variable debugger-one-at-a-time? #f)))
	(kill-buffer (car buffers))))
  (let ((buffer (continuation-browser-buffer object)))
    (let ((thread (and (not (default-object? thread)) thread)))
      (if thread
	  (buffer-put! buffer 'THREAD thread)))
    (let ((screen (make-debug-screen buffer)))
      (if screen
	  (select-screen screen)
	  (select-buffer buffer)))
    ((ref-command browser-select-line) (buffer-point buffer))))

(define-command browse-continuation
  "Invoke the continuation-browser on CONTINUATION."
  "XBrowse Continuation"
  select-continuation-browser-buffer)

(define (make-debug-screen buffer)
  (and (multiple-screens?)
       (let ((new-screen? (ref-variable debugger-start-new-screen? buffer)))
	 (if (eq? new-screen? 'ASK)
	     (prompt-for-confirmation? "Start debugger in new screen")
	     new-screen?))
       (let ((screen (apply make-screen buffer (make-debug-screen-args))))
	 (set-browser/new-screen! (buffer-browser buffer) screen)
	 screen)))

(define (make-debug-screen-args)
  (case (display-type/name (current-display-type))
    ((X)
     (cond ((string? default-screen-geometry)
	    (list default-screen-geometry))
	   ((eq? default-screen-geometry 'ASK)
	    (let ((geometry
		   (let loop ((default default-screen-geometry))
		     (let ((geometry
			    (prompt-for-string "Please enter a geometry"
					       default)))
		       (if (geometry? geometry)
			   geometry
			   (loop geometry))))))
	      (set! default-screen-geometry geometry)
	      geometry))
	   (else '())))
    (else '())))

(define (geometry? geometry)
  (let ((geometry-pattern
	 "[0-9]+x[0-9]+\\(-[0-9]+\\|+[0-9]+\\|\\)\\(-[0-9]+\\|+[0-9]+\\|\\)"))
    (re-string-match (re-compile-pattern geometry-pattern #f) geometry)))

(define default-screen-geometry #f)

(define (continuation-browser-buffer object)
  (let ((browser
	 (make-browser "*debug*"
		       (ref-mode-object continuation-browser)
		       object))
	(blines
	 (continuation->blines
	  (cond ((continuation? object)
		 object)
		((condition? object)
		 (condition/continuation object))
		(else
		 (error:wrong-type-argument object
					    "condition or continuation"
					    'CONTINUATION-BROWSER-BUFFER)))
	  (ref-variable debugger-max-subproblems))))
    (let ((buffer (browser/buffer browser)))
      (let ((mark (buffer-end buffer)))
	(with-buffer-open mark
	  (lambda ()
	    (call-with-output-mark mark
	      (lambda (port)
		(if (ref-variable debugger-show-help-message?)
		    (write-string debugger-help-message port))
		(debugger-newline port)
		(if (condition? object)
		    (begin
		      (write-string "The " port)
		      (write-string (if (condition/error? object)
					"error"
					"condition")
				    port)
		      (write-string " that started the debugger is:" port)
		      (debugger-newline port)
		      (debugger-newline port)
		      (write-string "  " port)
		      (with-output-highlighted port
			(lambda ()
			  (write-condition-report object port)))
		      (debugger-newline port)))
		(debugger-newline port))))))
      (insert-blines browser 0 blines)
      (set-buffer-point! buffer
			 (if (null? blines)
			     (buffer-end buffer)
			     (bline/start-mark (car blines))))
      buffer)))

(define (find-debugger-buffers)
  (filter (let ((debugger-mode (ref-mode-object continuation-browser)))
	    (lambda (buffer)
	      (eq? (buffer-major-mode buffer) debugger-mode)))
	  (buffer-list)))

;;;; Continuation Browser Mode

(define-major-mode continuation-browser read-only "Debug"
  "                     ******* Debugger Help *******

Commands:

`mouse-button-1'
     Select a subproblem or reduction and display information in the
     description buffer.

`C-n'
`down-arrow'
     Move the cursor down the list of subproblems and reductions and
     display info in the description buffer.

`C-p'
`up-arrow'
     Move the cursor up the list of subproblems and reductions and
     display info in the description buffer.

`e'  Show the environment structure.

`q'  Quit the debugger, destroying its window.

`p'  Invoke the standard restarts.

`SPC'
     Display info on current item in the description buffer.

`?'  Display help information.

   Each line beginning with `S' represents either a subproblem or stack
frame.  A subproblem line may be followed by one or more indented lines
\(beginning with the letter `R') which represent reductions associated
with that subproblem.  The subproblems are indexed with the natural
numbers.  To obtain a more complete description of a subproblem or
reduction, click the mouse on the desired line or move the cursor to the
line using the arrow keys (or `C-n' and `C-p').  The description buffer
will display the additional information.

   The description buffer contains three major regions.  The first
region contains a pretty printed version of the current expression. The
current subproblem within the expression is highlighted.  The second
region contains a representation of the frames of the environment of the
current expression.  The bindings of each frame are listed below the
frame header.  If there are no bindings in the frame, none will be
listed.  The frame of the current expression is preceeded with ==>.

   The bottom of the description buffer contains a region for evaluating
expressions in the environment of the selected subproblem or reduction.
This is the only portion of the buffer where editing is possible.  This
region can be used to find the values of variables in different
environments; you cannot, however, use mutators (set!, etc.) on compiled
code.

   Typing  `e' creates a new buffer in which you may browse through the
current environment.  In this new buffer, you can use the mouse, the
arrows, or `C-n' and `C-p' to select lines and view different
environments.  The environments listed are the same as those in the
description buffer.  If the selected environment structure is too large
to display (if there are more than `environment-package-limit' items in
the environment) an appropriate message is displayed.  To display the
environment in this case, set the `environment-package-limit' variable
to  `#f'.  This process is initiated by the command `M-x set-variable'.
You can not use `set!' to set the variable because it is an editor
variable and does not exist in the current scheme environment.  At the
bottom of the new buffer is a region for evaluating expressions similar
to that of the description buffer.

   The appearance of environment displays is controlled by the editor
variables `debugger-show-inner-frame-topmost?' and `debugger-compact-display?'
which affect the ordering of environment frames and the line spacing
respectively.

   Type `q' to quit the debugger, killing its primary buffer and any
others that it has created.

   NOTE: The debugger creates discription buffers in which debugging
information is presented.  These buffers are given names beginning with
spaces so that they do not appear in the buffer list; they are
automatically deleted when you quit the debugger.  If you wish to keep
one of these buffers, simply rename it using `M-x rename-buffer': once
it has been renamed, it will not be deleted automatically.")

(define-key 'continuation-browser #\p 'quit-with-restart-value)
(define-key 'continuation-browser down 'browser-next-line)
(define-key 'continuation-browser up 'browser-previous-line)
(define-key 'continuation-browser button1-down 'debugger-mouse-select-bline)
(define-key 'continuation-browser #\c-n 'browser-next-line)
(define-key 'continuation-browser #\c-p 'browser-previous-line)
(define-key 'continuation-browser #\? 'describe-mode)
(define-key 'continuation-browser #\q 'browser-quit)
(define-key 'continuation-browser #\space 'browser-select-line)
(define-key 'continuation-browser #\e 'browser-where)

;;;; Subproblems

;; A continuation consists of subproblems.  A subproblem has
;; expression information that identifies what the subproblem means.
;; It additionally has reductions and an environment.  Similarly,
;; reductions have expression and environment information.
;; Environments consist of environment frames, and each frame consists
;; of bindings.  Subproblems, reductions, and environment frames are
;; ordered; bindings are not.

;;; Stops displaying subproblems past marked frame by default.

(define (continuation->blines continuation limit)
  (let ((beyond-system-code #f))
    (let loop ((frame (continuation/first-subproblem continuation))
	       (prev #f)
	       (n 0))
      (if (not frame)
	  '()
	  (let* ((next-subproblem
		  (lambda (bline)
		    (loop (stack-frame/next-subproblem frame)
			  bline
			  (+ n 1))))
		 (walk-reductions
		  (lambda (bline reductions)
		    (cons bline
			  (let loop ((reductions reductions) (prev #f))
			    (if (null? reductions)
				(next-subproblem bline)
				(let ((bline
				       (make-bline (car reductions)
						   bline-type:reduction
						   bline
						   prev)))
				  (cons bline
					(loop (cdr reductions) bline))))))))
		 (continue
		  (lambda ()
		    (let* ((subproblem (stack-frame->subproblem frame n)))
		      (if debugger:student-walk?
			  (let ((reductions
				 (subproblem/reductions subproblem)))
			    (if (null? reductions)
				(let ((bline
				       (make-bline subproblem
						   bline-type:subproblem
						   #f
						   prev)))
				  (cons bline
					(next-subproblem bline)))
				(let ((bline
				       (make-bline (car reductions)
						   bline-type:reduction
						   #f
						   prev)))
				  (walk-reductions bline
						   (if (> n 0)
						       '()
						       (cdr reductions))))))
			  (walk-reductions
			   (make-bline subproblem
				       bline-type:subproblem
				       #f
				       prev)
			   (subproblem/reductions subproblem)))))))
	    (cond ((and (not (ref-variable debugger-hide-system-code?))
			(system-frame? frame))
		   (loop (stack-frame/next-subproblem frame)
			 prev
			 n))
		  ((or (and limit (>= n limit))
		       (if (system-frame? frame)
			   (begin (set! beyond-system-code #t) #t)
			   #f)
		       beyond-system-code)
		   (list (make-continuation-bline continue #f prev)))
		  (else (continue))))))))

(define-record-type <subproblem>
    (make-subproblem stack-frame expression environment subexpression number)
    subproblem?
  (stack-frame subproblem/stack-frame)
  (expression subproblem/expression)
  (environment subproblem/environment)
  (subexpression subproblem/subexpression)
  (number subproblem/number))

(define (stack-frame->subproblem frame number)
  (receive (expression environment subexpression)
      (stack-frame/debugging-info frame)
    (make-subproblem frame expression environment subexpression number)))

(define-record-type <reduction>
    (make-reduction subproblem expression environment number)
    reduction?
  (subproblem reduction/subproblem)
  (expression reduction/expression)
  (environment reduction/environment)
  (number reduction/number))

(define (subproblem/reductions subproblem)
  (let ((frame (subproblem/stack-frame subproblem)))
    (let loop ((reductions (stack-frame/reductions frame)) (n 0))
      (if (pair? reductions)
	  (cons (make-reduction subproblem
				(caar reductions)
				(cadar reductions)
				n)
		(loop (cdr reductions) (+ n 1)))
	  '()))))

(define (subproblem/write-summary bline port)
  (let* ((subproblem (bline/object bline))
	 (frame (subproblem/stack-frame subproblem)))
    (if (system-frame? frame)
	(write-string "***************Internal System Code Follows***********"
		      port)
	(begin
	  (write-string "S" port)
	  (write-string (bline/offset-string (subproblem/number subproblem))
			port)
	  (write-string " " port)
	  (let ((expression (subproblem/expression subproblem))
		(subexpression (subproblem/subexpression subproblem)))
	    (cond ((debugging-info/compiled-code? expression)
		   (write-string ";unknown compiled code" port))
		  ((not (debugging-info/undefined-expression? expression))
		   (parameterize ((param:print-primitives-by-name? #t))
		     (write
		      (unsyntax (if (invalid-subexpression? subexpression)
				    expression
				    subexpression)))))
		  ((debugging-info/noise? expression)
		   (write-string ";" port)
		   (write-string ((debugging-info/noise expression) #f)
				 port))
		  (else
		   (write-string ";undefined expression" port))))))))

(define (subproblem/write-description bline port)
  (let* ((subproblem (bline/object bline))
	 (frame (subproblem/stack-frame subproblem)))
    (cond ((system-frame? frame)
	   (write-string "The subproblems which follow are part of the " port)

	   (write-string "internal system workings." port))
	  (else
	   (write-string "                         SUBPROBLEM LEVEL: " port)
	   (write (subproblem/number subproblem) port)
	   (debugger-newline port)
	   (debugger-newline port)
	   (let ((expression (subproblem/expression subproblem))
		 (frame (subproblem/stack-frame subproblem)))
	     (cond ((not (invalid-expression? expression))
		    (write-string (if (stack-frame/compiled-code? frame)
				      "COMPILED expression"
				      "Expression")
				  port)
		    (write-string " (from stack):" port)
		    (debugger-newline port)
		    (write-string
		     " Subproblem being executed is highlighted.\n"
		     port)
		    (debugger-newline port)
		    (let ((subexpression
			   (subproblem/subexpression subproblem)))
		      (if (invalid-subexpression? subexpression)
			  (debugger-pp expression expression-indentation port)
			  (debugger-pp-highlight-subexpression
			   expression
			   subexpression
			   expression-indentation
			   port))))
		   ((debugging-info/noise? expression)
		    (write-string ((debugging-info/noise expression) #t)
				  port))
		   (else
		    (write-string (if (stack-frame/compiled-code? frame)
				      "Compiled expression unknown"
				      "Expression unknown")
				  port)
		    (debugger-newline port)
		    (write (stack-frame/return-address frame) port))))
	   (let ((environment (subproblem/environment subproblem)))
	     (if (not (debugging-info/undefined-environment? environment))
		 (begin
		   (debugger-newline port)
		   (debugger-newline port)
		   (desc-show-environment-name-and-bindings environment
							    port))))))))

(define bline-type:subproblem
  (make-bline-type subproblem/write-summary
		   subproblem/write-description
		   1))

(1d-table/put! (bline-type/properties bline-type:subproblem)
	       'GET-ENVIRONMENT
	       (lambda (bline)
		 (subproblem/environment (bline/object bline))))

;;;; Reductions

(define (reduction/write-summary bline port)
  (let ((reduction (bline/object bline)))
    (if (bline/parent bline)
	(begin
	  (write-string "R" port)
	  (write-string (bline/offset-string (reduction/number reduction))
			port))
	(begin
	  (write-string "S" port)
	  (write-string
	   (bline/offset-string
	    (subproblem/number (reduction/subproblem reduction)))
	   port)))
    (write-string " " port)
    (parameterize ((param:print-primitives-by-name? #t))
      (write (unsyntax (reduction/expression reduction)) port))))

(define (reduction/write-description bline port)
  (let ((reduction (bline/object bline)))
    (write-string "              SUBPROBLEM LEVEL: " port)
    (write (subproblem/number (reduction/subproblem reduction)) port)
    (write-string "  REDUCTION NUMBER: " port)
    (write (reduction/number reduction) port)
    (debugger-newline port)
    (debugger-newline port)
    (write-string "Expression (from execution history):" port)
    (debugger-newline port)
    (debugger-newline port)
    (debugger-pp (reduction/expression reduction) expression-indentation port)
    (debugger-newline port)
    (debugger-newline port)
    (desc-show-environment-name-and-bindings (reduction/environment reduction)
					port)))

(define bline-type:reduction
  (make-bline-type reduction/write-summary
		   reduction/write-description
		   1))

(1d-table/put! (bline-type/properties bline-type:reduction)
	       'GET-ENVIRONMENT
	       (lambda (bline)
		 (reduction/environment (bline/object bline))))

;;;; Environments

(define-command browse-environment
  "Invoke the environment-browser on ENVIRONMENT."
  "XBrowse Environment"
  (lambda (environment)
    (select-buffer (environment-browser-buffer environment))))

;;; Adds a help line.

(define (environment-browser-buffer object)
  (let ((environment (->environment object)))
    (let ((browser
	   (make-browser "*where*"
			 (ref-mode-object environment-browser)
			 object))
	  (blines (environment->blines environment)))

      (let ((buffer (browser/buffer browser)))
	(let ((mark (buffer-end buffer)))
	  (with-buffer-open mark
	    (lambda ()
	      (call-with-output-mark
	       mark
	       (lambda (port)
		 (if (ref-variable debugger-show-help-message?)
		     (write-string where-help-message port))
		 (debugger-newline port))))))
	(insert-blines browser 0 blines)
	(if (null? blines)
	    (set-buffer-point! buffer (buffer-end buffer))
	    (select-bline (car blines)))
	buffer))))

(define (environment->blines environment)
  (let loop ((environment environment) (prev #f))
    (let ((bline (make-bline environment bline-type:environment #f prev)))
      (cons bline
	    (if (eq? #t (environment-has-parent? environment))
		(loop (environment-parent environment) bline)
		'())))))

(define-major-mode environment-browser read-only "Environment Browser"
  "             ********Environment Browser Help********

Commands:

`mouse-button-1'
     Select a subproblem or reduction and display information in the
     description buffer.

`C-n'
`down-arrow'
     Move the cursor down the list of subproblems and reductions and
     display info in the description buffer.

`C-p'
`up-arrow'
     Move the cursor up the list of subproblems and reductions and
     display info in the description buffer.

`q'
     Quit the environment browser, destroying its window.

`SPC'
     Display info on current item in the description buffer.

`?'
     Display help information.

   In this buffer, you can use the mouse, the arrows, or `C-n' and
`C-p' to select lines and view different environments.
If the selected environment structure is too large to display (if
there are more than `environment-package-limit' items in the
environment) an appropriate message is displayed.  To display the
environment in this case, set the `environment-package-limit' variable
to  `#f'.  This process is initiated by the command `M-x
set-variable'. You can not use `set!' to set the variable because it
is an editor variable and does not exist in the current scheme
environment.

   The bottom of the description buffer contains a region for evaluating
expressions in the environment of the selected subproblem or reduction.
This is the only portion of the buffer where editing is possible.  This
region can be used to find the values of variables in different
environments; you cannot, however, use mutators (set!, etc.) on
compiled code.

   Type `q' to quit the environment browser, killing its primary buffer
and any others that it has created.

NOTE: The environment browser creates discription buffers in which
debugging information is presented.  These buffers are given names
beginning with spaces so that they do not appear in the buffer list;
they are automatically deleted when you quit the debugger.  If you wish
to keep one of these buffers, simply rename it using `M-x rename-buffer':
once it has been renamed, it will not be deleted automatically.")

(define-key 'environment-browser down 'browser-next-line)
(define-key 'environment-browser up 'browser-previous-line)
(define-key 'environment-browser button1-down	'debugger-mouse-select-bline)
(define-key 'environment-browser #\c-n 'browser-next-line)
(define-key 'environment-browser #\c-p 'browser-previous-line)
(define-key 'environment-browser #\? 'describe-mode)
(define-key 'environment-browser #\q 'browser-quit)
(define-key 'environment-browser #\space 'browser-select-line)

(define (environment/write-summary bline port)
  (write-string "E" port)
  (write-string (bline/offset-string (bline/offset bline)) port)
  (write-string " " port)
  (show-environment-name (bline/object bline) port))

(define (environment/write-description bline port)
  (let ((environment (bline/object bline)))
    (show-environment-name-and-bindings environment port)))

(define (show-environment-name-and-bindings environment port)
  (show-environment-name environment port)
  (debugger-newline port)
  (debugger-newline port)
  (let ((names (environment-bound-names environment))
	(name? (environment-has-name? environment))
	(finish
	 (lambda (names)
	   (debugger-newline port)
	   (for-each (lambda (name)
		       (myprint-binding name
					(environment-safe-lookup environment
								 name)
					port))
	     names))))
    (cond ((null? names)
	   (write-string " has no bindings" port))
	  ((and name?
		(let ((limit (ref-variable environment-package-limit)))
		  (and limit
		       (let ((n (length names)))
			 (and (>= n limit)
			      (begin
				(write-string " has " port)
				(write n port)
				(write-string " bindings (first " port)
				(write limit port)
				(write-string " shown):" port)
				(finish (take names limit))
				#t)))))))
	  (else
	   (write-string "  BINDINGS:" port)
	   (finish (if name? (sort names symbol<?) names)))))
  (debugger-newline port)
  (debugger-newline port)
  (write-string
   "---------------------------------------------------------------------"
   port))

;;;This does some stuff who's end product is to pp the bindings
(define (myprint-binding name value port)
  (let ((x-size (output-port/x-size port)))
    (debugger-newline port)
    (let ((name1
	   (output-to-string (quotient x-size 2)
	     (lambda ()
	       (write-dbg-name name (current-output-port))))))
      (write-string name1 port)
      (cond ((unassigned-reference-trap? value)
	     (write-string " is unassigned" port))
	    ((macro-reference-trap? value)
	     (write-string " is a syntactic keyword" port))
	    (else
	     (let ((separator " = "))
	       (write-string separator port)
	       (let ((indentation
		      (+ (string-length name1)
			 (string-length separator))))
		 (write-string (string-tail
				(call-with-output-string
				  (lambda (port)
				    (pretty-print value port #t indentation)))
				indentation)
			       port))))))
    (debugger-newline port)))

(define bline-type:environment
  (make-bline-type environment/write-summary
		   environment/write-description
		   1))

(1d-table/put! (bline-type/properties bline-type:environment)
	       'GET-ENVIRONMENT
	       bline/object)

(define (bline/offset-string number)
  (let ((string (number->string number)))
    (if (< (string-length string) offset-string-min)
	(string-pad-right string offset-string-min)
	string)))

(define offset-string-min
  2)

(define (with-buffer-open mark thunk)
  (with-read-only-defeated mark thunk)
  (buffer-not-modified! (mark-buffer mark)))

(define (desc-show-environment-name-and-bindings environment port)
  (write-string
   "---------------------------------------------------------------------"
   port)
  (if (ref-variable debugger-show-frames?)
      (show-frames-and-bindings environment port)
      (print-the-local-bindings environment port))
  (debugger-newline port)
  (write-string
   "---------------------------------------------------------------------"
   port))

(define (debugger-newline port)
  (if (ref-variable debugger-compact-display?)
      (fresh-line port)
      (newline port)))

(define (show-frames-and-bindings environment port)

  (define (envs environment)
    (cons environment
	  (if (environment-has-parent? environment)
	      (envs (environment-parent environment))
	      '())))

  (define (show-frames envs indents)
    (for-each (lambda (env indent)
		(debugger-newline port)
		(if (eq? env environment)
		    (let* ((pointer "==> ")
			   (pl (string-length pointer)))
		      (if (> (string-length indent) pl)
			  (write-string (string-tail indent pl) port))
		      (write-string pointer port))
		    (write-string indent port))
		(show-environment-name env port)
		(debugger-newline port)
		(show-environment-bindings-with-ind env indent port))
	      envs indents))

  (let ((env-list (envs environment)))
    (cond ((ref-variable debugger-show-inner-frame-topmost?)
	   (show-frames env-list (make-list (length env-list) "")))
	  (else
	   (show-frames (reverse env-list)
			(make-initialized-list (length env-list)
			  (lambda (i) (make-string (* i 2) #\space))))))))

(define (print-the-local-bindings environment port)
  (let ((names (get-all-local-bindings environment)))
    (let ((n-bindings (length names))
	  (finish
	   (lambda (names)
	     (for-each (lambda (name)
			 (let loop ((env environment))
			   (if (environment-bound? env name)
			       (print-binding-with-ind
				name
				(environment-safe-lookup env name)
				"  "
				port)
			       (loop (environment-parent env)))))
		       names))))
      (debugger-newline port)
      (show-environment-name environment port)
      (cond ((zero? n-bindings)
	     (debugger-newline port)
	     (write-string "    has no bindings" port)
	     (debugger-newline port))
	    ((> n-bindings (ref-variable environment-package-limit)))
	    (else
	     (debugger-newline port)
	     (debugger-newline port)
	     (write-string "  Local Bindings:" port)
	     (debugger-newline port)
	     (finish names))))))

(define (show-environment-name environment port)
  (write-string "ENVIRONMENT " port)
  (let ((name (environment-name environment)))
    (if name
	(begin
	  (write-string "named: " port)
	  (write name port))
	(begin
	  (write-string "created by " port)
	  (print-user-friendly-name environment port)))))

(define (get-all-local-bindings environment)
  (define (envs environment)
    (if (environment-has-parent? environment)
	(cons environment (envs (environment-parent environment))) ;
	'()))
  (let* ((env-list (envs environment))
	 (names1 (map (lambda (envir)
			(let ((names (environment-bound-names envir)))
			  (if (< (length names)
				 (ref-variable environment-package-limit))
			      names
			      '())))
		      env-list))
	 (names2 (reduce-right append '() names1))
	 (names3 (let loop ((l names2))
		     (if (null? l)
			 l
			 (cons (car l) (loop (delete (car l) l))))))
	 (names4 (sort names3 symbol<?)))
    names4))

(define (show-environment-bindings-with-ind environment ind port)
  (let ((names (environment-bound-names environment)))
    (let ((n-bindings (length names))
	  (finish
	   (lambda (names)
	     (debugger-newline port)
	     (for-each (lambda (name)
			 (print-binding-with-ind
			  name
			  (environment-safe-lookup environment name)
			  ind
			  port))
		       names))))
      (cond ((environment-has-name? environment)
	     (write-string (string-append ind "    has ") port)
	     (write n-bindings port)
	     (write-string
	      " bindings"
	      port)
	     (debugger-newline port))
	    ((zero? n-bindings)
	     #|(write-string (string-append ind "    has no bindings") port)
	     (debugger-newline port)|#)
	    ((> n-bindings (ref-variable environment-package-limit))
	     (write-string (string-append ind "    has ") port)
	     (write n-bindings port)
	     (write-string
	      " bindings (see editor variable environment-package-limit)"
	      port)
	     (debugger-newline port))
	    (else
	     (finish names))))))

(define (print-binding-with-ind name value ind port)
  (let* ((extra "    ")
	 (x-size
	  (- (output-port/x-size port)
	     (+ (string-length ind)
		(string-length extra)))))
    (write-string ind port)
    (write-string extra port)
    (let ((name
	   (output-to-string (quotient x-size 2)
	     (lambda ()
	       (write-dbg-name name (current-output-port))))))
      (write-string name port)
      (cond ((unassigned-reference-trap? value)
	     (write-string " is unassigned" port))
	    ((macro-reference-trap? value)
	     (write-string " is a syntactic keyword" port))
	    (else
	     (let ((separator " = "))
	       (write-string separator port)
	       (write-string
		(output-to-string (max 0
				       (- (- x-size 1)
					  (+ (string-length name)
					     (string-length separator))))
				  (lambda () (write value)))
		port)))))
    (debugger-newline port)))