# HG changeset patch # User Stefan Monnier # Date 1097687155 0 # Node ID db7d00351c33c3e24fd17601226d5b309a351ff4 # Parent 5f1d886ba4118fa540264b2a45e60c5d49e86c54 (substitute-key-definition-key): New function. (substitute-key-definition): Use it with map-keymap. (event-modifiers): Use push. (mouse-movement-p, with-temp-buffer): Simplify. diff -r 5f1d886ba411 -r db7d00351c33 lisp/subr.el --- a/lisp/subr.el Wed Oct 13 17:04:45 2004 +0000 +++ b/lisp/subr.el Wed Oct 13 17:05:55 2004 +0000 @@ -367,15 +367,6 @@ (define-key map (char-to-string loop) 'digit-argument) (setq loop (1+ loop)))))) -;Moved to keymap.c -;(defun copy-keymap (keymap) -; "Return a copy of KEYMAP" -; (while (not (keymapp keymap)) -; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap)))) -; (if (vectorp keymap) -; (copy-sequence keymap) -; (copy-alist keymap))) - (defvar key-substitution-in-progress nil "Used internally by substitute-key-definition.") @@ -396,126 +387,54 @@ ;; original key, with PREFIX added at the front. (or prefix (setq prefix "")) (let* ((scan (or oldmap keymap)) - (vec1 (vector nil)) - (prefix1 (vconcat prefix vec1)) + (prefix1 (vconcat prefix [nil])) (key-substitution-in-progress (cons scan key-substitution-in-progress))) ;; Scan OLDMAP, finding each char or event-symbol that ;; has any definition, and act on it with hack-key. - (while (consp scan) - (if (consp (car scan)) - (let ((char (car (car scan))) - (defn (cdr (car scan)))) - ;; The inside of this let duplicates exactly - ;; the inside of the following let that handles array elements. - (aset vec1 0 char) - (aset prefix1 (length prefix) char) - (let (inner-def skipped) - ;; Skip past menu-prompt. - (while (stringp (car-safe defn)) - (setq skipped (cons (car defn) skipped)) - (setq defn (cdr defn))) - ;; Skip past cached key-equivalence data for menu items. - (and (consp defn) (consp (car defn)) - (setq defn (cdr defn))) - (setq inner-def defn) - ;; Look past a symbol that names a keymap. - (while (and (symbolp inner-def) - (fboundp inner-def)) - (setq inner-def (symbol-function inner-def))) - (if (or (eq defn olddef) - ;; Compare with equal if definition is a key sequence. - ;; That is useful for operating on function-key-map. - (and (or (stringp defn) (vectorp defn)) - (equal defn olddef))) - (define-key keymap prefix1 (nconc (nreverse skipped) newdef)) - (if (and (keymapp defn) - ;; Avoid recursively scanning - ;; where KEYMAP does not have a submap. - (let ((elt (lookup-key keymap prefix1))) - (or (null elt) - (keymapp elt))) - ;; Avoid recursively rescanning keymap being scanned. - (not (memq inner-def - key-substitution-in-progress))) - ;; If this one isn't being scanned already, - ;; scan it now. - (substitute-key-definition olddef newdef keymap - inner-def - prefix1))))) - (if (vectorp (car scan)) - (let* ((array (car scan)) - (len (length array)) - (i 0)) - (while (< i len) - (let ((char i) (defn (aref array i))) - ;; The inside of this let duplicates exactly - ;; the inside of the previous let. - (aset vec1 0 char) - (aset prefix1 (length prefix) char) - (let (inner-def skipped) - ;; Skip past menu-prompt. - (while (stringp (car-safe defn)) - (setq skipped (cons (car defn) skipped)) - (setq defn (cdr defn))) - (and (consp defn) (consp (car defn)) - (setq defn (cdr defn))) - (setq inner-def defn) - (while (and (symbolp inner-def) - (fboundp inner-def)) - (setq inner-def (symbol-function inner-def))) - (if (or (eq defn olddef) - (and (or (stringp defn) (vectorp defn)) - (equal defn olddef))) - (define-key keymap prefix1 - (nconc (nreverse skipped) newdef)) - (if (and (keymapp defn) - (let ((elt (lookup-key keymap prefix1))) - (or (null elt) - (keymapp elt))) - (not (memq inner-def - key-substitution-in-progress))) - (substitute-key-definition olddef newdef keymap - inner-def - prefix1))))) - (setq i (1+ i)))) - (if (char-table-p (car scan)) - (map-char-table - (function (lambda (char defn) - (let () - ;; The inside of this let duplicates exactly - ;; the inside of the previous let, - ;; except that it uses set-char-table-range - ;; instead of define-key. - (aset vec1 0 char) - (aset prefix1 (length prefix) char) - (let (inner-def skipped) - ;; Skip past menu-prompt. - (while (stringp (car-safe defn)) - (setq skipped (cons (car defn) skipped)) - (setq defn (cdr defn))) - (and (consp defn) (consp (car defn)) - (setq defn (cdr defn))) - (setq inner-def defn) - (while (and (symbolp inner-def) - (fboundp inner-def)) - (setq inner-def (symbol-function inner-def))) - (if (or (eq defn olddef) - (and (or (stringp defn) (vectorp defn)) - (equal defn olddef))) - (define-key keymap prefix1 - (nconc (nreverse skipped) newdef)) - (if (and (keymapp defn) - (let ((elt (lookup-key keymap prefix1))) - (or (null elt) - (keymapp elt))) - (not (memq inner-def - key-substitution-in-progress))) - (substitute-key-definition olddef newdef keymap - inner-def - prefix1))))))) - (car scan))))) - (setq scan (cdr scan))))) + (map-keymap + (lambda (char defn) + (aset prefix1 (length prefix) char) + (substitute-key-definition-key defn olddef newdef prefix1 keymap)) + scan))) + +(defun substitute-key-definition-key (defn olddef newdef prefix keymap) + (let (inner-def skipped menu-item) + ;; Find the actual command name within the binding. + (if (eq (car-safe defn) 'menu-item) + (setq menu-item defn defn (nth 2 defn)) + ;; Skip past menu-prompt. + (while (stringp (car-safe defn)) + (push (pop defn) skipped)) + ;; Skip past cached key-equivalence data for menu items. + (if (consp (car-safe defn)) + (setq defn (cdr defn)))) + (if (or (eq defn olddef) + ;; Compare with equal if definition is a key sequence. + ;; That is useful for operating on function-key-map. + (and (or (stringp defn) (vectorp defn)) + (equal defn olddef))) + (define-key keymap prefix + (if menu-item + (let ((copy (copy-sequence menu-item))) + (setcar (nthcdr 2 copy) newdef) + copy) + (nconc (nreverse skipped) newdef))) + ;; Look past a symbol that names a keymap. + (setq inner-def + (condition-case nil (indirect-function defn) (error defn))) + ;; For nested keymaps, we use `inner-def' rather than `defn' so as to + ;; avoid autoloading a keymap. This is mostly done to preserve the + ;; original non-autoloading behavior of pre-map-keymap times. + (if (and (keymapp inner-def) + ;; Avoid recursively scanning + ;; where KEYMAP does not have a submap. + (let ((elt (lookup-key keymap prefix))) + (or (null elt) (natnump elt) (keymapp elt))) + ;; Avoid recursively rescanning keymap being scanned. + (not (memq inner-def key-substitution-in-progress))) + ;; If this one isn't being scanned already, scan it now. + (substitute-key-definition olddef newdef keymap inner-def prefix))))) (defun define-key-after (keymap key definition &optional after) "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. @@ -661,19 +580,19 @@ (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ ?\H-\^@ ?\s-\^@ ?\A-\^@))))) (if (not (zerop (logand type ?\M-\^@))) - (setq list (cons 'meta list))) + (push 'meta list)) (if (or (not (zerop (logand type ?\C-\^@))) (< char 32)) - (setq list (cons 'control list))) + (push 'control list)) (if (or (not (zerop (logand type ?\S-\^@))) (/= char (downcase char))) - (setq list (cons 'shift list))) + (push 'shift list)) (or (zerop (logand type ?\H-\^@)) - (setq list (cons 'hyper list))) + (push 'hyper list)) (or (zerop (logand type ?\s-\^@)) - (setq list (cons 'super list))) + (push 'super list)) (or (zerop (logand type ?\A-\^@)) - (setq list (cons 'alt list))) + (push 'alt list)) list)))) (defun event-basic-type (event) @@ -691,8 +610,7 @@ (defsubst mouse-movement-p (object) "Return non-nil if OBJECT is a mouse movement event." - (and (consp object) - (eq (car object) 'mouse-movement))) + (eq (car-safe object) 'mouse-movement)) (defsubst event-start (event) "Return the starting position of EVENT. @@ -1883,8 +1801,7 @@ See also `with-temp-file' and `with-output-to-string'." (declare (indent 0) (debug t)) (let ((temp-buffer (make-symbol "temp-buffer"))) - `(let ((,temp-buffer - (get-buffer-create (generate-new-buffer-name " *temp*")))) + `(let ((,temp-buffer (generate-new-buffer " *temp*"))) (unwind-protect (with-current-buffer ,temp-buffer ,@body)