/[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.360.2.11 by miles, Sat Sep 25 12:05:25 2004 UTC revision 1.360.2.12 by miles, Thu Oct 14 08:49:59 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 383  but optional second arg NODIGITS non-nil Line 374  but optional second arg NODIGITS non-nil
374    "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.    "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
375  In other words, OLDDEF is replaced with NEWDEF where ever it appears.  In other words, OLDDEF is replaced with NEWDEF where ever it appears.
376  Alternatively, if optional fourth argument OLDMAP is specified, we redefine  Alternatively, if optional fourth argument OLDMAP is specified, we redefine
377  in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."  in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
378    
379    For most uses, it is simpler and safer to use command remappping like this:
380      \(define-key KEYMAP [remap OLDDEF] NEWDEF)"
381    ;; Don't document PREFIX in the doc string because we don't want to    ;; Don't document PREFIX in the doc string because we don't want to
382    ;; advertise it.  It's meant for recursive calls only.  Here's its    ;; advertise it.  It's meant for recursive calls only.  Here's its
383    ;; meaning    ;; meaning
# Line 393  in KEYMAP as NEWDEF those keys which are Line 387  in KEYMAP as NEWDEF those keys which are
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 658  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 688  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 1880  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)
# Line 2652  The properties used on SYMBOL are `compo Line 2572  The properties used on SYMBOL are `compo
2572    (put symbol 'abortfunc (or abortfunc 'kill-buffer))    (put symbol 'abortfunc (or abortfunc 'kill-buffer))
2573    (put symbol 'hookvar (or hookvar 'mail-send-hook)))    (put symbol 'hookvar (or hookvar 'mail-send-hook)))
2574    
2575    ;; Standardized progress reporting
2576    
2577    ;; Progress reporter has the following structure:
2578    ;;
2579    ;;      (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME
2580    ;;                            MIN-VALUE
2581    ;;                            MAX-VALUE
2582    ;;                            MESSAGE
2583    ;;                            MIN-CHANGE
2584    ;;                            MIN-TIME])
2585    ;;
2586    ;; This weirdeness is for optimization reasons: we want
2587    ;; `progress-reporter-update' to be as fast as possible, so
2588    ;; `(car reporter)' is better than `(aref reporter 0)'.
2589    ;;
2590    ;; NEXT-UPDATE-TIME is a float.  While `float-time' loses a couple
2591    ;; digits of precision, it doesn't really matter here.  On the other
2592    ;; hand, it greatly simplifies the code.
2593    
2594    (defsubst progress-reporter-update (reporter value)
2595      "Report progress of an operation in the echo area.
2596    However, if the change since last echo area update is too small
2597    or not enough time has passed, then do nothing (see
2598    `make-progress-reporter' for details).
2599    
2600    First parameter, REPORTER, should be the result of a call to
2601    `make-progress-reporter'.  Second, VALUE, determines the actual
2602    progress of operation; it must be between MIN-VALUE and MAX-VALUE
2603    as passed to `make-progress-reporter'.
2604    
2605    This function is very inexpensive, you may not bother how often
2606    you call it."
2607      (when (>= value (car reporter))
2608        (progress-reporter-do-update reporter value)))
2609    
2610    (defun make-progress-reporter (message min-value max-value
2611                                           &optional current-value
2612                                           min-change min-time)
2613      "Return progress reporter object usage with `progress-reporter-update'.
2614    
2615    MESSAGE is shown in the echo area.  When at least 1% of operation
2616    is complete, the exact percentage will be appended to the
2617    MESSAGE.  When you call `progress-reporter-done', word \"done\"
2618    is printed after the MESSAGE.  You can change MESSAGE of an
2619    existing progress reporter with `progress-reporter-force-update'.
2620    
2621    MIN-VALUE and MAX-VALUE designate starting (0% complete) and
2622    final (100% complete) states of operation.  The latter should be
2623    larger; if this is not the case, then simply negate all values.
2624    Optional CURRENT-VALUE specifies the progress by the moment you
2625    call this function.  You should omit it or set it to nil in most
2626    cases since it defaults to MIN-VALUE.
2627    
2628    Optional MIN-CHANGE determines the minimal change in percents to
2629    report (default is 1%.)  Optional MIN-TIME specifies the minimal
2630    time before echo area updates (default is 0.2 seconds.)  If
2631    `float-time' function is not present, then time is not tracked
2632    at all.  If OS is not capable of measuring fractions of seconds,
2633    then this parameter is effectively rounded up."
2634    
2635      (unless min-time
2636        (setq min-time 0.2))
2637      (let ((reporter
2638             (cons min-value ;; Force a call to `message' now
2639                   (vector (if (and (fboundp 'float-time)
2640                                    (>= min-time 0.02))
2641                               (float-time) nil)
2642                           min-value
2643                           max-value
2644                           message
2645                           (if min-change (max (min min-change 50) 1) 1)
2646                           min-time))))
2647        (progress-reporter-update reporter (or current-value min-value))
2648        reporter))
2649    
2650    (defun progress-reporter-force-update (reporter value &optional new-message)
2651      "Report progress of an operation in the echo area unconditionally.
2652    
2653    First two parameters are the same as for
2654    `progress-reporter-update'.  Optional NEW-MESSAGE allows you to
2655    change the displayed message."
2656      (let ((parameters (cdr reporter)))
2657        (when new-message
2658          (aset parameters 3 new-message))
2659        (when (aref parameters 0)
2660          (aset parameters 0 (float-time)))
2661        (progress-reporter-do-update reporter value)))
2662    
2663    (defun progress-reporter-do-update (reporter value)
2664      (let* ((parameters   (cdr reporter))
2665             (min-value    (aref parameters 1))
2666             (max-value    (aref parameters 2))
2667             (one-percent  (/ (- max-value min-value) 100.0))
2668             (percentage   (truncate (/ (- value min-value) one-percent)))
2669             (update-time  (aref parameters 0))
2670             (current-time (float-time))
2671             (enough-time-passed
2672              ;; See if enough time has passed since the last update.
2673              (or (not update-time)
2674                  (when (>= current-time update-time)
2675                    ;; Calculate time for the next update
2676                    (aset parameters 0 (+ update-time (aref parameters 5)))))))
2677        ;;
2678        ;; Calculate NEXT-UPDATE-VALUE.  If we are not going to print
2679        ;; message this time because not enough time has passed, then use
2680        ;; 1 instead of MIN-CHANGE.  This makes delays between echo area
2681        ;; updates closer to MIN-TIME.
2682        (setcar reporter
2683                (min (+ min-value (* (+ percentage
2684                                        (if enough-time-passed
2685                                            (aref parameters 4) ;; MIN-CHANGE
2686                                          1))
2687                                     one-percent))
2688                     max-value))
2689        (when (integerp value)
2690          (setcar reporter (ceiling (car reporter))))
2691        ;;
2692        ;; Only print message if enough time has passed
2693        (when enough-time-passed
2694          (if (> percentage 0)
2695              (message "%s%d%%" (aref parameters 3) percentage)
2696            (message "%s" (aref parameters 3))))))
2697    
2698    (defun progress-reporter-done (reporter)
2699      "Print reporter's message followed by word \"done\" in echo area."
2700      (message "%sdone" (aref (cdr reporter) 3)))
2701    
2702  ;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc  ;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
2703  ;;; subr.el ends here  ;;; subr.el ends here

Legend:
Removed from v.1.360.2.11  
changed lines
  Added in v.1.360.2.12

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