File psl-1983/nmode/buffers.sl artifact 812211d95b part of check-in 9992369dd3


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Buffers.SL - Buffer Collection Manipulation Functions
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        23 August 1982
% Revised:     25 January 1983
%
% This file contains functions that manipulate the set of existing buffers.
%
% 25-Jan-83 Alan Snyder
%  Fix bug in buffer name completion: now accepts the name of an existing buffer
%  even when the name is a prefix of the name of some other buffer.
% 29-Dec-82 Alan Snyder
%  Revise prompt-for-buffer code to use new prompted input.
%  PROMPT-FOR-EXISTING-BUFFER now completes on CR and LF, as well as SPACE.
% 3-Dec-82 Alan Snyder
%  Added CLEANUP-BUFFERS.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects extended-char fast-strings))
(load stringx)

(fluid '(nmode-current-buffer nmode-current-window nmode-main-buffer
	 nmode-output-buffer nmode-default-mode nmode-input-default
	 ))

(fluid '(nmode-selectable-buffers))
(if (not (boundp 'nmode-selectable-buffers))
  (setf nmode-selectable-buffers NIL))

% Internals:

(fluid '(prompt-for-buffer-command-list
	 prompt-for-existing-buffer-command-list))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Creating buffers:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de buffer-create-default (buffer-name)

  % Create a new buffer with the default mode.  The name of the new buffer will
  % be the specified name if no buffer already exists with that name.
  % Otherwise, a similar name will be chosen.  The buffer becomes selectable,
  % but is not selected.

  (buffer-create buffer-name nmode-default-mode))

(de buffer-create (buffer-name initial-mode)

  % Create a new buffer.  The name of the new buffer will be the specified name
  % if no buffer already exists with that name.  Otherwise, a similar name will
  % be chosen.  The buffer becomes selectable, but is not selected.

  (setf buffer-name (buffer-make-unique-name buffer-name))
  (let ((b (buffer-create-unselectable buffer-name initial-mode)))
    (setq nmode-selectable-buffers (cons b nmode-selectable-buffers))
    b))

(de buffer-create-unselectable (buffer-name initial-mode)

  % Create a new buffer.  The name of the new buffer will be the specified
  % name.  The buffer will not be selectable.

  (let ((b (create-text-buffer buffer-name)))
    (=> b set-mode initial-mode)
    (=> b set-previous-buffer nmode-current-buffer)
    b))

(de buffer-make-unique-name (buffer-name)
  % Return a buffer name not equal to the name of any existing buffer.

  (setf buffer-name (string-upcase buffer-name))
  (for*
    (with (root-name (string-concat buffer-name "-")))
    (for count 0 (+ count 1))
    (for name buffer-name (string-concat root-name (BldMsg "%d" count)))
    (do (if (not (buffer-exists? name)) (exit name)))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Finding buffers:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de buffer-find (buffer-name)
  % If a selectable buffer exists with the specified name (case does
  % not matter), then return it.  Otherwise, return NIL.

  (for (in b nmode-selectable-buffers)
       (do (if (string-equal buffer-name (=> b name))
	       (exit b)))
       (returns nil)
       ))

(de buffer-find-or-create (buffer-name)
  % Return the specified buffer, if it exists and is selectable.
  % Otherwise, create a buffer of that name and return it.

  (or (buffer-find buffer-name)
      (buffer-create-default buffer-name)
      ))

(de buffer-exists? (buffer-name)
  % Return T if a selectable buffer exists with the specified name
  % (case does not matter), NIL otherwise.

  (if (buffer-find buffer-name) T NIL))

(de nmode-user-buffers ()
  % Return a list of those selectable buffers whose names do not begin
  % with a '+'.

  (for (in b nmode-selectable-buffers)
       (when (~= (string-fetch (=> b name) 0) #/+))
       (collect b)
       ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Manipulating buffers:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de buffer-is-selectable? (b)
  % Return T if the specified buffer is selectable.
  (MemQ b nmode-selectable-buffers))

(de buffer-set-mode (b mode)
  % Set the "mode" of the buffer B.  If B is the current buffer, then the
  % mode is "established".

  (=> b set-mode mode)
  (when (eq b nmode-current-buffer)
	(nmode-establish-current-mode)
	(set-message "")
	))

(de cleanup-buffers ()
  % Ask each buffer to "clean up" any unneeded storage.
  (for (in b nmode-selectable-buffers)
       (do (=> b cleanup))
       ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Selecting Buffers:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de buffer-select (b)
  % If B is not NIL and B is a selectable buffer, then make it the current
  % buffer, attach it to the current window, and return it.  Otherwise, do
  % nothing and return NIL.

  (window-select-buffer nmode-current-window b))

(de buffer-select-previous (b)
  % Select the previous buffer of B, if it exists and is selectable.
  % Otherwise, select the MAIN buffer.

  (if (not (buffer-select (=> b previous-buffer)))
      (buffer-select nmode-main-buffer))
  )

(de buffer-select-by-name (buffer-name)
  % If the specified buffer exists and is selectable, select it and return it.
  % Otherwise, return NIL.

  (buffer-select (buffer-find buffer-name)))

(de buffer-select-or-create (buffer-name)
  % Select the specified buffer, if it exists and is selectable.
  % Otherwise, create a buffer of that name and select it.

  (or (buffer-select-by-name buffer-name)
      (buffer-select (buffer-create-default buffer-name))
      ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Prompting for buffer names:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(setf prompt-for-buffer-command-list
  (list
   (cons (x-char SPACE) 'complete-input-buffer-name)
   (cons (x-char CR) 'check-input-buffer-name)
   (cons (x-char LF) 'check-input-buffer-name)
   ))

(setf prompt-for-existing-buffer-command-list
  (list
   (cons (x-char SPACE) 'complete-input-buffer-name)
   (cons (x-char CR) 'complete-input-existing-buffer-name)
   (cons (x-char LF) 'complete-input-existing-buffer-name)
   ))

(de prompt-for-buffer (prompt default-b)
  % Ask the user for the name of a buffer.  If the user gives a name that does
  % not name an existing buffer, a new buffer with that name will be created
  % (but NOT selected), and the prompt "(New Buffer)" will be displayed.
  % Return the buffer.  DEFAULT-B is the buffer to return as default (it may
  % be NIL).  A valid buffer will always be returned (the user may ABORT).

  (let* ((default-name (and default-b (=> default-b name)))
	 (name (prompt-for-string-special
		prompt
		default-name
		prompt-for-buffer-command-list
		))
	 )
    (or (buffer-find name)
	(prog1
	 (buffer-create-default (string-upcase name))
	 (write-prompt "(New Buffer)")
	 ))))

(de prompt-for-existing-buffer (prompt default-b)
  % Ask the user for the name of an existing buffer.  Return the buffer.
  % DEFAULT-B is the buffer to return as default (it may be NIL).  A valid
  % buffer will always be returned, unless the user aborts (throw 'ABORT).

  (let* ((default-name (and default-b (=> default-b name)))
	 (name (prompt-for-string-special
		prompt
		default-name
		prompt-for-existing-buffer-command-list
		))
	 )
    (buffer-find name)
    ))

% Internal functions:

(de complete-input-buffer-name ()
  % Extend the string in the input buffer as far as possible to match the set of
  % existing buffers.  Return T if the resulting string names an existing
  % buffer; otherwise Beep and return NIL.

  (let* ((name (nmode-get-input-string))
	 (names (buffer-names-that-match name))
	 )
    (when (not (null names))
      (setf name (strings-largest-common-prefix names))
      (nmode-replace-input-string name)
      )
    (if (member name names)
      T
      (progn (Ding) NIL)
      )))

(de check-input-buffer-name ()
  % Check the string in the input buffer to ensure that it is non-empty, or if
  % it is empty, that the default string exists and is not empty.  Beep if this
  % condition fails, otherwise terminate the input.

  (if (or (not (string-empty? (nmode-get-input-string)))
	  (and nmode-input-default
	       (not (string-empty? nmode-input-default))))
    (nmode-terminate-input)
    (Ding)
    ))

(de complete-input-existing-buffer-name ()
  % If the input buffer is empty and there is a default string, substitute the
  % default string.  Then, extend the string in the input buffer as far as
  % possible to match the set of existing buffers.  If the resulting string
  % names an existing buffer, refresh and terminate input.  Otherwise, beep.

  (nmode-substitute-default-input)
  (when (complete-input-buffer-name)
    (nmode-refresh)
    (nmode-terminate-input)
    ))

(de buffer-names-that-match (name)
  (for (in b nmode-selectable-buffers)
       (when (buffer-name-matches b name))
       (collect (=> b name))))

(de buffer-name-matches (b name2)
  (let* ((len2 (string-length name2))
	 (name1 (=> b name))
	 (len1 (string-length name1))
	 )
    (and
      (>= len1 len2)
      (string-equal (substring name1 0 len2) name2)
      )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Attaching buffers to windows
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de window-select-buffer (w b)
  % If B is not NIL and B is a selectable buffer, then attach B to the window
  % W and return B.  Otherwise, do nothing and return NIL.

  (cond ((and b (buffer-is-selectable? b))
	 (=> w set-buffer b)
	 (nmode-adjust-window w)
	 (cond ((eq w nmode-current-window)
		(setf nmode-current-buffer b)
		(nmode-establish-current-mode)
		(reset-message)
		))
	 b
	 )))

(de window-select-previous-buffer (w)
  % Replace window W's current buffer with that buffer's previous
  % buffer, if it exists and is selectable.  Otherwise, replace
  % it with the MAIN buffer.

  (if (not (window-select-buffer w (=> (=> w buffer) previous-buffer)))
      (window-select-buffer w nmode-main-buffer)))

(de window-copy-buffer (w-source w-dest)
  % Attach to window W-DEST the buffer belonging to window W-SOURCE.
  % Duplicate the window's BUFFER-TOP and BUFFER-LEFT as well.
  % If W is the current window, then the buffer becomes the current buffer.

  (let ((b (=> w-source buffer)))
    (=> w-dest set-buffer b)
    (=> w-dest set-buffer-top (=> w-source buffer-top))
    (=> w-dest set-buffer-left (=> w-source buffer-left))
    (cond ((eq w-dest nmode-current-window)
	   (setf nmode-current-buffer b)
	   (nmode-establish-current-mode)
	   (reset-message)
	   ))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Killing Buffers
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de window-kill-buffer ()
  % This function kills the buffer associated with the current window and
  % detaches it from that window or any other window (replacing it with
  % another buffer, preferrably the buffer's "previous buffer").
  % Do not kill the MAIN or OUTPUT buffer.

  (buffer-kill-and-detach (=> nmode-current-window buffer)))

(de buffer-kill-and-detach (b)
  % Kill the specified buffer and detach it from any existing windows
  % (replacing with another buffer, preferrably the buffer's previous buffer).
  % Do not kill the MAIN or OUTPUT buffer.

  (if (buffer-kill b)
    (for (in w (find-buffer-in-windows b))
	 (do (window-select-previous-buffer w)))))

(de buffer-killable? (b)
  (not (or (eq b nmode-main-buffer)
	   (eq b nmode-output-buffer)
	   )))

% Internal function:

(de buffer-kill (b)
  % Remove the specified buffer from the list of selectable buffers and return
  % T, unless the buffer is the MAIN or OUTPUT buffer, in which case do
  % nothing and return NIL.

  (let ((kill? (buffer-killable? b)))
    (if kill?
      (setf nmode-selectable-buffers (DelQ b nmode-selectable-buffers))
      )
    kill?
    ))


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]