reduce-historical/psl-1983/nmode/move-commands.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Move-Commands.SL - NMODE Move commands
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        23 August 1982
% Revised:     17 February 1983
%
% 17-Feb-83 Alan Snyder
%   Bug fix: permanent goal column wasn't permanent.
% 18-Nov-82 Alan Snyder
%   Added move-up-list, move-over-list, and move-over-defun commands.
%   Changed skip-forward-blanks and skip-backward-blanks.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects fast-int))

(fluid '(nmode-current-buffer
         nmode-command-argument
	 nmode-command-argument-given
         nmode-previous-command-function))

% Internal static variables:

(fluid '(nmode-goal-column		% permanent goal (set by user)
	 nmode-temporary-goal-column	% temporary goal within cmd sequence
	 nmode-goal-column-functions	% cmds that don't reset temp goal
	 ))

(setf nmode-goal-column nil)
(setf nmode-temporary-goal-column nil)
(setf nmode-goal-column-functions
  (list
   (function move-down-command)
   (function move-down-extending-command)
   (function move-up-command)
   (function set-goal-column-command)
   ))

(de move-to-buffer-start-command ()
  (set-mark-from-point)
  (move-to-buffer-start)
  )

(de move-to-buffer-end-command ()
  (set-mark-from-point)
  (move-to-buffer-end)
  )

(de move-to-start-of-line-command ()
  (current-buffer-goto (+ (current-line-pos) (- nmode-command-argument 1)) 0)
  )

(de move-to-end-of-line-command ()
  (move-to-start-of-line-command)
  (move-to-end-of-line))

(de set-goal-column-command ()
  (cond ((= nmode-command-argument 1)
	 (setf nmode-goal-column (current-display-column))
	 (write-prompt (BldMsg "Goal Column = %p" nmode-goal-column))
	 )
	(t
	 (setf nmode-goal-column NIL)
	 (write-prompt "No Goal Column")
	 )))

(de setup-goal-column ()
  % If this is the first in a new (potential) sequence of up/down commands,
  % then set the temporary goal column for that sequence of commands.
  (if (not (memq nmode-previous-command-function nmode-goal-column-functions))
    (setf nmode-temporary-goal-column (current-display-column)))
  )

(de goto-goal-column ()
  % Move the cursor to the current goal column, which is the permanent goal
  % column (if set by the user) or the temporary goal column (otherwise).
  (cond (nmode-goal-column
	 (set-display-column nmode-goal-column))
	(nmode-temporary-goal-column
	 (set-display-column nmode-temporary-goal-column))
	))

(de move-up-command ()
  (setup-goal-column)
  (set-line-pos (- (current-line-pos) nmode-command-argument))
  (goto-goal-column)
  )

(de move-down-extending-command ()
  (when (and (not nmode-command-argument-given) (current-line-is-last?))
    (let ((old-pos (buffer-get-position)))
      (move-to-buffer-end)
      (insert-eol)
      (buffer-set-position old-pos)
      ))
  (move-down-command)
  )

(de move-down-command ()
  (setup-goal-column)
  (set-line-pos (+ (current-line-pos) nmode-command-argument))
  (goto-goal-column)
  )

(de exchange-point-and-mark ()
  (let ((old-mark (current-mark)))
    (previous-mark) % pop off the old mark
    (set-mark-from-point) % push the new one
    (buffer-set-position old-mark)
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Skipping Blanks
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de char-blank-or-newline? (ch)
  (or (char-blank? ch) (= ch #\LF)))

(de skip-forward-blanks ()
  % Skip over "blanks", return the first non-blank character seen.
  % Cursor is positioned to the left of that character.
  (while (and (not (at-buffer-end?))
	      (char-blank-or-newline? (next-character))
	      )
    (move-forward))
  (next-character))

(de skip-backward-blanks ()
  % Skip backwards over "blanks", return the first non-blank character seen.
  % Cursor is positioned to the right of that character.
  (while (and (not (at-buffer-start?))
	      (char-blank-or-newline? (previous-character))
	      )
    (move-backward))
  (previous-character))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Move-Over-Characters commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de move-forward-character-command ()
  (if (not (move-over-characters nmode-command-argument))
    (Ding)))

(de move-backward-character-command ()
  (if (not (move-over-characters (- nmode-command-argument)))
    (Ding)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Move-Over-Word commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de move-forward-word-command ()
  (if (not (move-over-words nmode-command-argument))
    (Ding)))

(de move-backward-word-command ()
  (if (not (move-over-words (- nmode-command-argument)))
    (Ding)))

(de move-over-words (n)
  % Move forward (n>0) or backwards (n<0) over |n| words.  Return T if the
  % specified number of words were found, NIL otherwise.  The cursor remains at
  % the last word found.

  (let ((flag T))
    (while (and (> n 0) (setf flag (move-forward-word)))
      (setf n (- n 1)))
    (while (and (< n 0) (setf flag (move-backward-word)))
      (setf n (+ n 1)))
    flag))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Move-Over-Form commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de move-forward-form-command ()
  (if (not (move-over-forms nmode-command-argument))
    (Ding)))

(de move-backward-form-command ()
  (if (not (move-over-forms (- nmode-command-argument)))
    (Ding)))

(de move-over-forms (n)
  % Move forward (n>0) or backwards (n<0) over |n| forms.  Return T if the
  % specified number of forms were found, NIL otherwise.  The cursor remains at
  % the last form found.

  (let ((flag T))
    (while (and (> n 0) (setf flag (move-forward-form)))
      (setf n (- n 1)))
    (while (and (< n 0) (setf flag (move-backward-form)))
      (setf n (+ n 1)))
    flag))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Move-Up-List commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de forward-up-list-command ()
  (if (not (move-up-lists nmode-command-argument))
    (Ding)))

(de backward-up-list-command ()
  (if (not (move-up-lists (- nmode-command-argument)))
    (Ding)))

(de move-up-lists (n)
  % Move forward (n>0) or backwards (n<0) out of |n| lists (structures).
  % Return T if the specified number of brackets were found, NIL otherwise.
  % The cursor remains at the last bracket found.

  (let ((flag T))
    (while (and (> n 0) (setf flag (move-forward-up-list)))
      (setf n (- n 1)))
    (while (and (< n 0) (setf flag (move-backward-up-list)))
      (setf n (+ n 1)))
    flag
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Move-Over-List commands
%
% Note: In EMACS, these commands were motivated by the fact that EMACS did
% not understand Lisp comments.  Thus, in EMACS, move-forward-list could be
% used as a move-forward-form that ignored comments.  Since NMODE does
% understand comments, it is not clear that these commands have any use.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de move-forward-list-command ()
  (if (not (move-over-lists nmode-command-argument))
    (Ding)))

(de move-backward-list-command ()
  (if (not (move-over-lists (- nmode-command-argument)))
    (Ding)))

(de move-over-lists (n)
  % Move forward (n>0) or backwards (n<0) over |n| lists (structures).
  % Return T if the specified number of lists were found, NIL otherwise.
  % The cursor remains at the last list found.

  (let ((flag T))
    (while (and (> n 0) (setf flag (move-forward-list)))
      (setf n (- n 1)))
    (while (and (< n 0) (setf flag (move-backward-list)))
      (setf n (+ n 1)))
    flag
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Move-Over-Defun commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de move-forward-defun-command ()
  (if (not (move-over-defuns nmode-command-argument))
    (Ding)))

(de move-backward-defun-command ()
  (if (not (move-over-defuns (- nmode-command-argument)))
    (Ding)))

(de move-over-defuns (n)
  % Move forward (n>0) or backwards (n<0) over |n| defuns.
  % Return T if the specified number of defuns were found, NIL otherwise.
  % The cursor remains at the last defun found.

  (let ((flag T))
    (while (and (> n 0) (setf flag (move-forward-defun)))
      (setf n (- n 1)))
    (while (and (< n 0) (setf flag (move-backward-defun)))
      (setf n (+ n 1)))
    flag
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Basic Character Movement Primitives
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de move-over-characters (n)
  % Move forward (n>0) or backwards (n<0) over |n| characters.  Return T if the
  % specified number of characters were found, NIL otherwise.  The cursor
  % remains at the last character found.

  (let ((flag T))
    (while (and (> n 0) (setf flag (move-forward-character)))
      (setf n (- n 1)))
    (while (and (< n 0) (setf flag (move-backward-character)))
      (setf n (+ n 1)))
    flag))

(de move-forward-character ()
  % Move forward one character.  If there is no next character, leave cursor
  % unchanged and return NIL; otherwise, return T.

  (if (at-buffer-end?)
    NIL
    (move-forward)
    T
    ))

(de move-backward-character ()
  % Move backward one character.  If there is no previous character, leave
  % cursor unchanged and return NIL; otherwise, return T.

  (if (at-buffer-start?)
    NIL
    (move-backward)
    T
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Basic Character Movement Primitives (Hacking Tabs Version)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de move-over-characters-hacking-tabs (n)
  % Move forward (n>0) or backwards (n<0) over |n| characters.  Return T if the
  % specified number of characters were found, NIL otherwise.  The cursor
  % remains at the last character found.

  (let ((flag T))
    (while (and (> n 0) (setf flag (move-forward-character-hacking-tabs)))
      (setf n (- n 1)))
    (while (and (< n 0) (setf flag (move-backward-character-hacking-tabs)))
      (setf n (+ n 1)))
    flag))

(de move-forward-character-hacking-tabs ()
  % Move forward one character.  If the next character is a tab, first
  % replace it with the appropriate number of spaces.  If there is no next
  % character, leave cursor unchanged and return NIL; otherwise, return T.

  (if (at-buffer-end?)
    NIL
    (cond ((= (next-character) (char TAB))
	   (delete-next-character)
	   (let ((n (- 8 (& (current-display-column) 7))))
	     (insert-string (substring "        " 0 n))
	     (set-char-pos (- (current-char-pos) n))
	     )))
    (move-forward)
    T
    ))

(de move-backward-character-hacking-tabs ()
  % Move backward one character.  If the previous character is a tab, first
  % replace it with the appropriate number of spaces.  If there is no previous
  % character, leave cursor unchanged and return NIL; otherwise, return T.

  (if (at-buffer-start?)
    NIL
    (cond ((= (previous-character) (char TAB))
	   (delete-previous-character)
	   (let ((n (- 8 (& (current-display-column) 7))))
	     (insert-string (substring "        " 0 n))
	     )))
    (move-backward)
    T
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Basic Word Movement Primitives
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de word-char? (ch)
  (or (AlphanumericP ch) (= ch (char -))))

(de move-forward-word ()
  % Move forward one "word", starting from point.  Leave cursor to the
  % right of the "word".  If there is no next word, leave cursor unchanged
  % and return NIL; otherwise, return T.

  (let ((old-pos (buffer-get-position)))
    (while (and (not (at-buffer-end?)) % scan for start of word
	        (not (word-char? (next-character)))
	        )
      (move-forward))
    (cond ((at-buffer-end?)
	   (buffer-set-position old-pos)
	   NIL
	   )
	  (t
	   (while (and (not (at-buffer-end?)) % scan for end of word
		       (word-char? (next-character))
		       )
	     (move-forward))
	   T
	   ))))

(de move-backward-word ()
  % Move backward one "word", starting from point.  Leave cursor to the left of
  % the "word".  If there is no previous word, leave cursor unchanged and
  % return NIL; otherwise, return T.

  (let ((old-pos (buffer-get-position)))
    (while (and (not (at-buffer-start?)) % scan for end of word
	        (not (word-char? (previous-character)))
	        )
      (move-backward))
    (cond ((at-buffer-start?)
	   (buffer-set-position old-pos)
	   NIL
	   )
	  (t
	   (while (and (not (at-buffer-start?)) % scan for start of word
		       (word-char? (previous-character))
		       )
	     (move-backward))
	   T
	   ))))