#| -*-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.

|#

;;;; Inferior REPL Mode
;;; Package: (edwin inferior-repl)

(declare (usual-integrations))

(define-variable repl-enable-transcript-buffer
  "If true, record input and output from inferior REPLs in transcript buffer.
This flag has effect only when ENABLE-TRANSCRIPT-BUFFER is also true."
  #t
  boolean?)

(define-variable repl-error-decision
  "Controls how errors in an inferior REPL are handled.
There are three meaningful values:
#F	a nested error REPL is started
PROMPT	the user is prompted to decide whether to start the debugger
6001	like PROMPT, except that the error is always aborted"
  'PROMPT
  (lambda (object) (or (boolean? object) (memv object '(6001 PROMPT)))))

(define-variable repl-mode-locked
  "If true, user cannot change the mode of REPL and CMDL buffers."
  #t
  boolean?)

(define-variable inferior-repl-write-results
  "If true, results of evaluation commands are written in the REPL buffer.
This includes evaluation of expressions in other buffers.
Otherwise, only evaluation of expressions in the REPL buffer itself do this."
  #t
  boolean?)

(define (call-with-transcript-output-mark buffer procedure)
  (if (and (ref-variable repl-enable-transcript-buffer buffer)
	   (ref-variable enable-transcript-buffer buffer))
      (call-with-transcript-buffer
       (lambda (buffer)
	 (procedure (buffer-end buffer))))
      (procedure #f)))

(define-command repl
  "Run an inferior read-eval-print loop (REPL), with I/O through a buffer.
With no arguments, selects the current evaluation buffer,
 or creates a new one if there is none.
With one C-u, creates a new REPL buffer unconditionally.
With two C-u's, creates a new REPL buffer with a new evaluation environment.
  (Otherwise USER-INITIAL-ENVIRONMENT is used.)"
  "p"
  (lambda (argument)
    (select-buffer
     (let ((buffer (current-buffer)))
       (let ((make-new
	      (lambda (environment)
		(let ((repl-buffer (new-buffer initial-buffer-name)))
		  (start-inferior-repl! repl-buffer environment #f)
		  repl-buffer))))
	 (if (>= argument 16)
	     (make-new
	      (extend-top-level-environment system-global-environment))
	     (or (and (< argument 4) (current-repl-buffer* buffer))
		 (make-new user-initial-environment))))))))

(define-command set-inferior-repl-buffer
  "Select an inferior REPL buffer for evaluating this buffer's contents.
Subsequent evaluation commands executed in the current buffer will be
evaluated in the specified inferior REPL buffer."
  (lambda ()
    (list
     (find-buffer
      (let ((buffers (repl-buffer-list)))
	(prompt-for-string-table-name "REPL buffer"
				      (and (pair? buffers)
					   (buffer-name (car buffers)))
				      (alist->string-table
				       (map (lambda (buffer)
					      (cons (buffer-name buffer)
						    buffer))
					    buffers))
				      'DEFAULT-TYPE 'VISIBLE-DEFAULT
				      'REQUIRE-MATCH? #t))
      #t)))
  (lambda (repl-buffer)
    (set-local-repl-buffer! (current-buffer) repl-buffer)))

(define (start-inferior-repl! buffer environment message)
  (set-buffer-major-mode! buffer (ref-mode-object inferior-repl))
  (if (ref-variable repl-mode-locked)
      (buffer-put! buffer 'MAJOR-MODE-LOCKED #t))
  (if (environment? environment)
      (local-set-variable! scheme-environment environment buffer))
  (create-thread editor-thread-root-continuation
    (lambda ()
      (let ((port
	     (make-interface-port buffer
				  (let ((thread (current-thread)))
				    (detach-thread thread)
				    thread))))
	(attach-buffer-interface-port! buffer port)
	(parameterize ((param:exit-hook inferior-repl/exit)
		       (param:suspend-hook inferior-repl/suspend))
	  (dynamic-wind
	   (lambda () unspecific)
	   (lambda ()
	     (repl/start (make-repl #f
				    port
				    environment
				    #f
				    `((ERROR-DECISION ,error-decision))
				    user-initial-prompt)
			 (make-init-message message)))
	   (lambda ()
	     (signal-thread-event editor-thread
	       (lambda ()
		 (unwind-inferior-repl-buffer buffer))))))))
    buffer))

(define (make-init-message message)
  (if message
      (cmdl-message/append cmdl-message/init-inferior message)
      cmdl-message/init-inferior))

(define cmdl-message/init-inferior
  (cmdl-message/active
   (lambda (port)
     (set-working-directory-pathname!
      (buffer-default-directory (port/buffer port))))))

(define (inferior-repl/exit #!optional integer)
  (exit-current-thread (if (default-object? integer) 0 integer)))

(define (inferior-repl/suspend)
  unspecific)

(define (current-repl-buffer #!optional buffer)
  (let ((repl-buffer (current-repl-buffer* buffer)))
    (if (not repl-buffer)
	(error "No REPL to evaluate in."))
    repl-buffer))

(define (current-repl-buffer* #!optional buffer)
  (let ((buffer (->buffer buffer)))
    (if (repl-buffer? buffer)
	buffer
	(or (local-repl-buffer buffer)
	    (global-repl-buffer)))))

(define (local-repl-buffer buffer)
  (or (let ((wp (buffer-get buffer 'REPL-BUFFER #f)))
	(and (weak-pair? wp)
	     (let ((repl-buffer (weak-car wp)))
	       (and (repl-buffer? repl-buffer)
		    (buffer-alive? repl-buffer)
		    repl-buffer))))
      (begin
	(buffer-remove! buffer 'REPL-BUFFER)
	#f)))

(define (set-local-repl-buffer! buffer repl-buffer)
  (if repl-buffer
      (begin
	(if (not (repl-buffer? repl-buffer))
	    (error:wrong-type-argument repl-buffer "REPL buffer"
				       'SET-LOCAL-REPL-BUFFER!))
	(buffer-put! buffer 'REPL-BUFFER (weak-cons repl-buffer #f)))
      (begin
	(undefine-variable-local-value! buffer (ref-variable-object run-light))
	(buffer-remove! buffer 'REPL-BUFFER))))

(define (global-repl-buffer)
  (let ((buffers (repl-buffer-list)))
    (and (pair? buffers)
	 (car buffers))))

(define (repl-buffer-list)
  (set! repl-buffers (filter! buffer-alive? repl-buffers))
  repl-buffers)

(define (repl-buffer? buffer)
  (and (buffer? buffer)
       (buffer-interface-port buffer #f)))

(define repl-buffers)

(add-event-receiver! editor-initializations
  (lambda ()
    (set! repl-buffers '())
    unspecific))

(define (wait-for-input port mode ready? level)
  (signal-thread-event editor-thread
    (lambda ()
      (maybe-switch-modes! port mode)
      (let ((buffer (port/buffer port)))
	(local-set-variable!
	 mode-line-process
	 (list ": "
	       'RUN-LIGHT
	       (if (= level 1)
		   ""
		   (string-append " [level: " (number->string level) "]")))
	 buffer)
	(set-run-light! buffer #f)
	(inferior-thread-run-light! (port/output-registration port)))))
  (with-thread-events-blocked
   (lambda ()
     (do () ((ready? port))
       (suspend-current-thread)))))

(define (end-input-wait port)
  (set-run-light! (port/buffer port) #t)
  (signal-thread-event (port/thread port) #f))

(define (standard-prompt-spacing port)
  (fresh-line port)
  (newline port)
  (enqueue-output-operation! port
    (lambda (mark transcript?)
      transcript?
      (undo-boundary! mark)
      #t)))

(define (maybe-switch-modes! port mode)
  (let ((buffer (port/buffer port)))
    (let ((mode* (buffer-major-mode buffer)))
      (if (not (eq? mode* mode))
	  (if (or (eq? mode* (ref-mode-object inferior-repl))
		  (eq? mode* (ref-mode-object inferior-cmdl)))
	      ;; Modes are compatible, so no need to reset the buffer's
	      ;; variables and properties.
	      (begin
		(without-interrupts
		 (lambda ()
		   (set-car! (buffer-modes buffer) mode)
		   (switch-comtabs! buffer mode mode*)))
		(buffer-modeline-event! buffer 'BUFFER-MODES))
	      (begin
		(set-buffer-major-mode! buffer mode)
		(attach-buffer-interface-port! buffer port)))))))

(define (switch-comtabs! buffer new-mode old-mode)
  (let ((comtabs (buffer-comtabs buffer))
	(new-comtabs (mode-comtabs new-mode))
	(old-comtabs (mode-comtabs old-mode)))
    (if (eq? comtabs old-comtabs)
	(set-buffer-comtabs! buffer new-comtabs)
	(let loop ((previous comtabs))
	  (let ((comtabs (cdr previous)))
	    (cond ((eq? comtabs old-comtabs)
		   (set-cdr! previous new-comtabs))
		  ((not (pair? comtabs))
		   (warn ";Buffer's comtabs do not match its mode:" buffer))
		  (else
		   (loop comtabs))))))))

(define (attach-buffer-interface-port! buffer port)
  (if (not (memq buffer repl-buffers))
      (set! repl-buffers (append! repl-buffers (list buffer))))
  (buffer-put! buffer 'INTERFACE-PORT port)
  (add-kill-buffer-hook buffer kill-buffer-inferior-repl)
  (buffer-put! buffer 'COMINT-PROCESS-MARK inferior-repl-process-mark)
  (local-set-variable! comint-input-ring (port/input-ring port) buffer)
  (local-set-variable! comint-last-input-end
		       (mark-right-inserting-copy (buffer-end buffer))
		       buffer)
  (local-set-variable! comint-last-input-match #f buffer)
  (set-run-light! buffer #f))

(define (buffer-interface-port buffer error?)
  (or (buffer-get buffer 'INTERFACE-PORT #f)
      (and error?
	   (error "No inferior REPL for this buffer:" buffer))))

(define (kill-buffer-inferior-repl buffer)
  (let ((port (buffer-interface-port buffer #f)))
    (if port
	(let ((thread (port/thread port)))
	  (if (not (thread-dead? thread))
	      (signal-thread-event thread
		(lambda ()
		  (exit-current-thread unspecific)))))))
  (unwind-inferior-repl-buffer buffer))

(define (unwind-inferior-repl-buffer buffer)
  (without-interrupts
   (lambda ()
     (let ((port (buffer-interface-port buffer #f)))
       (if port
	   (begin
	     (deregister-inferior-thread! (port/output-registration port))
	     (if (eq? buffer (global-run-light-buffer))
		 (set-global-run-light! #f))
	     (set! repl-buffers (delq! buffer repl-buffers))
	     (let ((buffer (global-run-light-buffer)))
	       (if buffer
		   (set-global-run-light! (local-run-light buffer))))
	     (buffer-remove! buffer 'INTERFACE-PORT)))))))

(define (set-run-light! buffer run?)
  (let ((value (if run? "eval" "listen")))
    (if (eq? buffer (global-run-light-buffer))
	(set-global-run-light! value))
    (set-local-run-light! buffer value)
    (for-each (lambda (buffer*)
		(if (eq? buffer (local-repl-buffer buffer*))
		    (set-local-run-light! buffer* value)))
	      (buffer-list))))

(define (global-run-light-buffer)
  (and (evaluate-in-inferior-repl? #f)
       (global-repl-buffer)))

(define (set-global-run-light! value)
  (set-variable-default-value! (ref-variable-object run-light) value)
  (global-window-modeline-event!))

(define (local-run-light buffer)
  (ref-variable run-light buffer))

(define (set-local-run-light! buffer value)
  (local-set-variable! run-light value buffer)
  (buffer-modeline-event! buffer 'RUN-LIGHT))

(add-variable-assignment-daemon!
 (ref-variable-object evaluate-in-inferior-repl)
 (lambda (buffer variable) buffer variable (reset-run-light!)))

(define (reset-run-light!)
  (set-global-run-light!
   (let ((buffer (global-run-light-buffer)))
     (and buffer
	  (local-run-light buffer)))))

(define (error-decision repl condition)
  (let ((port (cmdl/port repl)))
    (if (interface-port? port)
	(let ((start-debugger
	       (lambda ()
		 (enqueue-output-operation! port
		   (lambda (mark transcript?)
		     mark
		     (if (not transcript?)
			 (start-continuation-browser port
						     condition))
		     #t)))))
	  (case (ref-variable repl-error-decision)
	    ((6001 #T)
	     (enqueue-output-operation! port
	       (lambda (mark transcript?)
		 (if (and (not transcript?)
			  (not (buffer-visible? (mark-buffer mark))))
		     (begin
		       (message "Evaluation error in "
				(buffer-name (mark-buffer mark))
				" buffer")
		       (editor-beep)))
		 #t))
	     (dynamic-wind
	      (lambda () unspecific)
	      (lambda ()
		(let loop ()
		  (fresh-line port)
		  (write-string
		   ";Type D to debug error, Q to quit back to REP loop: "
		   port)
		  (let ((char (read-command-char port (cmdl/level repl))))
		    (write-char char port)
		    (cond ((char-ci=? char #\d)
			   (fresh-line port)
			   (write-string ";Starting debugger..." port)
			   (start-debugger))
			  ((not (char-ci=? char #\q))
			   (beep port)
			   (loop))))))
	      cmdl-interrupt/abort-top-level))
	    ((PROMPT)
	     (if (let ((start? (ref-variable debug-on-evaluation-error #f)))
		   (if (eq? 'ASK start?)
		       (let loop ()
			 (fresh-line port)
			 (write-string ";Start debugger? (y or n): " port)
			 (let ((char
				(read-command-char port
						   (cmdl/level repl))))
			   (write-char char port)
			   (cond ((or (char-ci=? char #\y)
				      (char-ci=? char #\space))
				  (fresh-line port)
				  (write-string ";Starting debugger..."
						port)
				  #t)
				 ((or (char-ci=? char #\n)
				      (char-ci=? char #\rubout))
				  #f)
				 (else
				  (beep port)
				  (loop)))))
		       start?))
		 (start-debugger))))))))

;;;; Modes

(define-major-mode inferior-repl scheme "REPL"
  "Major mode for communicating with an inferior read-eval-print loop (REPL).
Editing and evaluation commands are like Scheme mode:

\\[lisp-indent-line] indents the current line for Scheme.
\\[indent-sexp] indents the next s-expression.
\\[scheme-complete-variable] completes the variable preceding point.
\\[show-parameter-list] shows the parameters of the call surrounding point.

\\[inferior-repl-eval-last-sexp] evaluates the expression preceding point.
\\[inferior-repl-eval-defun] evaluates the current definition.
\\[inferior-repl-eval-region] evaluates the current region.

When an error occurs, you can run the command-line debugger with (debug),
or you can run the windowed debugger:

\\[inferior-repl-debug] enters windowed debugger on the current error.

Expressions submitted for evaluation are saved in an expression history.
The history may be accessed with the following commands:

\\[comint-previous-input] cycles backwards through the history;
\\[comint-next-input] cycles forwards.
\\[comint-history-search-backward] searches backwards for a matching string;
\\[comint-history-search-forward] searches forwards.

The REPL may be controlled by the following commands:

\\[inferior-cmdl-abort-top-level] aborts evaluation, returns to top level.
\\[inferior-cmdl-abort-nearest] aborts evaluation, returns to current level.
\\[inferior-cmdl-abort-previous] aborts evaluation, goes up one level.
\\[inferior-cmdl-breakpoint] interrupts evaluation, enters a breakpoint.

\\{inferior-repl}"
  (lambda (buffer)
    (event-distributor/invoke! (ref-variable inferior-repl-mode-hook buffer)
			       buffer)))

(define-variable inferior-repl-mode-hook
  "An event distributor that is invoked when entering Inferior REPL mode."
  (make-event-distributor))

(define-key 'inferior-repl '(#\C-c #\C-b) 'inferior-cmdl-breakpoint)
(define-key 'inferior-repl '(#\C-c #\C-c) 'inferior-cmdl-abort-top-level)
(define-key 'inferior-repl '(#\C-c #\C-u) 'inferior-cmdl-abort-previous)
(define-key 'inferior-repl '(#\C-c #\C-x) 'inferior-cmdl-abort-nearest)

(define-key 'inferior-repl #\M-o 'undefined)
(define-key 'inferior-repl #\M-z 'inferior-repl-eval-defun)
(define-key 'inferior-repl #\C-M-z 'inferior-repl-eval-region)
(define-key 'inferior-repl '(#\C-x #\C-e) 'inferior-repl-eval-last-sexp)

(define-key 'inferior-repl #\M-p 'comint-previous-input)
(define-key 'inferior-repl #\M-n 'comint-next-input)
(define-key 'inferior-repl '(#\C-c #\C-l) 'comint-show-output)
(define-key 'inferior-repl '(#\C-c #\C-o) 'inferior-repl-flush-output)
(define-key 'inferior-repl '(#\C-c #\C-r) 'comint-history-search-backward)
(define-key 'inferior-repl '(#\C-c #\C-s) 'comint-history-search-forward)
;;(define-key 'inferior-repl '(#\C-c #\C-u) 'comint-kill-input)

(define-key 'inferior-repl '(#\C-c #\C-d) 'inferior-repl-debug)

(define-major-mode inferior-cmdl scheme "CMDL"
  "Major mode for communicating with an inferior command loop.
Like Scheme mode except that the evaluation commands are disabled,
and characters that would normally be self inserting are commands.
Typing ? will show you which characters perform useful functions.

Additionally, these commands abort the command loop:

\\[inferior-cmdl-abort-top-level] returns to the top-level REPL.
\\[inferior-cmdl-abort-previous] goes up one level to the previous REPL.
\\[inferior-cmdl-abort-nearest] returns to the current REPL.
\\[inferior-cmdl-breakpoint] enters a breakpoint REPL."
  (lambda (buffer)
    (event-distributor/invoke! (ref-variable inferior-cmdl-mode-hook buffer)
			       buffer)))

(define-variable inferior-cmdl-mode-hook
  "An event distributor that is invoked when entering Inferior CMDL mode."
  (make-event-distributor))

(define-key 'inferior-cmdl '(#\C-c #\C-b) 'inferior-cmdl-breakpoint)
(define-key 'inferior-cmdl '(#\C-c #\C-c) 'inferior-cmdl-abort-top-level)
(define-key 'inferior-cmdl '(#\C-c #\C-u) 'inferior-cmdl-abort-previous)
(define-key 'inferior-cmdl '(#\C-c #\C-x) 'inferior-cmdl-abort-nearest)

(define-key 'inferior-cmdl #\M-o 'undefined)
(define-key 'inferior-cmdl #\M-z 'undefined)
(define-key 'inferior-cmdl #\C-M-z 'undefined)
(define-key 'inferior-cmdl '(#\C-x #\C-e) 'undefined)

(define-key 'inferior-cmdl #\M-p 'undefined)
(define-key 'inferior-cmdl #\M-n 'undefined)
(define-key 'inferior-cmdl '(#\C-c #\C-r) 'undefined)
(define-key 'inferior-cmdl '(#\C-c #\C-s) 'undefined)

(define-key 'inferior-cmdl char-set:graphic 'inferior-cmdl-self-insert)

;;;; Commands

(define (interrupt-command interrupt flush-queue?)
  (lambda ()
    (let ((port (buffer-interface-port (current-repl-buffer) #t)))
      (signal-thread-event (port/thread port) interrupt)
      (if flush-queue?
	  (flush-queue! (port/expression-queue port))))))

(define-command inferior-cmdl-breakpoint
  "Force the inferior REPL into a breakpoint."
  ()
  (interrupt-command cmdl-interrupt/breakpoint #f))

(define-command inferior-cmdl-abort-nearest
  "Force the inferior REPL back to the current level."
  ()
  (interrupt-command cmdl-interrupt/abort-nearest #t))

(define-command inferior-cmdl-abort-previous
  "Force the inferior REPL up to the previous level."
  ()
  (interrupt-command cmdl-interrupt/abort-previous #t))

(define-command inferior-cmdl-abort-top-level
  "Force the inferior REPL up to top level."
  ()
  (interrupt-command cmdl-interrupt/abort-top-level #t))

(define-command inferior-repl-eval-defun
  "Evaluate defun that point is in or before."
  ()
  (lambda ()
    (inferior-repl-eval-from-mark (current-definition-start))))

(define-command inferior-repl-eval-last-sexp
  "Evaluate the expression preceding point."
  ()
  (lambda ()
    (inferior-repl-eval-from-mark (backward-sexp (current-point) 1 'ERROR))))

(define (inferior-repl-eval-from-mark mark)
  ((ref-command inferior-repl-eval-region)
   (make-region mark (forward-sexp mark 1 'ERROR))))

(define-command inferior-repl-eval-region
  "Evaluate the region."
  "r"
  (lambda (region)
    (let ((buffer (mark-buffer (region-start region))))
      (comint-record-input (port/input-ring (buffer-interface-port buffer #t))
			   (region->string region))
      (inferior-repl-eval-region buffer region))))

(define-command inferior-repl-debug
  "Select a debugger buffer to examine the current REPL state.
If this is an error, the debugger examines the error condition."
  ()
  (lambda ()
    (temporary-message "Starting continuation browser...")
    (let ((port (buffer-interface-port (current-buffer) #t)))
      (start-continuation-browser
       port
       (let ((object
	      (let ((cmdl (port/inferior-cmdl port)))
		(or (and (repl? cmdl)
			 (repl/condition cmdl))
		    (thread-continuation (port/thread port))))))
	 (if (not object)
	     (editor-error "No error condition to debug."))
	 object)))))

(define (start-continuation-browser port condition)
  ((ref-command browse-continuation) condition)
  (buffer-put! (current-buffer) 'INVOKE-CONTINUATION
    (lambda (continuation arguments)
      (if (not (buffer-alive? (port/buffer port)))
	  (editor-error
	   "Can't continue; REPL buffer no longer exists!"))
      (signal-thread-event (port/thread port)
	(lambda ()
	  (apply continuation arguments))))))

(define (buffer/inferior-cmdl buffer)
  (let ((port (buffer-interface-port buffer #f)))
    (and port
	 (port/inferior-cmdl port))))

(define (port/inferior-cmdl port)
  (let ((thread (current-thread))
	(cmdl #f))
    (signal-thread-event (port/thread port)
      (lambda ()
	(set! cmdl (nearest-cmdl))
	(signal-thread-event thread #f)))
    (with-thread-events-blocked
     (lambda ()
       (do () (cmdl)
	 (suspend-current-thread))))
    cmdl))

(define-command inferior-cmdl-self-insert
  "Send this character to the inferior debugger process."
  ()
  (lambda ()
    (let ((port (buffer-interface-port (current-buffer) #t)))
      (set-port/command-char! port (last-command-key))
      (end-input-wait port))))

(define-command inferior-repl-flush-output
  "Kill all output from REPL since last input."
  ()
  (lambda ()
    (let ((start
	   (let ((start (ref-variable comint-last-input-end)))
	     (if (and (not (line-start? start))
		      (eqv? #\newline (extract-right-char start)))
		 (mark1+ start)
		 start)))
	  (end (port/mark (buffer-interface-port (selected-buffer) #t))))
      (let ((value-mark
	     (re-search-backward flush-output-regexp end start #f)))
	(let ((start (mark-left-inserting-copy start))
	      (end (or value-mark end)))
	  (if (mark< start end)
	      (begin
		(delete-string start end)
		(guarantee-newline start)
		(insert-string "*** output flushed ***\n" start)))
	  (if value-mark
	      (let ((m
		     (re-match-forward ";Value [0-9]+: "
				       start (group-end start) #f)))
		(if m
		    (let ((e (line-end m 0)))
		      (if (> (- (mark-index e) (mark-index m)) 70)
			  (begin
			    (delete-string m e)
			    (insert-string "*** flushed ***" m)))))))
	  (mark-temporary! start))))))

(define flush-output-regexp
  (string-append "^;"
		 "\\("
		 "Unspecified return value$"
		 "\\|"
		 "Value: "
		 "\\|"
		 "Value [0-9]+: "
		 "\\|"
		 "Quit!$"
		 "\\)"))

(define (inferior-repl-eval-region buffer region)
  (inferior-repl-eval-ok? buffer)
  (call-with-transcript-output-mark buffer
    (lambda (mark)
      (if mark
	  (insert-region (region-start region)
			 (region-end region)
			 mark))))
  (let ((port (buffer-interface-port buffer #t)))
    (let ((input-end (inferior-repl-input-end buffer region)))
      (move-mark-to! (port/mark port) input-end)
      (move-mark-to! (ref-variable comint-last-input-end buffer) input-end))
    (let ((queue (port/expression-queue port)))
      (bind-condition-handler (list condition-type:error)
	  evaluation-error-handler
	(lambda ()
	  (for-each (let ((context
			   (if (eq? (group-buffer (region-group region))
				    buffer)
			       'REPL-BUFFER
			       'OTHER-BUFFER)))
		      (lambda (expression)
			(enqueue! queue (cons expression context))))
		    (read-expressions-from-region region))))
      (if (not (queue-empty? queue))
	  (end-input-wait port)))))

(define (inferior-repl-input-end buffer region)
  (receive (mark in-buffer?)
      (let ((end (buffer-end buffer))
	    (end* (region-end region)))
	(if (mark~ end end*)
	    (values end* #t)
	    (values end #f)))
    (let ((mark
	   (cond ((eqv? #\newline (extract-right-char mark))
		  (mark1+ mark))
		 ((line-start? mark)
		  mark)
		 (else
		  (let ((mark (mark-left-inserting-copy mark)))
		    (insert-newline mark)
		    (mark-temporary! mark)
		    mark)))))
      (if in-buffer?
	  (set-buffer-point! buffer mark))
      mark)))

(define (inferior-repl-eval-expression buffer expression)
  (inferior-repl-eval-ok? buffer)
  (call-with-transcript-output-mark buffer
    (lambda (mark)
      (if mark
	  (insert-string
	   (parameterize ((param:print-with-maximum-readability? #t))
	     (write-to-string expression))
	   mark))))
  (let ((port (buffer-interface-port buffer #t)))
    ;;(move-mark-to! (port/mark port) (buffer-end buffer))
    (move-mark-to! (ref-variable comint-last-input-end buffer)
		   (port/mark port))
    (enqueue! (port/expression-queue port) (cons expression 'EXPRESSION))
    (end-input-wait port)))

(define (inferior-repl-eval-ok? buffer)
  (let ((mode (buffer-major-mode buffer)))
    (if (not (eq? mode (ref-mode-object inferior-repl)))
	(editor-error
	 (if (eq? mode (ref-mode-object inferior-cmdl))
	     "REPL needs response before evaluation will be enabled."
	     "Can't evaluate -- REPL buffer in anomalous mode.")))))

(define (inferior-repl-process-mark buffer)
  (port/mark (buffer-interface-port buffer #t)))

;;;; Queue

(define-integrable (make-queue)
  (cons '() '()))

(define-integrable (queue-empty? queue)
  (null? (car queue)))

(declare (integrate-operator enqueue!/unsafe dequeue!/unsafe))

(define (enqueue!/unsafe queue object)
  (let ((next (cons object '())))
    (if (null? (cdr queue))
	(set-car! queue next)
	(set-cdr! (cdr queue) next))
    (set-cdr! queue next)))

(define (dequeue!/unsafe queue empty)
  (let ((this (car queue)))
    (if (null? this)
	empty
	(begin
	  (set-car! queue (cdr this))
	  (if (null? (cdr this))
	      (set-cdr! queue '()))
	  (car this)))))

(define (enqueue! queue object)
  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (enqueue!/unsafe queue object)
    (set-interrupt-enables! interrupt-mask)
    unspecific))

(define (dequeue! queue empty)
  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (let ((value (dequeue!/unsafe queue empty)))
      (set-interrupt-enables! interrupt-mask)
      value)))

(define (flush-queue! queue)
  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (set-car! queue '())
    (set-cdr! queue '())
    (set-interrupt-enables! interrupt-mask)
    unspecific))

;;;; Interface Port

(define (make-interface-port buffer thread)
  (letrec
      ((port
	(make-port interface-port-type
		   (make-interface-port-state
		    thread
		    (mark-right-inserting-copy (buffer-end buffer))
		    (register-inferior-thread!
		     thread
		     (lambda () (process-output-queue port)))))))
    port))

(define (interface-port? object)
  (and (port? object)
       (interface-port-state? (port/state object))))

(define-structure (interface-port-state
		   (conc-name interface-port-state/)
		   (constructor make-interface-port-state
				(thread mark output-registration)))
  (thread #f read-only #t)
  (mark #f read-only #t)
  (input-ring (make-ring (ref-variable comint-input-ring-size)) read-only #t)
  (expression-queue (make-queue) read-only #t)
  (current-queue-element #f)
  (command-char #f)
  (output-queue (make-queue) read-only #t)
  (output-strings '())
  (output-registration #f read-only #t)
  (bytes-written 0))

(define-integrable (port/thread port)
  (interface-port-state/thread (port/state port)))

(define-integrable (port/mark port)
  (interface-port-state/mark (port/state port)))

(define-integrable (port/buffer port)
  (mark-buffer (port/mark port)))

(define-integrable (port/input-ring port)
  (interface-port-state/input-ring (port/state port)))

(define-integrable (port/expression-queue port)
  (interface-port-state/expression-queue (port/state port)))

(define-integrable (port/current-queue-element port)
  (interface-port-state/current-queue-element (port/state port)))

(define-integrable (set-port/current-queue-element! port element)
  (set-interface-port-state/current-queue-element! (port/state port) element))

(define-integrable (port/command-char port)
  (interface-port-state/command-char (port/state port)))

(define-integrable (set-port/command-char! port command-char)
  (set-interface-port-state/command-char! (port/state port) command-char))

(define-integrable (port/output-queue port)
  (interface-port-state/output-queue (port/state port)))

(define-integrable (port/output-strings port)
  (interface-port-state/output-strings (port/state port)))

(define-integrable (set-port/output-strings! port strings)
  (set-interface-port-state/output-strings! (port/state port) strings))

(define-integrable (port/output-registration port)
  (interface-port-state/output-registration (port/state port)))

(define-integrable (port/bytes-written port)
  (interface-port-state/bytes-written (port/state port)))

(define-integrable (set-port/bytes-written! port n)
  (set-interface-port-state/bytes-written! (port/state port) n))

;;; Output operations

(define (operation/write-char port char)
  (guarantee 8-bit-char? char)
  (enqueue-output-string! port (string char))
  1)

(define (operation/write-substring port string start end)
  (if (string? string)
      (begin
	(enqueue-output-string! port (substring string start end))
	(fix:- end start))
      (generic-port-operation:write-substring port string start end)))

(define (operation/beep port)
  (enqueue-output-operation!
   port
   (lambda (mark transcript?) mark (if (not transcript?) (editor-beep)) #t)))

(define (operation/x-size port)
  (let ((buffer (port/buffer port)))
    (and buffer
	 (let ((windows (buffer-windows buffer)))
	   (and (not (null? windows))
		(apply min (map window-x-size windows)))))))

(define (operation/write-values port expression vals)
  (let ((buffer (port/buffer port))
	(other-buffer?
	 (memq (operation/current-expression-context port expression)
	       '(other-buffer expression))))
    (if (and other-buffer?
	     (not (ref-variable inferior-repl-write-results buffer)))
	(let ((tbuffer
	       (and (ref-variable enable-transcript-buffer buffer)
		    (transcript-buffer))))
	  (for-each (lambda (object)
		      (transcript-write object tbuffer))
		    vals))
	(begin
	  (default/write-values port expression vals)
	  (if (and other-buffer? (not (mark-visible? (port/mark port))))
	      (for-each (lambda (val)
			  (transcript-write val #f))
			vals))))))

(define (mark-visible? mark)
  (any (lambda (window)
	 (window-mark-visible? window mark))
       (buffer-windows (mark-buffer mark))))

(define (enqueue-output-string! port string)
  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (set-port/output-strings! port (cons string (port/output-strings port)))
    (set-port/bytes-written! port
			     (+ (port/bytes-written port)
				(string-length string)))
    (inferior-thread-output!/unsafe (port/output-registration port))
    (set-interrupt-enables! interrupt-mask)
    unspecific))

;;; We assume here that none of the OPERATORs passed to this procedure
;;; generate any output in the REPL buffer, and consequently we don't
;;; need to update bytes-written here.  Review of the current usage of
;;; this procedure confirms the assumption.

(define (enqueue-output-operation! port operator)
  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (let ((strings (port/output-strings port)))
      (if (not (null? strings))
	  (begin
	    (set-port/output-strings! port '())
	    (enqueue!/unsafe
	     (port/output-queue port)
	     (let ((string (apply string-append (reverse! strings))))
	       (lambda (mark transcript?)
		 transcript?
		 (region-insert-string! mark string)
		 #t))))))
    (enqueue!/unsafe (port/output-queue port) operator)
    (inferior-thread-output!/unsafe (port/output-registration port))
    (set-interrupt-enables! interrupt-mask)
    unspecific))

(define (process-output-queue port)
  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))
	(result #t))
    (let ((mark (mark-left-inserting-copy (port/mark port))))
      (call-with-transcript-output-mark (port/buffer port)
	(lambda (transcript-mark)
	  (let ((run-operation
		 (lambda (operation mark transcript?)
		   (let ((flag (operation mark transcript?)))
		     (if (eq? flag 'FORCE-RETURN)
			 (set! result flag)))
		   unspecific)))
	    (let loop ()
	      (let ((operation (dequeue!/unsafe (port/output-queue port) #f)))
		(if operation
		    (begin
		      (run-operation operation mark #f)
		      (if transcript-mark
			  (run-operation operation transcript-mark #t))
		      (loop))))))
	  (let ((strings (port/output-strings port)))
	    (if (not (null? strings))
		(begin
		  (set-port/output-strings! port '())
		  (do ((strings (reverse! strings) (cdr strings)))
		      ((null? strings))
		    (region-insert-string! mark (car strings))
		    (if transcript-mark
			(region-insert-string! transcript-mark
					       (car strings)))))))))
      (move-mark-to! (port/mark port) mark)
      (mark-temporary! mark))
    (set-interrupt-enables! interrupt-mask)
    result))

;;; Input operations

(define (operation/read-char port)
  (error "READ-CHAR not supported on this port:" port))

(define (operation/read port)
  (read-expression port (nearest-cmdl/level)))

(define read-expression
  (let ((empty (cons '() '())))
    (lambda (port level)
      (let ((queue (port/expression-queue port))
	    (mode (ref-mode-object inferior-repl))
	    (ready?
	     (lambda (port)
	       (not (queue-empty? (port/expression-queue port))))))
	(let loop ()
	  (let ((element (dequeue! queue empty)))
	    (if (eq? element empty)
		(begin
		  (wait-for-input port mode ready? level)
		  (loop))
		(begin
		  (set-port/current-queue-element! port element)
		  (car element)))))))))

(define (operation/current-expression-context port expression)
  (let ((element (port/current-queue-element port)))
    (and (pair? element)
	 (eq? (car element) expression)
	 (cdr element))))

;;; Debugger

(define (operation/debugger-failure port string)
  (enqueue-output-operation! port
    (lambda (mark transcript?)
      mark
      (if (not transcript?)
	  (begin
	    (message string)
	    (editor-beep)))
      #t)))

(define (operation/debugger-message port string)
  (enqueue-output-operation!
   port
   (lambda (mark transcript?)
     mark
     (if (not transcript?) (message string))
     #t)))

(define (operation/debugger-presentation port thunk)
  (fresh-line port)
  (thunk))

;;; Prompting

(define (operation/prompt-for-expression port prompt)
  (unsolicited-prompt port prompt-for-expression prompt))

(define (operation/prompt-for-confirmation port prompt)
  (unsolicited-prompt port prompt-for-confirmation? prompt))

(define (operation/prompt-for-string port prompt)
  (unsolicited-prompt port (lambda (prompt)
			     (prompt-for-string prompt "")) prompt))

(define (operation/call-with-pass-phrase port prompt receiver)
  (unsolicited-prompt port (lambda (prompt)
			     (call-with-pass-phrase prompt receiver)) prompt))

(define unsolicited-prompt
  (let ((wait-value (list #f))
	(abort-value (list #f)))
    (lambda (port procedure prompt)
      (let ((value wait-value))
	(signal-thread-event editor-thread
	  (lambda ()
	    ;; This would be even better if it could notify the user
	    ;; that the inferior REPL wanted some attention.
	    (when-buffer-selected (port/buffer port)
	      (lambda ()
		;; We're using ENQUEUE-OUTPUT-OPERATION! here solely
		;; to force KEYBOARD-READ to exit so that the command
		;; reader loop will get control and notice the command
		;; override.
		(enqueue-output-operation! port
		  (lambda (mark transcript?)
		    mark
		    (if (not transcript?)
			(override-next-command!
			 (lambda ()
			   (let ((continue
				  (lambda (v)
				    (set! value v)
				    (signal-thread-event (port/thread port)
				      #f))))
			     (bind-condition-handler
				 (list condition-type:abort-current-command)
				 (lambda (condition)
				   (continue abort-value)
				   (signal-condition condition))
			       (lambda ()
				 (continue (procedure prompt))))))))
		    'FORCE-RETURN))))))
	(with-thread-events-blocked
	 (lambda ()
	   (let loop ()
	     (cond ((eq? value wait-value) (suspend-current-thread) (loop))
		   ((eq? value abort-value) (abort->nearest))
		   (else value)))))))))

(define (when-buffer-selected buffer thunk)
  (if (current-buffer? buffer)
      (thunk)
      (letrec ((hook (lambda (buffer window)
		       (if (current-window? window)
			   (begin
			     (thunk)
			     (remove-select-buffer-hook buffer hook))))))
	(add-select-buffer-hook buffer hook))))

(define (operation/prompt-for-command-expression port prompt level)
  (parse-command-prompt port prompt)
  (read-expression port level))

(define (operation/prompt-for-command-char port prompt level)
  (parse-command-prompt port prompt)
  (read-command-char port level))

(define (read-command-char port level)
  (set-port/command-char! port #f)
  (wait-for-input port (ref-mode-object inferior-cmdl) port/command-char level)
  (port/command-char port))

(define (parse-command-prompt port prompt)
  (standard-prompt-spacing port)
  (if (and (pair? prompt)
	   (eq? 'STANDARD (car prompt)))
      (if (not suppress-standard-prompts?)
	  (write-string (cdr prompt) port))
      (write-string prompt port)))

(define suppress-standard-prompts? #t)

;;; Miscellaneous

(define (operation/set-default-directory port directory)
  (enqueue-output-operation! port
    (lambda (mark transcript?)
      (if (not transcript?)
	  (begin
	    (set-buffer-default-directory! (mark-buffer mark) directory)
	    ;;(message (->namestring directory))
	    ))
      #t)))

(define (operation/set-default-environment port environment)
  (enqueue-output-operation! port
    (lambda (mark transcript?)
      (if (not transcript?)
	  (local-set-variable! scheme-environment environment
			       (mark-buffer mark)))
      #t)))

(define interface-port-type
  (make-port-type
   `((WRITE-CHAR ,operation/write-char)
     (WRITE-SUBSTRING ,operation/write-substring)
     (BEEP ,operation/beep)
     (X-SIZE ,operation/x-size)
     (BYTES-WRITTEN ,port/bytes-written)
     (DEBUGGER-FAILURE ,operation/debugger-failure)
     (DEBUGGER-MESSAGE ,operation/debugger-message)
     (DEBUGGER-PRESENTATION ,operation/debugger-presentation)
     (PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression)
     (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)
     (PROMPT-FOR-COMMAND-EXPRESSION ,operation/prompt-for-command-expression)
     (PROMPT-FOR-COMMAND-CHAR ,operation/prompt-for-command-char)
     (PROMPT-FOR-STRING ,operation/prompt-for-string)
     (CALL-WITH-PASS-PHRASE ,operation/call-with-pass-phrase)
     (SET-DEFAULT-DIRECTORY ,operation/set-default-directory)
     (SET-DEFAULT-ENVIRONMENT ,operation/set-default-environment)
     (READ-CHAR ,operation/read-char)
     (READ ,operation/read)
     (CURRENT-EXPRESSION-CONTEXT ,operation/current-expression-context)
     (WRITE-VALUES ,operation/write-values))
   #f))