changeset 57480:db7d00351c33

(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.

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