  -*-mode : lisp ; package :  ;  : cl ; -*-

Copyright ( c ) July 1983 by  
  and Massachusetts Institute of Technology .
;Permission to copy all or part of this material is granted, provided
  that the copies are not made or distributed for resale , the MIT
; copyright notice and reference to the source file and the software
; distribution version appear, and that notice is given that copying
  is by permission of Massachusetts Institute of Technology .

;New binding scheme.
There is still one issue to deal with :
  How to store Control - X commands so they may be bound in specific modes ,
; and still be properly inherited from superior modes.
;

;;list of all binding tables, used for invalidating them.
(defvar *all-binding-tables* nil)

;;When non-nil any reference to a binding  table will cause them all to
;;be invalidated.
(defvar invalidate-binding-tables-on-reference nil)

(defflavor binding-table (cache bit-vector bit-vector-valid? alist
                          superior prefix-alist buffer-local?)
  ()
  ;;Cache is a vector referenced by:
  ;; (sgvref cache (coerse-to-9bit-charp char)) => the binding.
Bit - vector is 1 for every self - inserting character . It should
  be changed to LOGAND self - insertion and graphic - charness .
  ;; Its use is for ECHOIN.
  ;;Bit-vector-valid? is used internally.
Alist is used internally . It is the alist of local binding definitions .
  ;; These are cached with the inherited definitions in CACHE.
Superior is the superior binding - table , or NIL .
  ;;Prefix-alist is an alist of Gensym atoms and binding tables.
  A prefix - character binding contains a reference to a  atom ,
  ;; and this is used to get to the binding table in the alist.
  ;; If the binding-table is not found in the alist the superiors are searched.
  ;; If it is found in a superior then that is the superior of the new
  ;; binding-table. Otherwise the new binding-table has no superior.
  ;; This is complicated, but I think the simplest robust scheme for
  ;; extensible and inheritable prefix-character bindings.
  ;; Notice in particular that
  ( editor - bind - key FOO ( internal - editor - lookup - key # \control - x ) )
  ;; will work, and be inheritable. Also the binding of control-x could
  ;; be deleted or changed (even to be a new prefix-character).
  :ordered-instance-variables
  :initable-instance-variables
  )

(defmethod (binding-table :invalidate) ()
  (loop for i from 0 below 256
        do (setf (sgvref cache i) nil)
9bit character set .
        do (setf (bit bit-vector i) 0))
  (setq bit-vector-valid? nil))

(defmethod (binding-table :define-binding) (key binding)
  ;;By binding something to nil you may cause it to be unbound
  ;;even when it is still bound in a superior binding table.
  ;;Note that in all cases it is less efficieint to lookup an
  ;;unbound key than a bound one.
  (setq invalidate-binding-tables-on-reference t)
  ;;Shadow superior binding definitions.
  (cond ((assq key alist) (setf (cadr (assq key alist)) binding))
        (t (push (list key binding) alist))))

(defmethod (binding-table :undefine-binding) (key)
  (setq invalidate-binding-tables-on-reference t)
  (delq (assq key alist) alist))

(defmethod (binding-table :lookup-primitive) (key)
  (or (assq key alist)
      (and (not (null superior))
           (send superior :lookup-primitive key))))

(defmacro check-binding-validity ()
  '(when invalidate-binding-tables-on-reference
     (invalidate-all-binding-tables)))

(defun invalidate-all-binding-tables ()
  (loop for table in *all-binding-tables*
        do (send table :invalidate))
  (setq invalidate-binding-tables-on-reference nil))

(defun coerse-to-9bit-charp (character)
Return an integer < 512 to represent the character .
  (unless (and (<& (char-code character) 128)
               (<& (char-bits character) 4)
               (0p (char-font character)))
    (ed-lose "Invalid character for keybinding ~a" character))
  (+& (char-code character) (*& (char-bits character) 128)))

(defmethod (binding-table :lookup) (key)
  (unless (characterp key)
    (ed-lose "Key not character ~a" key))
  (check-binding-validity)
  (let ((s-key (coerse-to-9bit-charp key)))
    (or (sgvref cache s-key)
        (let ((binding (send self :lookup-primitive key)))
          (if (not (null binding))
              (progn (setf (sgvref cache s-key) (cadr binding))
                     (cadr binding)))))))

(defmethod (binding-table :get-echoin-bit-vector) ()
  (unless bit-vector-valid?
    (send self :calculate-bit-vector))
  bit-vector)

(defmethod (binding-table :calculate-bit-vector) ()
  (loop for i from 0 below 256
        for char = (int-char i)
        do (setf (bit bit-vector i)
                 (if (and (graphic-charp char)
                          (not (of-syntax char paren-close))
                          (eq (or (send self :lookup char)
                                  (send self :lookup (char-upcase char)))
                              'self-insert))
                     1 0)))
  (setq bit-vector-valid? t))

(defun make-binding-table (&optional (superior nil))
  (let ((table (make-instance 'binding-table
                              :cache (make-vector 512 :initial-element nil)
                              :bit-vector (make-bits 256)
                              :alist nil
                              :superior superior
                              :bit-vector-valid? nil
                              :prefix-alist nil
                              :buffer-local? nil)))
    (push table *all-binding-tables*)
    table))

Two compatibility functions .
(defun make-empty-key-binding-table ()
  (make-binding-table))

(defun derive-bindings (superior-bindings)
  (make-binding-table superior-bindings))

;
;Key binding.
;

(defmethod (binding-table :get-prefix-table) (char)
  ;;This use of :lookup-primitive is slower at run time, but
  ;;using :lookup would force every prefix-character sub-command binding
  ;;to invalidate all of the binding-tables. This would be very very
  ;;slow. linking the editor would be painfull.
  ;;There could be a message for :get-prefix-table-for-binding
  ;;or a flag argument. It probably is not worth the trouble either way though,
  ;;since control-x commands are several orders of magnitude less important
  ;;than self-insert. In fact it is guaranteed that terminal i/o will be
  ;;done immediately after this lookup (to get the subcommand dispatch char)
  ;;so we have all the time in the world to find the table.
  (let ((binding (cadr (send self :lookup-primitive char))))
    (and (consp binding)
         (eq (car binding) 'prefix-character)
         (or ;;Table already there?
             (cadr (assq (caddr binding) prefix-alist))
             ;;Find it and inherit from intermeditate superiors.
             (send self :get-prefix-table-primitive (caddr binding))
             (let ((new (make-binding-table)))
               (push (list (caddr binding) new) prefix-alist)
               new)))))

(defmethod (binding-table :get-prefix-table-primitive) (tag &aux table)
  (cond ((cadr (assq tag prefix-alist)))
        ((null superior) nil)
        ((setq table (send superior :get-prefix-table-primitive tag))
         (setq table (make-binding-table table))
         (push (list tag table) prefix-alist)
         table)
        (t nil)))

;Why clutter up the m-X namespace with all these???

(defun internal-bindery (key-seq binding &optional (mode nil))
; (when (symbolp binding)
;   (defcommand (string binding) meta-x-command-table binding))
  (%internal-bindery key-seq binding
                     (if (null mode)
                         *editor-bindings*
                         (mode-keys (lookup-mode mode)))))

(defun %internal-bindery (key-seq binding table)
  (cond ((consp key-seq)
         (let ((x-table (send table :get-prefix-table (car key-seq))))
           (when (null x-table)
             (ed-lose "Bad prefix character: ~a" key-seq))
           (send x-table :define-binding (cadr key-seq) binding)))
        (t (send table :define-binding key-seq binding)))
  binding)

(defun lookup-key-in-superior-tables (key table)
  (send table :lookup key))

(defun %internal-lookup (key-seq table)
  (if (consp key-seq)
      (let ((x-table (send table :get-prefix-table (car key-seq))))
        (when (null x-table)
          (ed-lose "Bad prefix-character in ~a" key-seq))
        (lookup-key-in-table (cadr key-seq) x-table))
      (lookup-key-in-table key-seq table)))

(defun internal-editor-lookup-key (key-seq)
  (if (consp key-seq)
      (let ((x-table (send *editor-bindings* :get-prefix-table (car key-seq))))
        (when (null x-table)
          (ed-lose "Bad prefix-character in ~a" key-seq))
        (lookup-key-in-table (cadr key-seq) x-table))
      (lookup-key-in-table key-seq *editor-bindings*)))

;The prefix-character scheme is rather complex.
  It includes many levels of indirection to implement two principle features .
  ( 1 ) The binding definition of a prefix - character can be bound to any
;     other key and it will be the same prefix-character (using the same
;     subtable.) With some restriction this can be done even if the new
;     binding is done in a different mode. (The restriction is a scoping
;     restriction. The new binding must be in the original binding-table, or
;     one of its inferiors.) With this restriction it is unambiguous how
;     the subtable should inherit: it always inherits from some superior,
;     just as the original binding-table would.
  ( 2 ) Redefinining the binding of a two character command is always
;     scoped right. An inferior mode definition will shadow a superior
;     definition and a superior definition will be inherited by an inferior
;     binding-table unless it is shadowed. Again this is exactly the behavior
;     of single character binding definitions.
;
;Implementation.
        The binding definition of a prefix character includes a  atom .
;       This identifies the original sub-table for that prefix-character.
;       Using this as a tag the sub-table is found by searching the
;       current binding-table and its superiors. The instance-variable
;       prefix-alist is used to store the sub-table. If the prefix-table
;       is found in a superior binding-table, then a new sub-table is
;       generated and added to the prefix-alist of the current binding-table.
        The newly generated sub - table will have the original one as its
;       ultimate superior, so inheritance and shadowing can occur.
;
;      Binding a sub-command is done by finding or creating the correct
;       sub-table (as described above) and then binding the secondary
;       dispatch character in the sub-table.
;
;      Lookup is done by finding or creating the correct sub-table and
;       looking up the secondary dispatch character in the sub-table.
;

(defun define-prefix-char (char &optional (prompt-string ""))
  (internal-bindery char `(prefix-character
                           ,prompt-string
                           ,(gensym))))

(defun prefix-character (command-char echo-string tag)
 (let ((char)
       (x-table (send *editor-bindings* :get-prefix-table command-char)))
  (or (null *display-prefixes*)
      (type-ahead-p)
      (null echo-string)
      (with-prefix-echo-line
       (send terminal-io :oustr echo-string 0 (string-length echo-string))
       (peek-char&save terminal-io)))
  (setq char (canonicalize-control-characters (read-char&save terminal-io)))
  (values (list command-char char)
          (or (send x-table :lookup char)
              (send x-table :lookup (char-upcase char))))))


;
;Local binding
;


(defmethod (binding-table :buffer-local?) (&optional (value buffer-local?))
  (setq buffer-local? value)
  buffer-local?)

(defun bind-key-in-buffer (buffer key-seq binding)
  (let ((binds (buffer-key-bindings buffer)))
    (when (not (send binds :buffer-local?))
      (setq binds (make-binding-table binds))
      (send binds :buffer-local? t)
      (bind-in-buffer buffer '*binding-table* binds))
    (%internal-bindery key-seq binding binds))
  t)

(defun buffer-local-value (buffer variable)
  (let ((env (buffer-environment buffer)))
    (if (null env)
        (values nil nil)
        (loop for var in (load-environment-binding-vars env)
              for val in (load-environment-new-values env)
              if (eq var variable) return (values val t)
              finally (return (values nil nil))))))

(defun buffer-default-major-mode (buffer)
  (let ((temp (buffer-file-name buffer)))
    (or (and temp
             (setq temp (send temp :type))
             (default-major-mode temp))
        "Fundamental")))

(defun buffer-key-bindings (buffer)
  (or (buffer-local-value buffer '*editor-bindings*)
      (mode-keys (lookup-mode (buffer-default-major-mode buffer)))))

Kludging key bindings .

(defmacro with-key-binding (key binding &body forms)
  (let ((table (gensym))
        (old-binding (gensym)))
    `(let ((,table *editor-bindings*))
       (let ((,old-binding (%internal-lookup ,key ,table)))
         (unwind-protect
          (progn (%internal-bindery ,key ,binding ,table)
                 ,@forms)
          (%internal-bindery ,key ,old-binding ,table))))))

(defmacro with-many-key-bindings (alist &body forms)
  (let ((old-bindings (gensym))
        (table (gensym))
        (x (gensym))
        (y (gensym))
        (v-alist (gensym)))
    `(let ((,table *editor-bindings*)
           (,v-alist ,alist))
       (when (not (listp (car ,v-alist)))
         (setq ,table (car ,v-alist))
         (setq ,v-alist (cdr ,v-alist)))
       (let ((,old-bindings
              (mapcar #'(lambda (,x) (%internal-lookup (car ,x) ,table))
                      ,v-alist)))
         (unwind-protect
          (progn (mapc #'(lambda (,x)
                           (%internal-bindery (car ,x) (cadr ,x) ,table))
                       ,v-alist)
                 ,@forms)
          (mapc #'(lambda (,x ,y)
                    (%internal-bindery (car ,x) ,y ,table))
                ,v-alist ,old-bindings))))))

(defmacro with-many-key-bindings-named ((var alist) &body forms)
  ;;This form is very powerfull. It binds several keys temporarilly,
  ;;inside an unwind-protect so they are certain to be rebound on exit.
However , the VARIABLE given as the first parameter is used to store
  ;;the old key-bindings. They could be changed this way, but this is not
  ;;reccommended and is considered to be incorrect. It can be used as
  ;;an argument to this form so one may temorarrily revert to the old
  ;;bindings. It has been hacked so it also stores the binding-table to
  ;;use there.
  (let ((old-bindings var)
        (table (gensym))
        (x (gensym))
        (v-alist (gensym)))
    `(let ((,table *editor-bindings*)
           (,v-alist ,alist))
       (when (not (listp (car ,v-alist)))
         (setq ,table (car ,v-alist))
         (setq ,v-alist (cdr ,v-alist)))
       (let ((,old-bindings
              (cons ,table
                    (mapcar #'(lambda (,x) (list (car ,x)
                                                 (%internal-lookup
                                                  (car ,x) ,table)))
                            ,v-alist))))
         (unwind-protect
          (progn (mapc #'(lambda (,x)
                           (%internal-bindery (car ,x) (cadr ,x) ,table))
                       ,v-alist)
                 ,@forms)
          (mapc #'(lambda (,x)
                    (%internal-bindery (car ,x) (cadr ,x) ,table))
                (cdr ,old-bindings)))))))



;
;NEW binding functions.
;These are now the correct way to do these things.
;They provide for proper separation between editor names and lisp names
;and also require documentation strings. (I am facist, I don't make
;documentation optional...But I know the sub-primitives to avoid this, ha ha.)
;

;(define-binding key-seq binding mode-list documentation args)

;(define-extended name binding documentation args)

(defvar function-documentation nil)

(defun %define-extended (name binding documentation args)
  (defcommand (string name) meta-x-command-table binding)
  (setq function-documentation
        (nconc function-documentation
               (delq (assq (intern name 'steve) function-documentation)
                     function-documentation)
               (list (list* binding documentation args))))
  name)

(defun %define-binding (key-seq binding m-x-name modes documentation args)
  (mapc #'(lambda (mode)
            (%internal-bindery key-seq binding
                               (mode-keys (lookup-mode mode))))
        modes)
  (when m-x-name
    (%define-extended m-x-name binding documentation args))
  (or m-x-name binding key-seq))

;User level suger.

(defmacro define-extended (name binding documentation &rest doc-args)
  `(%define-extended name ',binding documentation ',doc-args))

(defmacro define-binding (key-seq binding m-x-name modes documentation
                                  &rest args)
  `(%define-binding ,key-seq ',binding ,m-x-name
                    ,(if modes
                         (list 'quote modes)
                         '("Fundamental"))
                    ',documentation ',args))

 package :  ;  : cl ; -*-
Permission to copy all or part of this material is granted, provided
 copyright notice and reference to the source file and the software
 distribution version appear, and that notice is given that copying
New binding scheme.
 and still be properly inherited from superior modes.

list of all binding tables, used for invalidating them.
When non-nil any reference to a binding  table will cause them all to
be invalidated.
Cache is a vector referenced by:
 (sgvref cache (coerse-to-9bit-charp char)) => the binding.
 Its use is for ECHOIN.
Bit-vector-valid? is used internally.
 These are cached with the inherited definitions in CACHE.
Prefix-alist is an alist of Gensym atoms and binding tables.
 and this is used to get to the binding table in the alist.
 If the binding-table is not found in the alist the superiors are searched.
 If it is found in a superior then that is the superior of the new
 binding-table. Otherwise the new binding-table has no superior.
 This is complicated, but I think the simplest robust scheme for
 extensible and inheritable prefix-character bindings.
 Notice in particular that
 will work, and be inheritable. Also the binding of control-x could
 be deleted or changed (even to be a new prefix-character).
By binding something to nil you may cause it to be unbound
even when it is still bound in a superior binding table.
Note that in all cases it is less efficieint to lookup an
unbound key than a bound one.
Shadow superior binding definitions.

Key binding.

This use of :lookup-primitive is slower at run time, but
using :lookup would force every prefix-character sub-command binding
to invalidate all of the binding-tables. This would be very very
slow. linking the editor would be painfull.
There could be a message for :get-prefix-table-for-binding
or a flag argument. It probably is not worth the trouble either way though,
since control-x commands are several orders of magnitude less important
than self-insert. In fact it is guaranteed that terminal i/o will be
done immediately after this lookup (to get the subcommand dispatch char)
so we have all the time in the world to find the table.
Table already there?
Find it and inherit from intermeditate superiors.
Why clutter up the m-X namespace with all these???
 (when (symbolp binding)
   (defcommand (string binding) meta-x-command-table binding))
The prefix-character scheme is rather complex.
     other key and it will be the same prefix-character (using the same
     subtable.) With some restriction this can be done even if the new
     binding is done in a different mode. (The restriction is a scoping
     restriction. The new binding must be in the original binding-table, or
     one of its inferiors.) With this restriction it is unambiguous how
     the subtable should inherit: it always inherits from some superior,
     just as the original binding-table would.
     scoped right. An inferior mode definition will shadow a superior
     definition and a superior definition will be inherited by an inferior
     binding-table unless it is shadowed. Again this is exactly the behavior
     of single character binding definitions.

Implementation.
       This identifies the original sub-table for that prefix-character.
       Using this as a tag the sub-table is found by searching the
       current binding-table and its superiors. The instance-variable
       prefix-alist is used to store the sub-table. If the prefix-table
       is found in a superior binding-table, then a new sub-table is
       generated and added to the prefix-alist of the current binding-table.
       ultimate superior, so inheritance and shadowing can occur.

      Binding a sub-command is done by finding or creating the correct
       sub-table (as described above) and then binding the secondary
       dispatch character in the sub-table.

      Lookup is done by finding or creating the correct sub-table and
       looking up the secondary dispatch character in the sub-table.


Local binding

This form is very powerfull. It binds several keys temporarilly,
inside an unwind-protect so they are certain to be rebound on exit.
the old key-bindings. They could be changed this way, but this is not
reccommended and is considered to be incorrect. It can be used as
an argument to this form so one may temorarrily revert to the old
bindings. It has been hacked so it also stores the binding-table to
use there.

NEW binding functions.
These are now the correct way to do these things.
They provide for proper separation between editor names and lisp names
and also require documentation strings. (I am facist, I don't make
documentation optional...But I know the sub-primitives to avoid this, ha ha.)

(define-binding key-seq binding mode-list documentation args)
(define-extended name binding documentation args)
User level suger.

Copyright ( c ) July 1983 by  
  and Massachusetts Institute of Technology .
  that the copies are not made or distributed for resale , the MIT
  is by permission of Massachusetts Institute of Technology .

There is still one issue to deal with :
  How to store Control - X commands so they may be bound in specific modes ,

(defvar *all-binding-tables* nil)

(defvar invalidate-binding-tables-on-reference nil)

(defflavor binding-table (cache bit-vector bit-vector-valid? alist
                          superior prefix-alist buffer-local?)
  ()
Bit - vector is 1 for every self - inserting character . It should
  be changed to LOGAND self - insertion and graphic - charness .
Alist is used internally . It is the alist of local binding definitions .
Superior is the superior binding - table , or NIL .
  A prefix - character binding contains a reference to a  atom ,
  ( editor - bind - key FOO ( internal - editor - lookup - key # \control - x ) )
  :ordered-instance-variables
  :initable-instance-variables
  )

(defmethod (binding-table :invalidate) ()
  (loop for i from 0 below 256
        do (setf (sgvref cache i) nil)
9bit character set .
        do (setf (bit bit-vector i) 0))
  (setq bit-vector-valid? nil))

(defmethod (binding-table :define-binding) (key binding)
  (setq invalidate-binding-tables-on-reference t)
  (cond ((assq key alist) (setf (cadr (assq key alist)) binding))
        (t (push (list key binding) alist))))

(defmethod (binding-table :undefine-binding) (key)
  (setq invalidate-binding-tables-on-reference t)
  (delq (assq key alist) alist))

(defmethod (binding-table :lookup-primitive) (key)
  (or (assq key alist)
      (and (not (null superior))
           (send superior :lookup-primitive key))))

(defmacro check-binding-validity ()
  '(when invalidate-binding-tables-on-reference
     (invalidate-all-binding-tables)))

(defun invalidate-all-binding-tables ()
  (loop for table in *all-binding-tables*
        do (send table :invalidate))
  (setq invalidate-binding-tables-on-reference nil))

(defun coerse-to-9bit-charp (character)
Return an integer < 512 to represent the character .
  (unless (and (<& (char-code character) 128)
               (<& (char-bits character) 4)
               (0p (char-font character)))
    (ed-lose "Invalid character for keybinding ~a" character))
  (+& (char-code character) (*& (char-bits character) 128)))

(defmethod (binding-table :lookup) (key)
  (unless (characterp key)
    (ed-lose "Key not character ~a" key))
  (check-binding-validity)
  (let ((s-key (coerse-to-9bit-charp key)))
    (or (sgvref cache s-key)
        (let ((binding (send self :lookup-primitive key)))
          (if (not (null binding))
              (progn (setf (sgvref cache s-key) (cadr binding))
                     (cadr binding)))))))

(defmethod (binding-table :get-echoin-bit-vector) ()
  (unless bit-vector-valid?
    (send self :calculate-bit-vector))
  bit-vector)

(defmethod (binding-table :calculate-bit-vector) ()
  (loop for i from 0 below 256
        for char = (int-char i)
        do (setf (bit bit-vector i)
                 (if (and (graphic-charp char)
                          (not (of-syntax char paren-close))
                          (eq (or (send self :lookup char)
                                  (send self :lookup (char-upcase char)))
                              'self-insert))
                     1 0)))
  (setq bit-vector-valid? t))

(defun make-binding-table (&optional (superior nil))
  (let ((table (make-instance 'binding-table
                              :cache (make-vector 512 :initial-element nil)
                              :bit-vector (make-bits 256)
                              :alist nil
                              :superior superior
                              :bit-vector-valid? nil
                              :prefix-alist nil
                              :buffer-local? nil)))
    (push table *all-binding-tables*)
    table))

Two compatibility functions .
(defun make-empty-key-binding-table ()
  (make-binding-table))

(defun derive-bindings (superior-bindings)
  (make-binding-table superior-bindings))


(defmethod (binding-table :get-prefix-table) (char)
  (let ((binding (cadr (send self :lookup-primitive char))))
    (and (consp binding)
         (eq (car binding) 'prefix-character)
             (cadr (assq (caddr binding) prefix-alist))
             (send self :get-prefix-table-primitive (caddr binding))
             (let ((new (make-binding-table)))
               (push (list (caddr binding) new) prefix-alist)
               new)))))

(defmethod (binding-table :get-prefix-table-primitive) (tag &aux table)
  (cond ((cadr (assq tag prefix-alist)))
        ((null superior) nil)
        ((setq table (send superior :get-prefix-table-primitive tag))
         (setq table (make-binding-table table))
         (push (list tag table) prefix-alist)
         table)
        (t nil)))


(defun internal-bindery (key-seq binding &optional (mode nil))
  (%internal-bindery key-seq binding
                     (if (null mode)
                         *editor-bindings*
                         (mode-keys (lookup-mode mode)))))

(defun %internal-bindery (key-seq binding table)
  (cond ((consp key-seq)
         (let ((x-table (send table :get-prefix-table (car key-seq))))
           (when (null x-table)
             (ed-lose "Bad prefix character: ~a" key-seq))
           (send x-table :define-binding (cadr key-seq) binding)))
        (t (send table :define-binding key-seq binding)))
  binding)

(defun lookup-key-in-superior-tables (key table)
  (send table :lookup key))

(defun %internal-lookup (key-seq table)
  (if (consp key-seq)
      (let ((x-table (send table :get-prefix-table (car key-seq))))
        (when (null x-table)
          (ed-lose "Bad prefix-character in ~a" key-seq))
        (lookup-key-in-table (cadr key-seq) x-table))
      (lookup-key-in-table key-seq table)))

(defun internal-editor-lookup-key (key-seq)
  (if (consp key-seq)
      (let ((x-table (send *editor-bindings* :get-prefix-table (car key-seq))))
        (when (null x-table)
          (ed-lose "Bad prefix-character in ~a" key-seq))
        (lookup-key-in-table (cadr key-seq) x-table))
      (lookup-key-in-table key-seq *editor-bindings*)))

  It includes many levels of indirection to implement two principle features .
  ( 1 ) The binding definition of a prefix - character can be bound to any
  ( 2 ) Redefinining the binding of a two character command is always
        The binding definition of a prefix character includes a  atom .
        The newly generated sub - table will have the original one as its

(defun define-prefix-char (char &optional (prompt-string ""))
  (internal-bindery char `(prefix-character
                           ,prompt-string
                           ,(gensym))))

(defun prefix-character (command-char echo-string tag)
 (let ((char)
       (x-table (send *editor-bindings* :get-prefix-table command-char)))
  (or (null *display-prefixes*)
      (type-ahead-p)
      (null echo-string)
      (with-prefix-echo-line
       (send terminal-io :oustr echo-string 0 (string-length echo-string))
       (peek-char&save terminal-io)))
  (setq char (canonicalize-control-characters (read-char&save terminal-io)))
  (values (list command-char char)
          (or (send x-table :lookup char)
              (send x-table :lookup (char-upcase char))))))




(defmethod (binding-table :buffer-local?) (&optional (value buffer-local?))
  (setq buffer-local? value)
  buffer-local?)

(defun bind-key-in-buffer (buffer key-seq binding)
  (let ((binds (buffer-key-bindings buffer)))
    (when (not (send binds :buffer-local?))
      (setq binds (make-binding-table binds))
      (send binds :buffer-local? t)
      (bind-in-buffer buffer '*binding-table* binds))
    (%internal-bindery key-seq binding binds))
  t)

(defun buffer-local-value (buffer variable)
  (let ((env (buffer-environment buffer)))
    (if (null env)
        (values nil nil)
        (loop for var in (load-environment-binding-vars env)
              for val in (load-environment-new-values env)
              if (eq var variable) return (values val t)
              finally (return (values nil nil))))))

(defun buffer-default-major-mode (buffer)
  (let ((temp (buffer-file-name buffer)))
    (or (and temp
             (setq temp (send temp :type))
             (default-major-mode temp))
        "Fundamental")))

(defun buffer-key-bindings (buffer)
  (or (buffer-local-value buffer '*editor-bindings*)
      (mode-keys (lookup-mode (buffer-default-major-mode buffer)))))

Kludging key bindings .

(defmacro with-key-binding (key binding &body forms)
  (let ((table (gensym))
        (old-binding (gensym)))
    `(let ((,table *editor-bindings*))
       (let ((,old-binding (%internal-lookup ,key ,table)))
         (unwind-protect
          (progn (%internal-bindery ,key ,binding ,table)
                 ,@forms)
          (%internal-bindery ,key ,old-binding ,table))))))

(defmacro with-many-key-bindings (alist &body forms)
  (let ((old-bindings (gensym))
        (table (gensym))
        (x (gensym))
        (y (gensym))
        (v-alist (gensym)))
    `(let ((,table *editor-bindings*)
           (,v-alist ,alist))
       (when (not (listp (car ,v-alist)))
         (setq ,table (car ,v-alist))
         (setq ,v-alist (cdr ,v-alist)))
       (let ((,old-bindings
              (mapcar #'(lambda (,x) (%internal-lookup (car ,x) ,table))
                      ,v-alist)))
         (unwind-protect
          (progn (mapc #'(lambda (,x)
                           (%internal-bindery (car ,x) (cadr ,x) ,table))
                       ,v-alist)
                 ,@forms)
          (mapc #'(lambda (,x ,y)
                    (%internal-bindery (car ,x) ,y ,table))
                ,v-alist ,old-bindings))))))

(defmacro with-many-key-bindings-named ((var alist) &body forms)
However , the VARIABLE given as the first parameter is used to store
  (let ((old-bindings var)
        (table (gensym))
        (x (gensym))
        (v-alist (gensym)))
    `(let ((,table *editor-bindings*)
           (,v-alist ,alist))
       (when (not (listp (car ,v-alist)))
         (setq ,table (car ,v-alist))
         (setq ,v-alist (cdr ,v-alist)))
       (let ((,old-bindings
              (cons ,table
                    (mapcar #'(lambda (,x) (list (car ,x)
                                                 (%internal-lookup
                                                  (car ,x) ,table)))
                            ,v-alist))))
         (unwind-protect
          (progn (mapc #'(lambda (,x)
                           (%internal-bindery (car ,x) (cadr ,x) ,table))
                       ,v-alist)
                 ,@forms)
          (mapc #'(lambda (,x)
                    (%internal-bindery (car ,x) (cadr ,x) ,table))
                (cdr ,old-bindings)))))))






(defvar function-documentation nil)

(defun %define-extended (name binding documentation args)
  (defcommand (string name) meta-x-command-table binding)
  (setq function-documentation
        (nconc function-documentation
               (delq (assq (intern name 'steve) function-documentation)
                     function-documentation)
               (list (list* binding documentation args))))
  name)

(defun %define-binding (key-seq binding m-x-name modes documentation args)
  (mapc #'(lambda (mode)
            (%internal-bindery key-seq binding
                               (mode-keys (lookup-mode mode))))
        modes)
  (when m-x-name
    (%define-extended m-x-name binding documentation args))
  (or m-x-name binding key-seq))


(defmacro define-extended (name binding documentation &rest doc-args)
  `(%define-extended name ',binding documentation ',doc-args))

(defmacro define-binding (key-seq binding m-x-name modes documentation
                                  &rest args)
  `(%define-binding ,key-seq ',binding ,m-x-name
                    ,(if modes
                         (list 'quote modes)
                         '("Fundamental"))
                    ',documentation ',args))
