Artifact aa5db0efa53b34208ebea5b01d71c2a27a19d9d78d510195ed5586173de9c45a:

• File psl-1983/3-1/nmode/dispatch.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: 10108) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/nmode/dispatch.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: 10108) [annotate] [blame] [check-ins using]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% DISPATCH.SL - NMODE Dispatch table utilities
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        24 August 1982
%
% Adapted from Will Galway's EMODE
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects extended-char fast-int fast-vectors))
(fluid '(nmode-current-buffer nmode-minor-modes))

% A command is represented either as a single extended character (i.e., a
% character including Meta and Control bits) or as a list whose first element
% is an extended character (a command prefix character, e.g. C-X or M-X) and
% whose second element is the "argument", either an extended character or a
% string (for M-X).

% The dispatch table maps commands (as defined above) to functions (of no
% arguments).  There is a single command table that defines the "keyboard
% bindings" for the current mode.  Associated with every buffer is a list of
% forms to evaluate which will establish the keyboard bindings for that
% buffer.

% The dispatch table is represented by a 512-element vector
% NMODE-DISPATCH-TABLE which maps extended characters to functions, augmented
% by an association list for each prefix character (e.g., C-X and M-X) that
% maps extended characters to functions.  The prefix character assocation lists
% are themselves stored in an association list that maps from prefix
% characters.  This master association list is bound to the variable
% NMODE-PREFIX-DISPATCH-LIST.

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

% The following are INTERNAL static variables:

(fluid '(nmode-dispatch-table nmode-prefix-dispatch-list))

(if (null nmode-dispatch-table)
  (setf nmode-dispatch-table (MkVect 511)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Dispatch table lookup functions:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de dispatch-table-lookup (command)
  % Return the dispatch table entry for the specified character or character
  % sequence.  NIL is returned for undefined commands.

  (cond
    % Single character:
    ((FixP command)
     (getv nmode-dispatch-table command)
     )

    % Character sequence:
    ((PairP command)
      (let* ((prefix-char (car command))
	     (argument (cadr command))
	     (prefix-entry (lookup-prefix-character prefix-char))
	     )
        (and prefix-entry
	     % Look up the entry for the prefixed character.
	     (let ((char-entry (Atsoc argument prefix-entry)))
	       (and char-entry (cdr char-entry))
	       ))))

    % If we get here, we were given a bad argument
    (t
      (StdError (BldMsg "Bad argument %p for Dispatch-Table-Lookup" command))
      )))

(de lookup-prefix-character (ch)

  % Return the pair (PREFIX-CHAR .  ASSOCIATION-LIST) for the specified prefix
  % character.  This pair may be modified using RPLACD.

  (let ((assoc-entry (atsoc ch nmode-prefix-dispatch-list)))
    (when (null assoc-entry)
      % Create an entry for this prefix character.
      (setf assoc-entry (cons ch NIL))
      (setf nmode-prefix-dispatch-list
	    (cons assoc-entry nmode-prefix-dispatch-list))
      )
    assoc-entry
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Manipulating the dispatch table:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de nmode-make-self-inserting (chr)
  % Define the specified character to be "self inserting".
  (nmode-define-command chr 'insert-self-command))

(de nmode-undefine-command (chr)
  % Remove the command definition of the specified command.
  % If the command is entered, the bell will be rung.
  (nmode-define-command chr NIL))

(de nmode-define-commands (lis)
  (for (in x lis) (do (nmode-define-command (car x) (cdr x)))))

(de nmode-define-normal-self-inserts ()
  (nmode-make-self-inserting (char TAB))
  (for (from i 32 126) (do (nmode-make-self-inserting i))))

(de nmode-define-command (command op)
  % Set up the keyboard dispatch table for a character or a character sequence.
  % If the character is uppercase, define the equivalent lower case character
  % also.

  (cond
    % Single character:
    ((FixP command)
     (vector-store nmode-dispatch-table command op)
     (cond
       ((X-UpperCaseP command)
        (vector-store nmode-dispatch-table (X-Char-DownCase command) op))))

    % Character Sequence:
    ((PairP command)
      (let* ((prefix-char (car command))
	     (argument (cadr command))
	     (prefix-entry (lookup-prefix-character prefix-char))
	     )

        (if (null prefix-entry)
          (StdError (BldMsg "Undefined prefix-character in command %p" command))
	  % else

          % Add the prefixed character to the association list.  Note that in
          % case of duplicate entries the last one added is the one that counts.

          (rplacd prefix-entry
	    (cons (cons argument op) (cdr prefix-entry)))

          % Define the lower case version of the character, if relevent. 
          (cond
            ((and (FixP argument) (X-UpperCaseP argument))
              (rplacd prefix-entry
                (cons (cons (X-Char-DownCase argument) op)
		      (cdr prefix-entry)))
	     )))))

    % If we get here, we were given a bad argument
    (t
      (StdError (BldMsg "Impossible command %p" command))
      )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Mode Establishing
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de nmode-establish-current-mode ()
  (when nmode-current-buffer
    (nmode-clear-dispatch-table)
    (nmode-establish-mode (=> nmode-current-buffer mode))
    (for (in minor-mode nmode-minor-modes)
	 (do (nmode-establish-mode minor-mode)))
    ))

(de nmode-establish-mode (mode)

  % "Establish" the specified MODE: evaluate its "establish expressions" to set
  % up the dispatch table.  Use reverse so things on front of list are
  % evaluated last.  (So that later incremental changes are added later.)

  (for (in x (reverse (=> mode establish-expressions)))
       (do
          (if (pairp x)
            (eval x)
            (StdError (BldMsg "Invalid mode expression: %r" x))
	    ))
       ))

(de nmode-clear-dispatch-table ()
  % Set up a "clear" dispatch table.
  (for (from i 0 511)
       (do (nmode-undefine-command i)))
  (setf nmode-prefix-dispatch-list NIL))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Help for Commands
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de help-dispatch ()

  % Give a little information on the routine bound to a keyboard character (or
  % characters, in the case of prefixed things).

  (nmode-set-delayed-prompt "Show function of command: ")
  (let* ((command (input-command))
	 (func (dispatch-table-lookup command))
	 (prompt (BldMsg "%w    %w" (command-name command)
	    (or func "Undefined")))
	 )
    (write-prompt prompt)
    ))

(de print-all-dispatch ()
  % Print out the current dispatch table.
  (print-matching-dispatch NIL))

(fluid '(function-name-match-string))
(de function-name-matcher (f)
  (string-indexs (id2string f) function-name-match-string))

(de string-indexs (s pattern)

  % Search in the string S for the specified pattern.  If we find it, we return
  % the position of the first matching character.  Otherwise, we return NIL.

  (let* ((pattern-length (string-length pattern))
	 (limit (- (string-length s) pattern-length))
	 )
    (for (from pos 0 limit)
	 (do (if (pattern-in-string pattern s pos)
		 (exit pos)))
	 )
    ))

(de pattern-in-string (pattern s pos)
  % Return T if PATTERN occurs as substring of S, starting at POS.
  % No bounds checking is performed on S.

  (let ((i 0) (patlimit (string-upper-bound pattern)))
    (while (and (<= i patlimit)
		(= (string-fetch pattern i)
		   (string-fetch s (+ i pos)))
		)
      (setf i (+ i 1))
      )
    (> i patlimit) % T if all chars matched, NIL otherwise
    ))

(de print-matching-dispatch (s)
  % Print out the current dispatch table, showing only those function
  % whose names contain the string S (if S is NIL, show all functions).

  (let (f)
    (when s
      (setf function-name-match-string (string-upcase s))
      (setf f #'function-name-matcher)
      )

    % List the routines bound to single characters:
    (for (from ch 0 511)
         (do (print-dispatch-entry ch f)))
    % List the routines bound to prefix characters:
    (for (in prefix-entry nmode-prefix-dispatch-list)
         (do (for (in char-entry (cdr prefix-entry))
	          (do (print-dispatch-entry
		 	(list (car prefix-entry) (car char-entry))
			f
			)
		      ))))
    ))

(de print-dispatch-entry (command f)
  % Print out the dispatch routine for a character or character sequence.
  % Don't print anything if F is non-nill and (F fname) returns NIL, the
  % command is a self inserting character, "undefined", or a lower-case
  % character whose upper-case equivalent has the same definition.

  (let ((fname (dispatch-table-lookup command)))
    (if (not (or (null fname)
		 (memq fname 
		       '(insert-self-command argument-or-insert-command Ding))
		 (and f (null (apply f (list fname))))
		 (is-redundant-command? command)
		 ))
	(PrintF "%w %w%n" (string-pad-right (command-name command) 22) fname)
	)))

(de is-redundant-command? (command)
  (let ((ch (if (FixP command) command (cadr command))))
    (and (FixP ch)
	 (X-LowerCaseP ch)
	 (eq (dispatch-table-lookup command)
	     (dispatch-table-lookup
	       (if (FixP command)
		 (X-Char-UpCase command)
		 (list (car command) (X-Char-Upcase (cadr command)))
		 ))))))

(de command-name (command)
  % Return a string giving the name for a character or character sequence.
  (if (PairP command)
    (string-concat
      (prefix-name (car command))
      (let ((argument (cadr command)))
	(cond ((FixP argument) (x-char-name argument))
	      (t argument)
	      )))
    (x-char-name command)
    ))