#| -*-Scheme-*-

$Id: buffer.scm,v 1.190 2003/02/14 18:28:11 cph Exp $

Copyright 1986,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1998,1999,2000 Massachusetts Institute of Technology
Copyright 2001,2002,2003 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Buffer Abstraction

(declare (usual-integrations))

(define-structure (buffer
		   (constructor %make-buffer (%name %default-directory)))
  %name
  group
  mark-ring
  modes
  comtabs
  windows
  display-start
  %default-directory
  %pathname
  %truename
  alist
  local-bindings
  local-bindings-installed?
  auto-save-pathname
  auto-saved?
  %save-length
  backed-up?
  modification-time)

(define-syntax rename-buffer-accessor
  (sc-macro-transformer
   (lambda (form environment)
     (let ((slot-name (cadr form)))
       `(DEFINE-INTEGRABLE ,(symbol-append 'BUFFER- slot-name)
	  ,(close-syntax (symbol-append 'BUFFER-% slot-name)
			 environment))))))

(rename-buffer-accessor name)
(rename-buffer-accessor default-directory)
(rename-buffer-accessor pathname)
(rename-buffer-accessor truename)
(rename-buffer-accessor save-length)

(define-variable buffer-creation-hook
  "An event distributor that is invoked when a new buffer is created.
The new buffer is passed as its argument.
The buffer is guaranteed to be deselected at that time."
  (make-event-distributor))

(define (make-buffer name mode directory)
  (let ((buffer (%make-buffer name directory)))
    (let ((group (make-group buffer)))
      (set-buffer-group! buffer group)
      (add-group-clip-daemon! group (buffer-clip-daemon buffer))
      (%buffer-reset! buffer)
      (set-buffer-windows! buffer '())
      (set-buffer-display-start! buffer #f)
      (set-buffer-default-directory! buffer directory)
      (set-buffer-local-bindings! buffer '())
      (set-buffer-local-bindings-installed?! buffer #f)
      (%set-buffer-major-mode! buffer mode)
      (event-distributor/invoke!
       (variable-default-value (ref-variable-object buffer-creation-hook))
       buffer)
      buffer)))

(define (%buffer-reset! buffer)
  (let ((group (buffer-group buffer)))
    (disable-group-undo! group)
    (if (not (minibuffer? buffer))
	(enable-group-undo! group)))
  (set-buffer-mark-ring!
   buffer
   (make-ring
    (variable-default-value (ref-variable-object mark-ring-maximum))))
  (ring-push! (buffer-mark-ring buffer) (buffer-start buffer))
  (set-buffer-%pathname! buffer #f)
  (set-buffer-%truename! buffer #f)
  (set-buffer-auto-save-pathname! buffer #f)
  (set-buffer-auto-saved?! buffer #f)
  (set-buffer-%save-length! buffer 0)
  (set-buffer-backed-up?! buffer #f)
  (set-buffer-modification-time! buffer #f)
  (set-buffer-alist! buffer '()))

(define (buffer-modeline-event! buffer type)
  (let loop ((windows (buffer-windows buffer)))
    (if (not (null? windows))
	(begin
	  (window-modeline-event! (car windows) type)
	  (loop (cdr windows))))))

(define (without-editor-interrupts thunk)
  ;; Control interrupts whether or not in the editor.
  ;; WITH-EDITOR-INTERRUPTS-DISABLED is required in the running editor but
  ;; buffers are created at editor initialization time and variables may
  ;; be set as early as initial file load time (prior to dumping the band).
  (if within-editor?
      (with-editor-interrupts-disabled thunk)
      (without-interrupts thunk)))

(define (buffer-reset! buffer)
  (set-buffer-writeable! buffer)
  (buffer-widen! buffer)
  (region-delete! (buffer-region buffer))
  (buffer-not-modified! buffer)
  (without-editor-interrupts
   (lambda ()
     (undo-local-bindings! buffer #t)
     (%buffer-reset! buffer)
     (%set-buffer-major-mode!
      buffer
      (variable-default-value (ref-variable-object editor-default-mode)))
     (event-distributor/invoke! event:set-buffer-pathname buffer)
     (buffer-modeline-event! buffer 'BUFFER-RESET))))

(define (set-buffer-name! buffer name)
  (set-buffer-%name! buffer name)
  (buffer-modeline-event! buffer 'BUFFER-NAME))

(define (set-buffer-default-directory! buffer directory)
  (set-buffer-%default-directory! buffer (pathname-simplify directory)))

(define (set-buffer-pathname! buffer pathname)
  (set-buffer-%pathname! buffer pathname)
  (if pathname
      (set-buffer-default-directory! buffer (directory-pathname pathname)))
  (event-distributor/invoke! event:set-buffer-pathname buffer)
  (buffer-modeline-event! buffer 'BUFFER-PATHNAME))

(define event:set-buffer-pathname
  (make-event-distributor))

(define (set-buffer-truename! buffer truename)
  (set-buffer-%truename! buffer truename)
  (buffer-modeline-event! buffer 'BUFFER-TRUENAME))

(define-integrable (set-buffer-save-length! buffer)
  (set-buffer-%save-length! buffer (buffer-length buffer)))

(define (buffer-point buffer)
  (cond ((current-buffer? buffer)
	 (current-point))
	((let ((windows (buffer-windows buffer)))
	   (and (pair? windows)
		(null? (cdr windows))
		(car windows)))
	 => window-point)
	(else
	 (group-point (buffer-group buffer)))))

(define-integrable (%set-buffer-point! buffer mark)
  (set-group-point! (buffer-group buffer) mark))

(define-integrable (minibuffer? buffer)
  (char=? (string-ref (buffer-name buffer) 0) #\Space))

(define-integrable (buffer-region buffer)
  (group-region (buffer-group buffer)))

(define-integrable (buffer-string buffer)
  (region->string (buffer-region buffer)))

(define-integrable (buffer-unclipped-region buffer)
  (group-unclipped-region (buffer-group buffer)))

(define-integrable (buffer-widen! buffer)
  (group-widen! (buffer-group buffer)))

(define-integrable (buffer-length buffer)
  (group-length (buffer-group buffer)))

(define-integrable (buffer-start buffer)
  (group-start-mark (buffer-group buffer)))

(define-integrable (buffer-end buffer)
  (group-end-mark (buffer-group buffer)))

(define-integrable (buffer-absolute-start buffer)
  (group-absolute-start (buffer-group buffer)))

(define-integrable (buffer-absolute-end buffer)
  (group-absolute-end (buffer-group buffer)))

(define (add-buffer-window! buffer window)
  (set-buffer-windows! buffer (cons window (buffer-windows buffer))))

(define (remove-buffer-window! buffer window)
  (set-buffer-windows! buffer (delq! window (buffer-windows buffer))))

(define (buffer-visible? buffer)
  (there-exists? (buffer-windows buffer) window-visible?))

(define (buffer-x-size buffer)
  (let ((windows (buffer-windows buffer)))
    (if (null? windows)
	(screen-x-size (selected-screen))
	(apply min (map window-x-size windows)))))

(define (mark-x-size mark)
  (let ((buffer (mark-buffer mark)))
    (if buffer
	(buffer-x-size buffer)
	(screen-x-size (selected-screen)))))

(define (buffer-get buffer key #!optional default)
  (let ((entry (assq key (buffer-alist buffer))))
    (if entry
	(cdr entry)
	(if (default-object? default) #f default))))

(define (buffer-put! buffer key value)
  (let ((entry (assq key (buffer-alist buffer))))
    (if entry
	(set-cdr! entry value)
	(set-buffer-alist! buffer
			   (cons (cons key value) (buffer-alist buffer))))))

(define (buffer-remove! buffer key)
  (set-buffer-alist! buffer (del-assq! key (buffer-alist buffer))))

(define (->buffer object)
  (cond ((buffer? object) object)
	((and (mark? object) (mark-buffer object)))
	((and (group? object) (group-buffer object)))
	((window? object) (window-buffer object))
	(else (error "can't coerce to buffer:" object))))

;;;; Modification Flags

(define-integrable (buffer-modified? buffer)
  (group-modified? (buffer-group buffer)))

(define (buffer-not-modified! buffer)
  (without-editor-interrupts
   (lambda ()
     (let ((group (buffer-group buffer)))
       (if (group-modified? group)
	   (begin
	     (set-group-modified?! group #f)
	     (buffer-modeline-event! buffer 'BUFFER-MODIFIED)
	     (set-buffer-auto-saved?! buffer #f)))))))

(define (buffer-modified! buffer)
  (without-editor-interrupts
   (lambda ()
     (let ((group (buffer-group buffer)))
       (if (not (group-modified? group))
	   (begin
	     (set-group-modified?! group #t)
	     (buffer-modeline-event! buffer 'BUFFER-MODIFIED)))))))

(define (verify-visited-file-modification-time? buffer)
  (let ((truename (buffer-truename buffer))
	(buffer-time (buffer-modification-time buffer)))
    (or (not truename)
	(not buffer-time)
	(let ((file-time (file-modification-time truename)))
	  (and file-time (< (abs (- buffer-time file-time)) 2))))))

(define-integrable (clear-visited-file-modification-time! buffer)
  (set-buffer-modification-time! buffer #f))

(define (set-buffer-auto-saved! buffer)
  (set-buffer-auto-saved?! buffer #t)
  (set-group-modified?! (buffer-group buffer) 'AUTO-SAVED))

(define-integrable (buffer-auto-save-modified? buffer)
  (eq? #t (group-modified? (buffer-group buffer))))

(define (buffer-clip-daemon buffer)
  (lambda (group start end)
    group start end			;ignore
    (buffer-modeline-event! buffer 'CLIPPING-CHANGED)))

(define-integrable (buffer-read-only? buffer)
  (group-read-only? (buffer-group buffer)))

(define-integrable (buffer-writeable? buffer)
  (not (buffer-read-only? buffer)))

(define (set-buffer-writeable! buffer)
  (set-group-writeable! (buffer-group buffer))
  (buffer-modeline-event! buffer 'BUFFER-MODIFIABLE))

(define (set-buffer-read-only! buffer)
  (set-group-read-only! (buffer-group buffer))
  (buffer-modeline-event! buffer 'BUFFER-MODIFIABLE))

(define (with-read-only-defeated object thunk)
  (let ((group (buffer-group (->buffer object)))
	(outside)
	(inside 'FULLY))
    (dynamic-wind (lambda ()
		    (set! outside (group-writeable? group))
		    (set-group-writeable?! group inside))
		  thunk
		  (lambda ()
		    (set! inside (group-writeable? group))
		    (set-group-writeable?! group outside)))))

;;;; Local Bindings

(define (define-variable-local-value! buffer variable value)
  (let ((buffer (->buffer buffer))
	(value (normalize-variable-value variable value)))
    (without-editor-interrupts
     (lambda ()
       (let ((binding (search-local-bindings buffer variable)))
	 (if binding
	     (set-cdr! binding value)
	     (set-buffer-local-bindings!
	      buffer
	      (cons (cons variable value)
		    (buffer-local-bindings buffer)))))
       (if (buffer-local-bindings-installed? buffer)
	   (set-variable-%value! variable value))
       (invoke-variable-assignment-daemons! buffer variable)))))

(define (undefine-variable-local-value! buffer variable)
  (let ((buffer (->buffer buffer)))
    (without-editor-interrupts
     (lambda ()
       (let ((binding (search-local-bindings buffer variable)))
	 (if binding
	     (begin
	       (set-buffer-local-bindings!
		buffer
		(delq! binding (buffer-local-bindings buffer)))
	       (if (buffer-local-bindings-installed? buffer)
		   (set-variable-%value! variable
					 (variable-default-value variable)))
	       (invoke-variable-assignment-daemons! buffer variable))))))))

(define (variable-local-value buffer variable)
  (let ((not-mark-local
	 (lambda ()
	   (let ((binding
		  (and buffer
		       (search-local-bindings (->buffer buffer) variable))))
	     (if binding
		 (cdr binding)
		 (variable-default-value variable))))))
    (if (mark? buffer)
	(let ((no-datum (list 'NO-DATUM)))
	  (let ((value (region-get buffer variable no-datum)))
	    (if (eq? value no-datum)
		(not-mark-local)
		value)))
	(not-mark-local))))

(define (variable-local-value? buffer variable)
  (or (not buffer)
      (search-local-bindings (->buffer buffer) variable)))

(define (set-variable-local-value! buffer variable value)
  (if buffer
      (let ((buffer (->buffer buffer)))
	(cond ((variable-buffer-local? variable)
	       (define-variable-local-value! buffer variable value))
	      ((search-local-bindings buffer variable)
	       =>
	       (lambda (binding)
		 (let ((value (normalize-variable-value variable value)))
		   (without-editor-interrupts
		    (lambda ()
		      (set-cdr! binding value)
		      (if (buffer-local-bindings-installed? buffer)
			  (set-variable-%value! variable value))
		      (invoke-variable-assignment-daemons! buffer
							   variable))))))
	      (else
	       (set-variable-default-value! variable value))))
      (set-variable-default-value! variable value)))

(define (set-variable-default-value! variable value)
  (if within-editor?
      (let ((value (normalize-variable-value variable value)))
	(without-editor-interrupts
	 (lambda ()
	   (set-variable-%default-value! variable value)
	   (if (not (search-local-bindings (current-buffer) variable))
	       (set-variable-%value! variable value))
	   (invoke-variable-assignment-daemons! #f variable))))
      (set-default-variable-value!/outside-editor variable value)))

(define-integrable (search-local-bindings buffer variable)
  (let loop ((bindings (buffer-local-bindings buffer)))
    (and (not (null? bindings))
	 (if (eq? (caar bindings) variable)
	     (car bindings)
	     (loop (cdr bindings))))))

(define (undo-local-bindings! buffer all?)
  ;; Caller guarantees that interrupts are disabled.
  (let ((bindings (buffer-local-bindings buffer)))
    (if (buffer-local-bindings-installed? buffer)
	(do ((bindings bindings (cdr bindings)))
	    ((null? bindings))
	  (set-variable-%value! (caar bindings)
				(variable-default-value (caar bindings)))))
    (call-with-values
	(lambda ()
	  (split-list bindings
		      (lambda (binding)
			(variable-permanent-local? (car binding)))))
      (lambda (permanent impermanent)
	(set-buffer-local-bindings! buffer (if all? '() permanent))
	(do ((bindings impermanent (cdr bindings)))
	    ((null? bindings))
	  (invoke-variable-assignment-daemons! buffer (caar bindings)))))))

(define (with-current-local-bindings! thunk)
  (dynamic-wind (lambda ()
		  (install-buffer-local-bindings! (current-buffer)))
		thunk
		(lambda ()
		  (uninstall-buffer-local-bindings! (current-buffer)))))

(define (change-local-bindings! old-buffer new-buffer select-buffer!)
  ;; Assumes that interrupts are disabled and that OLD-BUFFER is selected.
  (uninstall-buffer-local-bindings! old-buffer)
  (select-buffer!)
  (install-buffer-local-bindings! new-buffer))

(define (install-buffer-local-bindings! buffer)
  (do ((bindings (buffer-local-bindings buffer) (cdr bindings)))
      ((null? bindings))
    (set-variable-%value! (caar bindings) (cdar bindings)))
  (set-buffer-local-bindings-installed?! buffer #t))

(define (uninstall-buffer-local-bindings! buffer)
  (do ((bindings (buffer-local-bindings buffer) (cdr bindings)))
      ((null? bindings))
    (set-variable-%value! (caar bindings)
			  (variable-default-value (caar bindings))))
  (set-buffer-local-bindings-installed?! buffer #f))

(define (set-variable-value! variable value)
  (if within-editor?
      (set-variable-local-value! (current-buffer) variable value)
      (set-default-variable-value!/outside-editor variable value)))

(define (set-default-variable-value!/outside-editor variable value)
  (let ((value (normalize-variable-value variable value)))
    (without-interrupts
     ;; Not with-editor-interrupts-disabled as we are not within-editor?
     (lambda ()
       (set-variable-%default-value! variable value)
       (set-variable-%value! variable value)
       (invoke-variable-assignment-daemons! #f variable)))))

(define (with-variable-value! variable new-value thunk)
  (let ((old-value))
    (dynamic-wind (lambda ()
		    (set! old-value (variable-value variable))
		    (set-variable-value! variable new-value)
		    (set! new-value)
		    unspecific)
		  thunk
		  (lambda ()
		    (set! new-value (variable-value variable))
		    (set-variable-value! variable old-value)
		    (set! old-value)
		    unspecific))))

;;;; Modes

(define-integrable (buffer-major-mode buffer)
  (car (buffer-modes buffer)))

(define (set-buffer-major-mode! buffer mode)
  (if (not (and (mode? mode) (mode-major? mode)))
      (error:wrong-type-argument mode "major mode" 'SET-BUFFER-MAJOR-MODE!))
  (if (buffer-get buffer 'MAJOR-MODE-LOCKED)
      (editor-error "The major mode of this buffer is locked: " buffer))
  ;; The very first buffer is created before the editor
  (without-editor-interrupts
   (lambda ()
     (undo-local-bindings! buffer #f)
     (%set-buffer-major-mode! buffer mode)
     (buffer-modeline-event! buffer 'BUFFER-MODES))))

(define (%set-buffer-major-mode! buffer mode)
  (set-buffer-modes! buffer (list mode))
  (set-buffer-comtabs! buffer (mode-comtabs mode))
  (set-variable-local-value! buffer
			     (ref-variable-object mode-name)
			     (mode-display-name mode))
  ((mode-initialization mode) buffer)
  (event-distributor/invoke! event:set-buffer-major-mode buffer))

(define event:set-buffer-major-mode
  (make-event-distributor))

(define (buffer-minor-modes buffer)
  (list-copy (cdr (buffer-modes buffer))))

(define (buffer-minor-mode? buffer mode)
  (if (not (and (mode? mode) (not (mode-major? mode))))
      (error:wrong-type-argument mode "minor mode" 'BUFFER-MINOR-MODE?))
  (memq mode (cdr (buffer-modes buffer))))

(define (enable-buffer-minor-mode! buffer mode)
  (if (not (minor-mode? mode))
      (error:wrong-type-argument mode "minor mode" 'ENABLE-BUFFER-MINOR-MODE!))
  (without-editor-interrupts
   (lambda ()
     (let ((modes (buffer-modes buffer)))
       (if (not (memq mode (cdr modes)))
	   (begin
	     (set-cdr! modes (append! (cdr modes) (list mode)))
	     (set-buffer-comtabs! buffer
				  (cons (minor-mode-comtab mode)
					(buffer-comtabs buffer)))
	     (add-minor-mode-line-entry! buffer mode)
	     ((mode-initialization mode) buffer)
	     (buffer-modeline-event! buffer 'BUFFER-MODES)))))))

(define (disable-buffer-minor-mode! buffer mode)
  (if (not (minor-mode? mode))
      (error:wrong-type-argument mode "minor mode"
				 'DISABLE-BUFFER-MINOR-MODE!))
  (without-editor-interrupts
   (lambda ()
     (let ((modes (buffer-modes buffer)))
       (if (memq mode (cdr modes))
	   (begin
	     (set-cdr! modes (delq! mode (cdr modes)))
	     (set-buffer-comtabs! buffer
				  (delq! (minor-mode-comtab mode)
					 (buffer-comtabs buffer)))
	     (remove-minor-mode-line-entry! buffer mode)
	     (buffer-modeline-event! buffer 'BUFFER-MODES)))))))