/[emacs]/emacs/lisp/subr.el
ViewVC logotype

Diff of /emacs/lisp/subr.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.417 by kfstorm, Mon Oct 11 22:02:16 2004 UTC revision 1.418 by monnier, Wed Oct 13 17:05:55 2004 UTC
# Line 367  but optional second arg NODIGITS non-nil Line 367  but optional second arg NODIGITS non-nil
367            (define-key map (char-to-string loop) 'digit-argument)            (define-key map (char-to-string loop) 'digit-argument)
368            (setq loop (1+ loop))))))            (setq loop (1+ loop))))))
369    
 ;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)))  
   
370  (defvar key-substitution-in-progress nil  (defvar key-substitution-in-progress nil
371   "Used internally by substitute-key-definition.")   "Used internally by substitute-key-definition.")
372    
# Line 396  For most uses, it is simpler and safer t Line 387  For most uses, it is simpler and safer t
387    ;; original key, with PREFIX added at the front.    ;; original key, with PREFIX added at the front.
388    (or prefix (setq prefix ""))    (or prefix (setq prefix ""))
389    (let* ((scan (or oldmap keymap))    (let* ((scan (or oldmap keymap))
390           (vec1 (vector nil))           (prefix1 (vconcat prefix [nil]))
          (prefix1 (vconcat prefix vec1))  
391           (key-substitution-in-progress           (key-substitution-in-progress
392            (cons scan key-substitution-in-progress)))            (cons scan key-substitution-in-progress)))
393      ;; Scan OLDMAP, finding each char or event-symbol that      ;; Scan OLDMAP, finding each char or event-symbol that
394      ;; has any definition, and act on it with hack-key.      ;; has any definition, and act on it with hack-key.
395      (while (consp scan)      (map-keymap
396        (if (consp (car scan))       (lambda (char defn)
397            (let ((char (car (car scan)))         (aset prefix1 (length prefix) char)
398                  (defn (cdr (car scan))))         (substitute-key-definition-key defn olddef newdef prefix1 keymap))
399              ;; The inside of this let duplicates exactly       scan)))
400              ;; the inside of the following let that handles array elements.  
401              (aset vec1 0 char)  (defun substitute-key-definition-key (defn olddef newdef prefix keymap)
402              (aset prefix1 (length prefix) char)    (let (inner-def skipped menu-item)
403              (let (inner-def skipped)      ;; Find the actual command name within the binding.
404                ;; Skip past menu-prompt.      (if (eq (car-safe defn) 'menu-item)
405                (while (stringp (car-safe defn))          (setq menu-item defn defn (nth 2 defn))
406                  (setq skipped (cons (car defn) skipped))        ;; Skip past menu-prompt.
407                  (setq defn (cdr defn)))        (while (stringp (car-safe defn))
408                ;; Skip past cached key-equivalence data for menu items.          (push (pop defn) skipped))
409                (and (consp defn) (consp (car defn))        ;; Skip past cached key-equivalence data for menu items.
410                     (setq defn (cdr defn)))        (if (consp (car-safe defn))
411                (setq inner-def defn)            (setq defn (cdr defn))))
412                ;; Look past a symbol that names a keymap.      (if (or (eq defn olddef)
413                (while (and (symbolp inner-def)              ;; Compare with equal if definition is a key sequence.
414                            (fboundp inner-def))              ;; That is useful for operating on function-key-map.
415                  (setq inner-def (symbol-function inner-def)))              (and (or (stringp defn) (vectorp defn))
416                (if (or (eq defn olddef)                   (equal defn olddef)))
417                        ;; Compare with equal if definition is a key sequence.          (define-key keymap prefix
418                        ;; That is useful for operating on function-key-map.            (if menu-item
419                        (and (or (stringp defn) (vectorp defn))                (let ((copy (copy-sequence menu-item)))
420                             (equal defn olddef)))                  (setcar (nthcdr 2 copy) newdef)
421                    (define-key keymap prefix1 (nconc (nreverse skipped) newdef))                  copy)
422                  (if (and (keymapp defn)              (nconc (nreverse skipped) newdef)))
423                           ;; Avoid recursively scanning        ;; Look past a symbol that names a keymap.
424                           ;; where KEYMAP does not have a submap.        (setq inner-def
425                           (let ((elt (lookup-key keymap prefix1)))              (condition-case nil (indirect-function defn) (error defn)))
426                             (or (null elt)        ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
427                                 (keymapp elt)))        ;; avoid autoloading a keymap.  This is mostly done to preserve the
428                           ;; Avoid recursively rescanning keymap being scanned.        ;; original non-autoloading behavior of pre-map-keymap times.
429                           (not (memq inner-def        (if (and (keymapp inner-def)
430                                      key-substitution-in-progress)))                 ;; Avoid recursively scanning
431                      ;; If this one isn't being scanned already,                 ;; where KEYMAP does not have a submap.
432                      ;; scan it now.                 (let ((elt (lookup-key keymap prefix)))
433                      (substitute-key-definition olddef newdef keymap                   (or (null elt) (natnump elt) (keymapp elt)))
434                                                 inner-def                 ;; Avoid recursively rescanning keymap being scanned.
435                                                 prefix1)))))                 (not (memq inner-def key-substitution-in-progress)))
436          (if (vectorp (car scan))            ;; If this one isn't being scanned already, scan it now.
437              (let* ((array (car scan))            (substitute-key-definition olddef newdef keymap inner-def prefix)))))
                    (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)))))  
438    
439  (defun define-key-after (keymap key definition &optional after)  (defun define-key-after (keymap key definition &optional after)
440    "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.    "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
# Line 661  even when EVENT actually has modifiers." Line 580  even when EVENT actually has modifiers."
580              (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@              (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
581                                                 ?\H-\^@ ?\s-\^@ ?\A-\^@)))))                                                 ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
582          (if (not (zerop (logand type ?\M-\^@)))          (if (not (zerop (logand type ?\M-\^@)))
583              (setq list (cons 'meta list)))              (push 'meta list))
584          (if (or (not (zerop (logand type ?\C-\^@)))          (if (or (not (zerop (logand type ?\C-\^@)))
585                  (< char 32))                  (< char 32))
586              (setq list (cons 'control list)))              (push 'control list))
587          (if (or (not (zerop (logand type ?\S-\^@)))          (if (or (not (zerop (logand type ?\S-\^@)))
588                  (/= char (downcase char)))                  (/= char (downcase char)))
589              (setq list (cons 'shift list)))              (push 'shift list))
590          (or (zerop (logand type ?\H-\^@))          (or (zerop (logand type ?\H-\^@))
591              (setq list (cons 'hyper list)))              (push 'hyper list))
592          (or (zerop (logand type ?\s-\^@))          (or (zerop (logand type ?\s-\^@))
593              (setq list (cons 'super list)))              (push 'super list))
594          (or (zerop (logand type ?\A-\^@))          (or (zerop (logand type ?\A-\^@))
595              (setq list (cons 'alt list)))              (push 'alt list))
596          list))))          list))))
597    
598  (defun event-basic-type (event)  (defun event-basic-type (event)
# Line 691  in the current Emacs session, then this Line 610  in the current Emacs session, then this
610    
611  (defsubst mouse-movement-p (object)  (defsubst mouse-movement-p (object)
612    "Return non-nil if OBJECT is a mouse movement event."    "Return non-nil if OBJECT is a mouse movement event."
613    (and (consp object)    (eq (car-safe object) 'mouse-movement))
        (eq (car object) 'mouse-movement)))  
614    
615  (defsubst event-start (event)  (defsubst event-start (event)
616    "Return the starting position of EVENT.    "Return the starting position of EVENT.
# Line 1883  Use a MESSAGE of \"\" to temporarily cle Line 1801  Use a MESSAGE of \"\" to temporarily cle
1801  See also `with-temp-file' and `with-output-to-string'."  See also `with-temp-file' and `with-output-to-string'."
1802    (declare (indent 0) (debug t))    (declare (indent 0) (debug t))
1803    (let ((temp-buffer (make-symbol "temp-buffer")))    (let ((temp-buffer (make-symbol "temp-buffer")))
1804      `(let ((,temp-buffer      `(let ((,temp-buffer (generate-new-buffer " *temp*")))
             (get-buffer-create (generate-new-buffer-name " *temp*"))))  
1805         (unwind-protect         (unwind-protect
1806             (with-current-buffer ,temp-buffer             (with-current-buffer ,temp-buffer
1807               ,@body)               ,@body)

Legend:
Removed from v.1.417  
changed lines
  Added in v.1.418

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26