Artifact 074372946eefca56e7640ed1a0588f4ae4a65e9e3c2121c3daec9642e4283fa3:

• File psl-1983/emode/hp-emodex.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 17414) [annotate] [blame] [check-ins using] [more...]

%
% 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)))