reduce-historical/psl-1983/emode/hp-emodex.sl

%
% HP-EMODEX.SL - General HP EMODE Extensions
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        2 August 1982
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%% Changes: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% WFG  23 August 1982
% - Modified transpose-characters-command to behave as if at end of line if
%   the last command dispatched on was InsertSelfCharacter.
% - Made several "lispy" commands specific to Lisp mode rather than text
%   mode.


(BothTimes (load common))

% The following symbolic constants should be used in source code
% instead of the equivalent (Char X) expression to avoid fooling
% EMODE's stupid LISP parser while editing this file:

(CompileTime (setf LEFT-PAREN 40))
(CompileTime (setf RIGHT-PAREN 41))
(CompileTime (setf LEFT-PAREN-ID (int2id 40)))
(CompileTime (setf RIGHT-PAREN-ID (int2id 41)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Window Scrolling Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(fluid '(CurrentLineIndex))

(de scroll-window-by-lines (n)

  % Scroll the contents of the current window up (n > 0) or down (n < 0)
  % by |n| lines.  CurrentLineIndex may be adjusted to keep it within
  % the desired window location.

  (let* ((window-height (current-window-height))
         (new-top-line (+ (current-window-top-line) n))
         (buffer-last-line (- (current-buffer-visible-size) 1))
         )

    % adjust to keep something in the window
    (cond
      ((< new-top-line 0) (setf new-top-line 0))
      ((> new-top-line buffer-last-line) (setf new-top-line buffer-last-line))
      )

    % adjust cursor if no longer in window
    (cond
      ((< CurrentLineIndex new-top-line)
       (SelectLine new-top-line))
      ((>= CurrentLineIndex (+ new-top-line window-height))
       (SelectLine (+ new-top-line window-height -1)))
      )
    (current-window-set-top-line new-top-line)
    ))

(de scroll-window-by-pages (n)

  % Scroll the contents of the current window up (n > 0) or down (n < 0)
  % by |n| screen-fulls.  CurrentLineIndex may be adjusted to keep it within
  % the desired window location.

  (let* ((old-top-line (current-window-top-line))
	 (window-height (current-window-height))
         (new-top-line (+ (current-window-top-line) (* n window-height)))
         (buffer-last-line (- (current-buffer-visible-size) 1))
         )

    % don't do the scroll if no change is needed
    (cond ((and (> new-top-line (- window-height))
	        (<= new-top-line buffer-last-line))
	   (setf new-top-line (max new-top-line 0))

	   % keep the cursor at the same relative location in the window!
	   (SelectLine (min (+ CurrentLineIndex (- new-top-line old-top-line))
			    (- (current-buffer-size) 1)))
	   (current-window-set-top-line new-top-line)
	   ))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Window Scrolling Commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de scroll-window-up-line-command ()
  (scroll-window-by-lines 1)
  )

(de scroll-window-down-line-command ()
  (scroll-window-by-lines -1)
  )

(de scroll-window-up-page-command ()
  (scroll-window-by-pages 1)
  )

(de scroll-window-down-page-command ()
  (scroll-window-by-pages -1)
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Basic Indenting Primitives
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de current-line-indent ()
  % Return the indentation of the current line, in terms of spaces.

  (for (in ch CurrentLine)
       (while (or (= ch (char space)) (= ch (char tab))))
       (sum (if (= ch (char tab)) 8 1))
       ))

(de current-line-strip-indent ()
  % Strip all leading blanks and tabs from the current line.
  (while (and CurrentLine (char-blank? (car CurrentLine)))
    (setf CurrentLine (cdr CurrentLine))
    (if (> point 0) (setf point (- point 1)))
    ))

(de strip-previous-blanks ()
  % Strip all blanks and tabs before point.
  (while (and (> point 0)
	      (char-blank? (current-line-fetch (- point 1))))
	 ($DeleteBackwardCharacter))
  )

(de indent-current-line (n)
 % Adjust the current line to have the specified indentation.
  
  (current-line-strip-indent)
  (let ((n-spaces (remainder n 8))
         (n-tabs (quotient n 8)))
    (for (from i 1 n-spaces 1)
      (do (setf CurrentLine (cons (char space) CurrentLine))
        (setf point (+ 1 point))))
    (for (from i 1 n-tabs 1)
      (do (setf CurrentLine (cons (char tab) CurrentLine))
        (setf point (+ 1 point))))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Basic Indenting Commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(SetTextKey (char (meta !\)) 'delete-horizontal-space-command)
(de delete-horizontal-space-command ()
  (prog (ch)
    (while (< point (current-line-length))
      (setf ch (current-line-fetch point))
      (if (not (char-blank? ch)) (exit))
      (DeleteCharacter)
      )
    (while (> point 0)
      (setf ch (current-line-fetch (- point 1)))
      (if (not (char-blank? ch)) (exit))
      (setf point (- point 1))
      (DeleteCharacter)
      )
    ))

(SetTextKey (CharSequence (cntrl X) (cntrl O)) 'delete-blank-lines-command)
(de delete-blank-lines-command ()
  (cond ((current-line-blank?)
	 % We are on a blank line.
	 % Replace multiple blank lines with one.
	 % First, search backwards for the first blank line
	 % and save its index.
	 (while (> CurrentLineIndex 0)
	   ($BackwardLine)
	   (cond ((not (current-line-blank?))
		  ($ForwardLine)
		  (exit))
		 )
	   )
	 (delete-following-blank-lines)
	 )
	(t
	 % We are on a non-blank line.  Delete any blank lines
	 % that follow this one.
	 (delete-following-blank-lines)
	 )
    ))

(de delete-following-blank-lines ()

  % Delete any blank lines that immediately follow the current one.

  (if (not (current-line-is-last?))
      (progn
       (let ((old-index CurrentLineIndex)
	     (old-point point)
	     first-index
		   )
	    % Advance past the current line until the next nonblank line.
	    (move-to-next-line)
	    (setf first-index CurrentLineIndex)
	    (while T
		   (cond ((not (current-line-blank?)) (exit))
			 ((current-line-is-last?) ($EndOfLine) (exit))
			 (t (move-to-next-line))
			 ))
	    (delete_or_copy T first-index 0 CurrentLineIndex point)
	    (current-buffer-goto old-index old-point)
	    ))))

(SetTextKey (char (meta M)) 'back-to-indentation-command)
(SetTextKey (char (meta (cntrl M))) 'back-to-indentation-command)

(de back-to-indentation-command ()
  ($BeginningOfLine)
  (while (char-blank? (CurrentCharacter))
	 ($ForwardCharacter)
	 ))

(SetTextKey (char (meta ^)) 'delete-indentation-command)
(de delete-indentation-command ()
  (current-line-strip-indent)
  ($BeginningOfLine)
  (if (not (current-line-is-first?))
      (progn
       ($DeleteBackwardCharacter)
       (if (and (not (= point 0))
		(not (= (current-line-fetch (- point 1)) #.LEFT-PAREN))
		(not (= (CurrentCharacter) #.RIGHT-PAREN))
		)
	   (InsertCharacter (char space))
	   ))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% LISP Indenting
% Note: this is a crock - need more sophisticated scanning
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(SetLispKey (char tab) 'lisp-tab-command)
(SetLispKey (char (meta (cntrl tab))) 'lisp-tab-command)
(SetLispKey (char LF) 'lisp-linefeed-command)
(SetLispKey (char (meta (cntrl Q))) 'lisp-indent-sexpr)

(de lisp-tab-command ()
  (indent-current-line (lisp-current-line-indent)))

(de lisp-linefeed-command ()
  ($CRLF)
  (indent-current-line (lisp-current-line-indent)))

(de lisp-indent-sexpr ()
  (if (not (move-down-list))
      (Ding)
      (let ((old-line CurrentLineIndex)
	    (old-point (- point 1))
	    final-line)
	   (if (not (forward-scan-for-right-paren -1))
	       (Ding)
	       (setf final-line CurrentLineIndex)
	       (for (from i (+ old-line 1) final-line 1)
		    (do
		     (SelectLine i)
		     (indent-current-line (lisp-current-line-indent))
		     ))
	       (current-buffer-goto old-line old-point)))
      ))

(de lisp-current-line-indent ()
  (let ((old-point point)
	(old-line CurrentLineIndex)
	indentation
	previous-line)
    (cond ((and (> CurrentLineIndex 0)
		(setf previous-line (GetBufferText (- CurrentLineIndex 1)))
		(>= (size previous-line) 0)
		(= (indx previous-line 0) #.LEFT-PAREN)
		)
	   2)
	  (t
	   (setf point 0)
	   (backward_sexpr)
	   (setf indentation (LineColumn point (List2String CurrentLine)))
	   (current-buffer-goto old-line old-point)
	   indentation
	   ))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Miscellaneous Commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(SetTextKey (char (cntrl T)) 'transpose-characters-command)

% Transpose the last two characters, if we're at the end of the line, or if
% a character was just inserted.  Otherwise, transpose the characters on
% either side of point.
(de transpose-characters-command ()
  (progn 
    (if (or
          (= point (current-line-length))
          (eq last_operation 'InsertSelfCharacter))
      % We are at the end of a non-empty line, or last character was self
      % inserting.
      ($BackwardCharacter))

    (cond
      % We are at the beginning of a line, or the line has fewer then two
      % characters?
      ((or (= point 0) (< (current-line-length) 2))
        (Ding))

      (t
        % We are in the middle of a line.
        (prog (ch)
          ($BackwardCharacter)
          (setf ch (CurrentCharacter))
          (DeleteCharacter)
          ($ForwardCharacter)
          (InsertCharacter ch)
          )
        ))))

(SetTextKey (char (meta @)) 'mark-word-command)
(de mark-word-command ()
  (let ((old-index CurrentLineIndex)
	(old-point point))
    (forward_word)
    (SetMark)
    (current-buffer-goto old-index old-point)
    ))

(SetTextKey (char (meta (cntrl @))) 'mark-sexp-command)
(de mark-sexp-command ()
  (let ((old-index CurrentLineIndex)
	(old-point point))
    (forward_sexpr)
    (SetMark)
    (current-buffer-goto old-index old-point)
    ))

(SetTextKey (CharSequence (cntrl X) H) 'mark-whole-buffer-command)
(de mark-whole-buffer-command ()
  ($EndOfBuffer)
  (SetMark)
  ($BeginningOfBuffer)
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% LISP Defun Commands and Primitives
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(SetLispKey (char (meta (cntrl A))) 'beginning-of-defun-command)
(SetLispKey (char (meta (cntrl ![))) 'beginning-of-defun-command)

(de beginning-of-defun-command ()

  % Move BACKWARD (literally) to the beginning of the current
  % (or previous) DEFUN.  If this is impossible, Ding and don't move.

  (if (at-buffer-start?)
      (Ding)
      ($BackwardCharacter)
      (if (not (beginning-of-defun)) (progn ($ForwardCharacter) (Ding)))
      ))

(de beginning-of-defun ()
  % Move backward to the beginning of the current DEFUN.  A DEFUN is
  % heuristically defined to be a line whose first character is a left
  % parenthesis.  If no DEFUN is found, point is left unchanged and
  % NIL is returned; otherwise T is returned.

  (let ((pos (buffer-get-position))
	)
    ($BeginningOfLine)
    (while T
	   (cond ((= (CurrentCharacter) #.LEFT-PAREN) (exit T))
		 ((current-line-is-first?)
		  (buffer-set-position pos)
		  (exit NIL))
		 (t (move-to-previous-line))
		 ))))

(SetLispKey (char (meta (cntrl E))) 'end-of-defun-command)
(SetLispKey (char (meta (cntrl !]))) 'end-of-defun-command)

(de end-of-defun-command ()
  % Move FORWARD (literally) to the beginning of the next line following
  % the end of a DEFUN.
  (let ((old-line CurrentLineIndex)
	)
    (if (or (not (end-of-defun)) (< CurrentLineIndex old-line))
	% If there is no current defun, or we were past the end of the
	% previous DEFUN, then we should continue onward to look for the
	% next DEFUN.
	(if (forward-defun)
	    (forward_sexpr)
	    (Ding)
	    )))
  (move-to-next-line)
  )

(de forward-defun ()
  % Move forward to the beginning of the next DEFUN.
  % If no DEFUN is found, point is left unchanged and
  % NIL is returned; otherwise T is returned.

  (let ((pos (buffer-get-position))
	)
    (while T
	   (move-to-next-line)
	   (cond ((= (CurrentCharacter) #.LEFT-PAREN) (exit T))
		 ((current-line-is-last?)
		  (buffer-set-position pos)
		  (exit NIL))
		 ))))

(de end-of-defun ()

  % Move forward to the end of the current DEFUN.
  % If there is no current DEFUN, don't move and return NIL.
  % Otherwise, return T.

  (cond ((not (beginning-of-defun)) NIL)
	(t (forward_sexpr) T)
	))

(SetLispKey (char (meta (cntrl H))) 'mark-defun-command)

(de mark-defun-command ()
  (end-of-defun-command)
  (SetMark)
  (beginning-of-defun-command)
  (if (> CurrentLineIndex 0)
      (progn
       (move-to-previous-line)
       (if (not (current-line-blank?))
	   (move-to-next-line))
       ))
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Lisp List Commands and Primitives
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(fluid '(paren_depth)) % see Search.RED

% Perhaps SetLispKey is more appropriate?
(SetTextKey (char (meta (cntrl P))) 'move-past-previous-list)

(de move-past-previous-list ()
  % Move to the beginning of the current or previous list.  In other words,
  % find the previous left paren whose matching right paren is after point
  % or is the first right paren before point.
  % If no such left paren can be found, Ding, but do not move.

  (if (not (reverse-scan-for-left-paren 0)) (Ding))
  )

% (SetTextKey (char (meta (cntrl #.LEFT-PAREN-ID))) 'backward-up-list)
(SetTextKey (char (meta (cntrl U))) 'backward-up-list)
(de backward-up-list ()
  % Move to the left of the current list.  "Dual" to forward-up-list.
  (if (not (reverse-scan-for-left-paren 1)) (Ding))
  )

(de reverse-scan-for-left-paren (depth)

  % Scan backwards (starting with the character before point) for
  % a left paren at depth >= the specified depth.  If found, the
  % left paren will be after point and T will be returned.  Otherwise,
  % point will not change and NIL will be returned.

  (let ((old-position (buffer-get-position))
	ch
	)
    (setf paren_depth 0)
    (while T
      (cond ((and (= ch #.LEFT-PAREN) (>= paren_depth depth))
	     (exit T))
	    ((at-buffer-start?)
	     (buffer-set-position old-position)
	     (exit NIL))
	    (t ($BackwardCharacter)
	       (setf ch (CurrentCharacter))
	       (adjust_depth ch)
	       )
	    ))))

(SetTextKey (char (meta (cntrl N))) 'move-past-next-list)
(de move-past-next-list ()
  % Move to the right of the current or next list.  In other words,
  % find the next right paren whose matching left paren is before point
  % or is the first left paren after point.
  % If no such right paren can be found, Ding, but do not move.

  (if (not (forward-scan-for-right-paren 0)) (Ding))
  )

% (SetTextKey (char (meta (cntrl #.RIGHT-PAREN-ID))) 'forward-up-list)
(SetTextKey (char (meta (cntrl O))) 'forward-up-list)
(de forward-up-list ()
  % Move to the right of the current list.  In other words,
  % find the next right paren whose matching left paren is before point.
  % If no such right paren can be found, Ding, but do not move.

  (if (not (forward-scan-for-right-paren -1)) (Ding))
  )

(de forward-scan-for-right-paren (depth)

  % Scan forward (starting with the character after point) for
  % a right paren at depth <= the specified depth.  If found, the
  % right paren will be before point and T will be returned.  Otherwise,
  % point will not change and NIL will be returned.

  (let ((old-position (buffer-get-position))
	ch
	)
    (setf paren_depth 0)
    (while T
      (cond ((at-buffer-end?)
	     (buffer-set-position old-position)
	     (exit NIL)))
      (setf ch (CurrentCharacter))
      (adjust_depth ch)
      ($ForwardCharacter)
      (cond ((and (= ch #.RIGHT-PAREN) (<= paren_depth depth))
	     (exit T))
	    ))))

(SetTextKey (char (meta (cntrl D))) 'down-list)
(de down-list ()
  % Move inside the next contained list.  In other words,
  % find the next left paren without an intervening right paren.
  % If no such left paren can be found, Ding, but do not move.

  (if (not (move-down-list)) (Ding))
  )

(de move-down-list ()
  (let ((old-position (buffer-get-position))
	ch
	)
    (while T
      (cond ((at-buffer-end?)
	     (buffer-set-position old-position)
	     (exit NIL)))
      (setf ch (CurrentCharacter))
      ($ForwardCharacter)
      (cond ((= ch #.LEFT-PAREN)
	     (exit T))
	    ((= ch #.RIGHT-PAREN)
	     (buffer-set-position old-position)
	     (exit NIL))
	    ))))

(SetTextKey (char (meta #.LEFT-PAREN-ID)) 'insert-parens)
(de insert-parens ()
  (InsertCharacter #.LEFT-PAREN)
  (InsertCharacter #.RIGHT-PAREN)
  ($BackwardCharacter)
  )

(SetTextKey (char (meta #.RIGHT-PAREN-ID)) 'move-over-paren)
(de move-over-paren ()
  (if (forward-scan-for-right-paren 0)
      (progn
       ($BackwardCharacter)
       (strip-previous-blanks)
       ($ForwardCharacter)
       (lisp-linefeed-command)
       )
      (Ding)))