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

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Commands.SL - Miscellaneous NMODE commands
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        24 August 1982
% Revised:     3 December 1982
%
% 3-Dec-82 Alan Snyder
%   Changed Insert-Self-Command to handle control- and meta- characters.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects extended-char fast-int))

% External variables used:

(fluid '(nmode-current-buffer nmode-command-argument nmode-current-window
         nmode-command-argument-given nmode-current-command
	 nmode-terminal nmode-allow-refresh-breakout
	 Text-Mode
	 ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de insert-self-command ()
  (if (FixP nmode-current-command)
    (let ((ch (x-base nmode-current-command)))
      (if (x-control? nmode-current-command)
	(let ((nch (char-upcase ch)))
	  (if (and (>= nch #/@) (<= nch #/_))
	    (setf ch (^ nch #/@))
	    )))
      (for (from i 1 nmode-command-argument)
	   (do (insert-character ch)))
      )
    % otherwise
    (Ding)
    ))

(de insert-next-character-command ()
  (nmode-append-separated-prompt "C-Q")
  (let ((ch (x-base (input-direct-terminal-character))))
    (nmode-complete-prompt (string-concat " " (x-char-name ch)))
    (for (from i 1 nmode-command-argument)
	 (do (insert-character ch)))))

(de return-command ()
  % Insert an EOL, unless we are at the end of thee current line and the
  % next line is empty.  Repeat as directed.

  (for (from i 1 nmode-command-argument)
       (do (cond ((and (at-line-end?) (not (at-buffer-end?)))
		  (move-to-next-line)
		  (cond ((not (current-line-empty?))
			 (insert-eol)
			 (move-to-previous-line)
			 )))
		 (t (insert-eol))))))

(de select-buffer-command ()
  (buffer-select (prompt-for-selectable-buffer)))

(de prompt-for-selectable-buffer ()
  (let ((default-b (=> nmode-current-buffer previous-buffer)))
    (if (and default-b (not (buffer-is-selectable? default-b)))
      (setf default-b NIL))
    (prompt-for-buffer "Select Buffer: " default-b)))

(de kill-buffer-command ()
  (let ((b (prompt-for-existing-buffer "Kill buffer: " nmode-current-buffer)))
    (if (or (not (=> b modified?))
	    (YesP "Kill unsaved buffer?"))
	(buffer-kill-and-detach b))))

(de insert-buffer-command ()
  (let ((b (prompt-for-existing-buffer "Insert Buffer:" nmode-current-buffer)))
    (insert-buffer-into-buffer b nmode-current-buffer)
    ))

(de select-previous-buffer-command ()
  (let ((old-buffer nmode-current-buffer))
    (buffer-select-previous nmode-current-buffer)
    (if (eq old-buffer nmode-current-buffer) (Ding)) % nothing visible happened
    ))

(de visit-in-other-window-command ()
  (nmode-2-windows)
  (selectq (char-upcase (input-base-character))
    (#/B (let ((b (prompt-for-selectable-buffer)))
	   (window-select-buffer (nmode-other-window) b)))
    (#/F (find-file-in-window
	  (nmode-other-window)
	  (prompt-for-file-name "Find file: " NIL)
	  ))
    (t (Ding))
    ))

(de nmode-refresh-command ()
  (if nmode-command-argument-given
    (let* ((arg nmode-command-argument)
	   (w nmode-current-window)
	   (height (=> w height))
	   (line (current-line-pos))
	   )
      (if (>= arg 0)
	  (=> w set-buffer-top (- line arg))
	  (=> w set-buffer-top (- (- line height) arg)))
      (nmode-refresh)
      )
    % Otherwise
    (=> nmode-current-window readjust-window)
    (nmode-full-refresh)
    ))

(de open-line-command ()
  (for (from i 1 nmode-command-argument)
       (do (insert-eol)
	   (move-backward)
	   )))

(de Ding ()
  (=> nmode-terminal ring-bell))

(de buffer-not-modified-command ()
  (=> nmode-current-buffer set-modified? NIL)
  )

(de set-mark-command ()
  (cond (nmode-command-argument-given
	 (buffer-set-position (current-mark))
	 (previous-mark)
	 )
	(t
	 (set-mark-from-point)
	 )))

(de mark-beginning-command ()
  (let ((old-pos (buffer-get-position)))
    (move-to-buffer-start)
    (set-mark-from-point)
    (buffer-set-position old-pos)
    ))

(de mark-end-command ()
  (let ((old-pos (buffer-get-position)))
    (move-to-buffer-end)
    (set-mark-from-point)
    (buffer-set-position old-pos)
    ))

(de transpose-characters-command ()
  (cond ((or (at-line-start?) (< (current-line-length) 2))
	 (Ding)
	 )
	(t
	 (if (at-line-end?) % We are at the end of a non-empty line.
	     (move-backward)
	     )
	 % We are in the middle of a line.
	 (let ((ch (previous-character)))
	   (delete-previous-character)
	   (move-forward)
	   (insert-character ch)
	   )
	 )))

(de mark-word-command ()
  (let ((old-pos (buffer-get-position)))
    (move-forward-word-command)
    (set-mark-from-point)
    (buffer-set-position old-pos)
    ))

(de mark-form-command ()
  (let ((old-pos (buffer-get-position)))
    (move-forward-form-command)
    (set-mark-from-point)
    (buffer-set-position old-pos)
    ))

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

(de nmode-abort-command ()
  (throw 'abort NIL)
  )

(de start-scripting-command ()
  (let ((b (prompt-for-buffer "Script Input to Buffer:" NIL)))
    (nmode-script-terminal-input b)
    ))

(de stop-scripting-command ()
  (nmode-script-terminal-input nil)
  )

(de execute-buffer-command ()
  (let ((b (prompt-for-buffer "Execute from Buffer:" NIL)))
    (setf nmode-allow-refresh-breakout nmode-command-argument-given)
    (nmode-execute-buffer b)
    ))

(de execute-file-command ()
  (nmode-execute-file (prompt-for-file-name "Execute File:" NIL)))

(de nmode-execute-file (fn)
  (let ((b (buffer-create-unselectable "FOO" Text-Mode)))
    (read-file-into-buffer b fn)
    (setf nmode-allow-refresh-breakout nmode-command-argument-given)
    (nmode-execute-buffer b)
    ))

(de apropos-command ()
  (let ((s (prompt-for-string
	    "Show commands whose names contain the string:"
	    NIL
	    )))
    (nmode-begin-typeout)
    (print-matching-dispatch s)
    (printf "-----")
    (nmode-end-typeout)
    ))