reduce-historical/psl-1983/emode/dispch.sl

%
% DISPCH.SL - Dispatch table utilities
% 
% Author:      William F. Galway
%              Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        25 July 1982
% Copyright (c) 1982 University of Utah
%

% The dispatch table (determining "keyboard bindings") is the 256 element
% vector "MainDispatch", AUGMENTED by association lists for C-X
% (and possibly other prefix) characters.  We actually use an association
% list of association lists: the top level is a list of 
% (prefixchar .  association-list), the second level is a list of
% (character_to_follow_prefix_char . procedure).  Associated with every
% buffer is a list of forms to evaluate which will establish that buffer's
% mode(s)--namely, the keyboard bindings that are in effect for that
% buffer.

% csp 7/7/82
% - Put all dispatch list and mode functions together, and collected
%   some into this file from EMODE1.
% - Modified EstablishCurrentMode to invoke DefinePrefixChars directly.
%   Generalized the idea of adding to a dispatch list with the function
%   AddToKeyList.
% - Modified mode lists to EVAL entries rather than APPLYing functions
%   to NIL.

% AS 7/12/82
% - Added C-X D (Dired), C-X K (Kill Buffer), M-C-L (Previous BUffer)
%   commands to Basic Dispatch list.
% - Separated out read-only text commands into ReadOnlyTextDispatchList.

% AS 7/21/82
% - Attached C-V and M-V to new scroll-window functions.

% WFG 25 July 1982
% - Dired stuff commented back out for now.  ModeEstablishProcedures
%   renamed to be ModeEstablishExpressions.

% AS 7/15/82
% - Changed AddToKeyList to add the new definition at the end of the
%   list, so that it will override existing definitions.
% - Added C-Q.

% AS 8/2/82
% - Revised $Iterate to use delayed prompting feature.

% WFG  23 August 1982
% - Changed AddToKeyList to call EstablishCurrentMode iff *EMODE is T.

(FLUID
  '(
    MainDispatch         % Dispatch table (vector), an entry for each key

    PrefixAssociationLists       % Additional dispatch information for
                                 % prefixed characters.

    % List of declared prefix characters.
    PrefixCharacterList

    SelfInsertCharacter  % Character being dispatched upon.

    last_operation       % The "last" routine dispatched to (before the
                         % "current operation").

    % List of expressions to be evaluated.  Each expression is expected to
    % modify (add to?) the dispatch table.
    ModeEstablishExpressions

    FundamentalTextMode     % See below
))

% Create MainDispatch vector, 256 entries in all.
(setf MainDispatch (MkVect 255))

% List of valid prefix characters.
(setf PrefixCharacterList NIL)

% Add a new prefix character and associated prompt.
(DE define_prefix_character (chr prompt-string)
  (setf PrefixCharacterList
    (cons (cons chr prompt-string) PrefixCharacterList)))

% Set up initial list of valid prefix characters.  Note that ESC (etc?)
% aren't implemented as "prefix characters", (although, perhaps they should
% be?)  NOTE: there seems to be something wrong in that we're using this
% general tool for only one prefix character.  (Note that M-X is not a
% prefix character.)
(define_prefix_character (char (cntrl X)) "C-X ")

% Generate a list of character codes, or a single character, from a list of
% "character descriptors".  Syntax is similar to that for the "Char"
% macro.
(DM CharSequence (chlist)
  (prog (processed-list)
    (setf processed-list
      (for (in chr-descriptor (cdr chlist))
        (collect (DoChar chr-descriptor))))

    % If there was a single character in the list, just return the
    % character code.
    (return
      (cond
        % Just return the character code if a single character.
        ((equal (length processed-list) 1)
          (car processed-list))
        % Otherwise, return the (quoted) list of character codes.
        (T
          `(quote ,processed-list))))))

% Return T if character has meta bit set.
(DS MetaP (chr)
  (GreaterP chr 127))

% Convert character to meta-character.
(DS MakeMeta (chr)
  (LOR chr 8#200))

% Return character with meta bit "stripped off"--converts meta to normal char.
(DS UnMeta (chr)
  (LAND chr 8#177))

% This version of "UpperCaseP" also handles meta-characters.
(DE X-UpperCaseP (chr)
  (cond
    ((MetaP chr)
      (UpperCaseP (UnMeta chr)))
    (T
      (UpperCaseP chr))))

(DE X-Char-DownCase (chr)
  (cond
    ((MetaP chr)
      (MakeMeta (Char-DownCase (UnMeta chr))))
    (T
      (Char-DownCase chr))))

% Set up a "clear" dispatch table.
(DE ClearDispatch ()
  (progn
    (for (from i 0 255 1)
      (do (Undefine i)))
    (setf PrefixAssociationLists NIL)))

% Set up the keyboard dispatch table for a character or "extended character".
% If the character is uppercase, define the equivalent lower case character
% also.
(DE SetKey (xchar op)
  (cond
    ((NumberP xchar)     % Add table entry for a simple character code.
      (progn
        (setf (indx MainDispatch xchar) op)
        (cond
          ((X-UpperCaseP xchar)
            (setf (indx MainDispatch (X-Char-DownCase xchar)) op)))))

    % If a valid prefixed character.
    ((and (PairP xchar) (Atsoc (car xchar) PrefixCharacterList))
      (prog (prefix-char assoc-entry)
        (setf prefix-char (car xchar))

        % Look up the prefix character in the a-list of a-lists.
        (setf assoc-entry (Atsoc prefix-char PrefixAssociationLists))

        % Add the prefix character if no entry present yet. 
        (cond
          ((null assoc-entry)
              (setf PrefixAssociationLists
                (cons
                  (setf assoc-entry (cons prefix-char NIL))
                  PrefixAssociationLists))))

        % Now, add the prefixed character to the association list.  Note
        % that in case of duplicate entries the last one added is the one
        % that counts.  (Perhaps we should go to a little more work and
        % DelQIP any old entry?)
        (RPLACD assoc-entry
          % (cadr xchar) is the prefixed character.
          (cons (cons (cadr xchar) op) (cdr assoc-entry)))

        % Define the lower case version of the character, if relevent. 
        (cond
          ((X-UpperCaseP (cadr xchar))
            (RPLACD assoc-entry
              (cons (cons
                      (X-Char-DownCase (cadr xchar))
                      op)
                (cdr assoc-entry)))))))

    % If we get here, SetKey was given a bad argument
    (T
      % (Use EMODEerror instead?)
      (Error 666 "Bad argument for SetKey"))))

% Procedure to define a character as "self inserting".
(DE MakeSelfInserting (chr)
  (SetKey chr 'InsertSelfCharacter))

% Define a character so that it just "dings" bell.
(DE Undefine (chr)
  (SetKey chr 'Ding))

(FLUID '(new-oper))

% Dispatch on next command character, "remember" the associated operation.
(DE Dispatcher ()
  (progn
    (Dispatch (GetNextCommandCharacter))
    (setf last_operation new-oper)))

% Dispatch on a character, "remember" the associated dispatch routine.
(DE Dispatch (chr)
  (prog (oper)
    (setf oper (indx MainDispatch chr))
    (setf new-oper oper)
    (apply oper NIL)))

% Read another character, and then perform appropriate operation from
% appropriate prefix "table" (association list).
(DE do-prefix ()
  (prog (prefix-entry char-entry chr)
    (setf prefix-entry (atsoc SelfInsertCharacter PrefixAssociationLists))
    (cond
      % "Complain" if no entry.
      ((null prefix-entry)
        (ding))

      % Otherwise, read a character and look up its entry.
      (T
        (setf chr
          (prompt_for_character
            % Prompt string for prefix
            (cdr (Atsoc SelfInsertCharacter PrefixCharacterList))))

        (setf char-entry (Atsoc chr prefix-entry))
        (cond
          ((null char-entry)
            (progn
              % Make note of the fact that we ding!
              (setf new-oper 'ding)
              (ding)))
          (T
            (apply (setf new-oper (cdr char-entry)) NIL)))))))

% Treat next command character" as "Meta-character".  (This routine is
% normally invoked by the "escape" character.)
(DE EscapeAsMeta ()
  (dispatch (LOR 8#200 (prompt_for_character "M-"))))

% Treat the next character as a "control-meta-character".  (This routine is
% normally invoked by cntrl-Z.)
(DE DoControlMeta ()
  (dispatch (LOR 8#200 (LAND 8#37 (prompt_for_character "M-C-")))))


(FLUID '(pushed_back_characters))

% Get command character, processing keyboard macros (someday! ), etc.
% Parity mask is used to clear "parity bit" for those terminals that don't
% have a meta key.  It should be 8#177 in that case.  Should be 8#377 for
% terminals with a meta key.  (Probably the wrong place to do this--if we
% also expect to handle keyboard macros! )
(DE GetNextCommandCharacter ()
  (cond
    % re-read any pushed back stuff.
    (pushed_back_characters
      (progn
        (setf SelfInsertCharacter (car pushed_back_characters))
        (setf pushed_back_characters (cdr pushed_back_characters))))

    (T
      (setf SelfInsertCharacter (Land parity_mask (PBIN))))))

% "Push back" a character.
(DE push_back (chr)
  (setf pushed_back_characters (cons chr pushed_back_characters)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Manipulating mode tables
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Set up dispatch table for current buffer, by evaluating the expressions
% in ModeEstablishExpressions.
(De EstablishCurrentMode ()
  (progn
    (ClearDispatch)

    % Use reverse so things on front of list are evaluated last.  (So that
    % later incremental changes are added later.)
    (for (in x (reverse ModeEstablishExpressions))
      (do
        (cond
          ((pairp x) (eval x))
          (t
            (error 667
              (bldmsg
            "%r is not a valid ""mode establish expression"" (non-list)"))))))

    % csp 7/782
    % Prefix chars are totally global anyway, so let them be
    %  established here, and let them override regular key defns.
    (DefinePrefixChars)))

% This list of (character-sequence . operation) defines a partial set
% of bindings for text mode (and other derived modes).  This list
% contains only commands that don't modify the buffer.

(setf ReadOnlyTextDispatchList (list

    % These commands are read-only commands for text mode.

    (cons (char (cntrl @)) 'SetMark)
    (cons (char (cntrl A)) '$BeginningOfLine)
    (cons (char (cntrl B)) '$BackwardCharacter)
    (cons (char (cntrl E)) '$EndOfLine)
    (cons (char (cntrl F)) '$ForwardCharacter)
    (cons (char (cntrl N)) '$ForwardLine)
    (cons (char (cntrl P)) '$BackwardLine)
    (cons (char (cntrl R)) 'reverse_string_search)
    (cons (char (cntrl S)) 'forward_string_search)
    (cons (char (cntrl V)) 'scroll-window-up-page-command)
    (cons (char (meta (cntrl B))) 'backward_sexpr)
    (cons (char (meta (cntrl F))) 'forward_sexpr)
    (cons (char (meta B)) 'backward_word)
    (cons (char (meta F)) 'forward_word)
    (cons (char (meta V)) 'scroll-window-down-page-command)
    (cons (char (meta W)) 'copy_region)
    (cons (char (meta <)) '$BeginningOfBuffer)
    (cons (char (meta >)) '$EndOfBuffer)
    (cons (CharSequence (cntrl X) (cntrl X)) 'ExchangePointAndMark)

    % Note that these two would be nice to have for other "data modes" than
    % text.  But current versions aren't generic enough.
    (cons (CharSequence (cntrl X) 1) 'OneWindow)
    (cons (CharSequence (cntrl X) 2) 'TwoRfaceWindows)
    ))

% This list of (character-sequence .  operation) defines bindings for text mode
% (and other derived modes).  TextDispatchList includes the initial contents of
% ReadOnlyTextDispatchList (above).  Be sure to put read-only commands on that
% list!

(setf TextDispatchList
  (append
    (list
      (cons (char !)) 'insert_matching_paren)
      (cons (char (cntrl D)) '$DeleteForwardCharacter)
      (cons (char (cntrl K)) 'kill_line)
      (cons (char (cntrl O)) 'OpenLine)
      (cons (char (cntrl Q)) 'InsertNextCharacter)
      (cons (char (cntrl T)) 'transpose_characters)
      (cons (char (cntrl W)) 'kill_region)
      (cons (char (cntrl Y)) 'insert_kill_buffer)
      (cons (char (meta (cntrl K))) 'kill_forward_sexpr)
      (cons (char (meta (cntrl RUBOUT))) 'kill_backward_sexpr)
      (cons (char (meta D)) 'kill_forward_word)
      (cons (char (meta Y)) 'unkill_previous)
      (cons (char (meta RUBOUT)) 'kill_backward_word)
      (cons (char DELETE) '$DeleteBackwardCharacter)
      (cons (char LF) '$CRLF)
      (cons (char CR) '$CRLF)
      (cons (char (meta !%)) 'Query-Replace-Command)
      (cons (CharSequence (cntrl X) (cntrl R)) 'CntrlXread)
      (cons (CharSequence (cntrl X) (cntrl S)) 'save_file)
      (cons (CharSequence (cntrl X) (cntrl W)) 'CntrlXwrite)
      )

    ReadOnlyTextDispatchList
    ))

% Add the (chr opr) binding to a list with name listname.
(de AddToKeyList (listname chr opr)
  (let*
    ((old-list (eval listname))
      (old-binding (atsoc chr old-list))
      (binding (cons chr opr)))
    (cond
      % If the binding isn't already in the a-list.
      ((null old-binding)
        % Add the new binding (Destructively to the end, so it's sure to
        % override any old stuff).
        (set listname (aconc old-list binding)))

      % Otherwise, replace the old operation in the binding.
      (T
        (setf (cdr old-binding) opr)))

    % Update the current mode if EMODE is running, in case it's affected by
    % the list we just modified.
    (cond
      (*EMODE
        (EstablishCurrentMode)))))

% Add a new key binding to "text mode".
(de SetTextKey (chr opr)
  (AddToKeyList 'TextDispatchList chr opr))

% Add a new key binding to "Lisp mode".
(de SetLispKey (chr opr)
  (AddToKeyList 'LispDispatchList chr opr))

% Execute the expressions in this list to establish "Fundamental Text Mode".
(setf FundamentalTextMode
  '((SetKeys TextDispatchList)
     (SetKeys BasicDispatchList)
     (NormalSelfInserts)))

(de SetKeys (lis)
  (for (in x lis) (do (SetKey (car x) (cdr x)))))

(de NormalSelfInserts ()
  (for (from i 32 126) (do (MakeSelfInserting i))))

(setf BasicDispatchList
  (list
	(cons (char ESC) 'EscapeAsMeta)
	(cons (char (cntrl U)) '$Iterate)
	(cons (char (cntrl Z)) 'DoControlMeta)

	% NOT basic?
	(cons (CharSequence (cntrl X) (cntrl B)) 'PrintBufferNames)
	(cons (CharSequence (cntrl X) B) 'ChooseBuffer)

%Dired stuff commented out for now.
%?	(cons (CharSequence (cntrl X) D) 'dired-command)

% window-kill-buffer not implemented yet?
%?	(cons (CharSequence (cntrl X) K) 'window-kill-buffer)

        % "C-X N" switches to "next window" (or "other window" if in "two
        % window mode").
        (cons (CharSequence (cntrl X) N) 'next_window)
        % "C-X O" does the same as "C-X N"
	(cons (CharSequence (cntrl X) O) 'next_window)

        % "C-X P" moves to "previous window".
        (cons (CharSequence (cntrl X) P) 'previous_window_command)

        % C-X C-Z causes us to exit to monitor.
        (cons (CharSequence (cntrl X) (cntrl Z)) 'QUIT)

        % M-C-Z causes us to rebind the channels for "normal" I/O, and
        % leave EMODE.
        (cons (char (meta (cntrl Z))) 'OldFace)

%Dired stuff commented out for now.
%?	(cons (char (meta (cntrl L))) 'SelectPreviousBuffer)

	(cons (char (cntrl L)) 'FullRefresh)

	% Two ways to invoke the help function.
	(cons (char (meta !/ )) '$HelpDispatch)
	(cons (char (meta !?)) '$HelpDispatch)

        (cons (CharSequence (cntrl X) (cntrl F)) 'find_file)

        (cons (CharSequence (cntrl X) (cntrl P)) 'WriteScreenPhoto)
        (cons (char (meta X)) 'execute_command)))

% Define the prefix characters given in PrefixCharacterList.
(de DefinePrefixChars ()
    (for (in prefix-entry PrefixCharacterList)
      (do
        % car gives character code for prefix.
        (SetKey (car prefix-entry) 'do-prefix))))

% IS THE FOLLOWING REALLY APPROPRIATE TO DISPATCH?

% Simulate EMACS's C-U, C-U meaning 4, C-U C-U meaning 16, etc., and C-U
% <integer> meaning <integer>.  This command suffers from the flaw of
% simply iterating the following command, instead of giving it a
% parameter.  Thus, for example, C-U C-A won't do what you expect.
%  Written by Alan Snyder, HP labs.

(fluid '(prompt-immediately prompt-was-output))

% C-U handler.
(de $iterate ()
  (let ((arg 1)
	(ch (char (control U)))
	(previous-ch nil)
	(prompt "")
	(prompt-immediately nil)
       )
    (while T
	(cond ((eqn ch (char (control U)))
	       (if previous-ch (setq prompt (concat prompt " ")))
	       (setq prompt (concat prompt "C-U"))
	       (setq arg (times arg 4))
	       )
              % Note check for non-meta character.  (Since DigitP blows up
              % otherwise?  Test may be obsolete??)
              ((and (LessP ch 128) (digitp ch))
	       (if (and previous-ch (digitp previous-ch))
		   (setq arg (plus (times arg 10) (char-digit ch)))
		   % ELSE
		   (setq arg (char-digit ch))
		   (setq prompt (concat prompt " "))
		   )
	       (setq prompt (concat prompt (string ch)))
	       )
	      (t (exit)))
	(setq previous-ch ch)
	(setq ch (prompt_for_character prompt))
	(setq prompt-immediately prompt-was-output)
	)
    (for (from i 1 arg 1)
         (do (dispatch ch)
             % NOTE KLUDGE!  Need to work this out better!
             (setf last_operation new-oper)))
    ))

% Convert from character code to digit.
(de char-digit (c)
  (cond ((digitp c) (difference (char-int c) (char-int (char 0))))))