File psl-1983/3-1/nmode/dabbrevs.sl artifact e8e5e5e384 part of check-in 3af273af29


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Dabbrevs.SL - Dynamic Abbreviations for NMODE
% 
% Author:      Mark R. Swanson
%              University of Utah
% Date:        15 June 1983
%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Methods provided: (all internal, really)
%   initial-expansion
%   expand-aux
%   find-next-expansion
%   get-expansion-from-buffer
%   expand
%   save-expansion
%
% Commands defined:
%   instant-abbrev-command
%     Tries to "expand" the word (or prefix) before point by searching for other
%     words with the same prefix.  The search goes back from point (or from the
%     location of the last expansion found for the current abbreviation); if
%     unsuccessful, a search is done forward from point.  Re-issuing the command
%     causes a search for the next possible expansion.  The command is initially
%     bound to the M-<space> key.

(CompileTime
 (load objects fast-int))

(fluid '(current-abbrev-expansion))
(setf current-abbrev-expansion nil)

(defflavor abbrev-expansion 
 (abbrev                    % original abbreviation string 
  abbrev-start-pos           
  abbrev-end-pos
  (expansion-list nil)      % list of all expansions tried (including abbrev)
  expansion-start-pos       % start of latest expansion
  expansion-end-pos         % end of latest expansion
  last-pos                  % position of end of latest expansion/abbrev in 
                            %  buffer
  (direction -1)            % initially look backwards (-1)
  (word-delim-list '(#\!( #\!) #\!' #\- #\space #\<)) % word delimitors
  )
  ()
)

(defmethod (abbrev-expansion initial-expansion) ()
% Initial attempt to find an expansion for "word" before point.  Search goes
%  first backward, then forward, through buffer for an appropriate expansion.

  (setf last-pos (setf abbrev-end-pos (buffer-get-position)))
  (if (not (move-backward-word)) % is there a word to expand?
    (ding)                       % no
    % else                         yes
    (setf abbrev-start-pos (buffer-get-position)) % bracket its position
    (setf abbrev (cdr (extract-region nil abbrev-start-pos abbrev-end-pos)))
    (=> self save-expansion abbrev) % abbrev is its own initial "expansion"
    (=> self expand-aux)
    ))

(defmethod (abbrev-expansion expand-aux) ()
% Actually do the expansion (or re-expansion); search backwards first, then
%  forwards if necessary;  do not re-present duplicate expansions which have
%  already been tried.

  (write-message (concat "Expanding " (vector-fetch abbrev 0)))
  (let ((found-one nil)
	 new-expansion)
    (while (and (~= direction 0)	% if zero we have searched in both directions
	     (not found-one))
      (setf new-expansion (=> self find-next-expansion direction))
      (if new-expansion % then 
	(progn 
	  (if (< direction 0)	% move ptr for next search (may not be necessary)
	    (move-backward) (move-forward))
	  (setf found-one (not (member new-expansion expansion-list))))
%else
	(setf direction (if (= direction -1) 1 0))	% change directions
	(buffer-set-position last-pos)	% and start from original location
	))
% Finally insert expansion and add it to history
    (if found-one
      (progn
	(extract-region T abbrev-start-pos last-pos)	%remove old abbrev/expans.
	(insert-string (vector-fetch new-expansion 0))	% put in new expans.
	(setf last-pos (buffer-get-position))	% note end of expans.
	(=> self save-expansion new-expansion))
% else
      (buffer-set-position last-pos)	% put point back where we started
      (ding)	% let user know we failed
      )))

(defmethod (abbrev-expansion find-next-expansion) (dir)
% Search backward/forward from current location for an expansion (string match of
%  abbreviation preceded by a word delimitor. Returns NIL on failure, 
%  expansion-string on success; leaves point at start of last string match.

  (let ((found-one nil))
    (while (and (not found-one)
		(buffer-text-search? abbrev dir))
      (if (or (=> nmode-current-buffer at-line-start?)
	      (member (=> nmode-current-buffer previous-character) 
		      word-delim-list))
	(setf found-one T)
	(if (< dir 0)
	  (move-backward)
	  (move-forward))))
    (if found-one
      (=> self get-expansion-from-buffer))))

(defmethod (abbrev-expansion get-expansion-from-buffer) ()
  % Extracts the expansion from the buffer; on entry point should be at start
  %  of expansion, on exit it will be returned to that position.  Form of
  %  result should be a vector containing 1 string.

  (let (expans)
    (setf expansion-start-pos (buffer-get-position))
    (move-forward-word)
    (setf expansion-end-pos (buffer-get-position))
    (setf expans (cdr (extract-region NIL expansion-start-pos expansion-end-pos)))
    (buffer-set-position expansion-start-pos)
    expans))

(defmethod (abbrev-expansion expand) ()
  % Attempt to re-expand last expansion.  Point must be at end of previous
  %  expansion, word itself should not have been changed.

  (let ((cur-pos (buffer-get-position)))
    (if (and
	 (equal last-pos (buffer-get-position))
	 (move-backward-word)
	 (equal abbrev-start-pos (buffer-get-position))
	 (equal (car expansion-list)
		(cdr (extract-region nil abbrev-start-pos last-pos))))
      (progn
       (buffer-set-position expansion-start-pos)
       (=> nmode-current-buffer move-backward)
       (=> self expand-aux))
      (buffer-set-position cur-pos)
      nil
      )))

(defmethod (abbrev-expansion save-expansion) (expansion)
	(setf expansion-list (adjoin expansion expansion-list)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% dynamic abbreviation command and its installation
%

(de instant-abbrev-command ()
  (cond ((or 
	  (null current-abbrev-expansion)
	  (null (=> current-abbrev-expansion expand)))
	 (setf current-abbrev-expansion (make-instance 'abbrev-expansion))
	 (=> current-abbrev-expansion initial-expansion))))

(setf Text-Command-List
  (NConc Text-Command-List
	 (list
	  (cons (x-char M-!  ) 'instant-abbrev-command)
	  )))



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