/[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.307.2.24 by miles, Wed Oct 6 05:21:51 2004 UTC revision 1.307.2.25 by miles, Mon Oct 25 04:19:39 2004 UTC
# Line 373  but optional second arg NODIGITS non-nil Line 373  but optional second arg NODIGITS non-nil
373            (define-key map (char-to-string loop) 'digit-argument)            (define-key map (char-to-string loop) 'digit-argument)
374            (setq loop (1+ loop))))))            (setq loop (1+ loop))))))
375    
 ;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)))  
   
376  (defvar key-substitution-in-progress nil  (defvar key-substitution-in-progress nil
377   "Used internally by substitute-key-definition.")   "Used internally by substitute-key-definition.")
378    
# Line 389  but optional second arg NODIGITS non-nil Line 380  but optional second arg NODIGITS non-nil
380    "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.
381  In other words, OLDDEF is replaced with NEWDEF where ever it appears.  In other words, OLDDEF is replaced with NEWDEF where ever it appears.
382  Alternatively, if optional fourth argument OLDMAP is specified, we redefine  Alternatively, if optional fourth argument OLDMAP is specified, we redefine
383  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.
384    
385    For most uses, it is simpler and safer to use command remappping like this:
386      \(define-key KEYMAP [remap OLDDEF] NEWDEF)"
387    ;; 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
388    ;; advertise it.  It's meant for recursive calls only.  Here's its    ;; advertise it.  It's meant for recursive calls only.  Here's its
389    ;; meaning    ;; meaning
# Line 399  in KEYMAP as NEWDEF those keys which are Line 393  in KEYMAP as NEWDEF those keys which are
393    ;; original key, with PREFIX added at the front.    ;; original key, with PREFIX added at the front.
394    (or prefix (setq prefix ""))    (or prefix (setq prefix ""))
395    (let* ((scan (or oldmap keymap))    (let* ((scan (or oldmap keymap))
396           (vec1 (vector nil))           (prefix1 (vconcat prefix [nil]))
          (prefix1 (vconcat prefix vec1))  
397           (key-substitution-in-progress           (key-substitution-in-progress
398            (cons scan key-substitution-in-progress)))            (cons scan key-substitution-in-progress)))
399      ;; Scan OLDMAP, finding each char or event-symbol that      ;; Scan OLDMAP, finding each char or event-symbol that
400      ;; has any definition, and act on it with hack-key.      ;; has any definition, and act on it with hack-key.
401      (while (consp scan)      (map-keymap
402        (if (consp (car scan))       (lambda (char defn)
403            (let ((char (car (car scan)))         (aset prefix1 (length prefix) char)
404                  (defn (cdr (car scan))))         (substitute-key-definition-key defn olddef newdef prefix1 keymap))
405              ;; The inside of this let duplicates exactly       scan)))
406              ;; the inside of the following let that handles array elements.  
407              (aset vec1 0 char)  (defun substitute-key-definition-key (defn olddef newdef prefix keymap)
408              (aset prefix1 (length prefix) char)    (let (inner-def skipped menu-item)
409              (let (inner-def skipped)      ;; Find the actual command name within the binding.
410                ;; Skip past menu-prompt.      (if (eq (car-safe defn) 'menu-item)
411                (while (stringp (car-safe defn))          (setq menu-item defn defn (nth 2 defn))
412                  (setq skipped (cons (car defn) skipped))        ;; Skip past menu-prompt.
413                  (setq defn (cdr defn)))        (while (stringp (car-safe defn))
414                ;; Skip past cached key-equivalence data for menu items.          (push (pop defn) skipped))
415                (and (consp defn) (consp (car defn))        ;; Skip past cached key-equivalence data for menu items.
416                     (setq defn (cdr defn)))        (if (consp (car-safe defn))
417                (setq inner-def defn)            (setq defn (cdr defn))))
418                ;; Look past a symbol that names a keymap.      (if (or (eq defn olddef)
419                (while (and (symbolp inner-def)              ;; Compare with equal if definition is a key sequence.
420                            (fboundp inner-def))              ;; That is useful for operating on function-key-map.
421                  (setq inner-def (symbol-function inner-def)))              (and (or (stringp defn) (vectorp defn))
422                (if (or (eq defn olddef)                   (equal defn olddef)))
423                        ;; Compare with equal if definition is a key sequence.          (define-key keymap prefix
424                        ;; That is useful for operating on function-key-map.            (if menu-item
425                        (and (or (stringp defn) (vectorp defn))                (let ((copy (copy-sequence menu-item)))
426                             (equal defn olddef)))                  (setcar (nthcdr 2 copy) newdef)
427                    (define-key keymap prefix1 (nconc (nreverse skipped) newdef))                  copy)
428                  (if (and (keymapp defn)              (nconc (nreverse skipped) newdef)))
429                           ;; Avoid recursively scanning        ;; Look past a symbol that names a keymap.
430                           ;; where KEYMAP does not have a submap.        (setq inner-def
431                           (let ((elt (lookup-key keymap prefix1)))              (condition-case nil (indirect-function defn) (error defn)))
432                             (or (null elt)        ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
433                                 (keymapp elt)))        ;; avoid autoloading a keymap.  This is mostly done to preserve the
434                           ;; Avoid recursively rescanning keymap being scanned.        ;; original non-autoloading behavior of pre-map-keymap times.
435                           (not (memq inner-def        (if (and (keymapp inner-def)
436                                      key-substitution-in-progress)))                 ;; Avoid recursively scanning
437                      ;; If this one isn't being scanned already,                 ;; where KEYMAP does not have a submap.
438                      ;; scan it now.                 (let ((elt (lookup-key keymap prefix)))
439                      (substitute-key-definition olddef newdef keymap                   (or (null elt) (natnump elt) (keymapp elt)))
440                                                 inner-def                 ;; Avoid recursively rescanning keymap being scanned.
441                                                 prefix1)))))                 (not (memq inner-def key-substitution-in-progress)))
442          (if (vectorp (car scan))            ;; If this one isn't being scanned already, scan it now.
443              (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)))))  
444    
445  (defun define-key-after (keymap key definition &optional after)  (defun define-key-after (keymap key definition &optional after)
446    "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 664  even when EVENT actually has modifiers." Line 586  even when EVENT actually has modifiers."
586              (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@              (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
587                                                 ?\H-\^@ ?\s-\^@ ?\A-\^@)))))                                                 ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
588          (if (not (zerop (logand type ?\M-\^@)))          (if (not (zerop (logand type ?\M-\^@)))
589              (setq list (cons 'meta list)))              (push 'meta list))
590          (if (or (not (zerop (logand type ?\C-\^@)))          (if (or (not (zerop (logand type ?\C-\^@)))
591                  (< char 32))                  (< char 32))
592              (setq list (cons 'control list)))              (push 'control list))
593          (if (or (not (zerop (logand type ?\S-\^@)))          (if (or (not (zerop (logand type ?\S-\^@)))
594                  (/= char (downcase char)))                  (/= char (downcase char)))
595              (setq list (cons 'shift list)))              (push 'shift list))
596          (or (zerop (logand type ?\H-\^@))          (or (zerop (logand type ?\H-\^@))
597              (setq list (cons 'hyper list)))              (push 'hyper list))
598          (or (zerop (logand type ?\s-\^@))          (or (zerop (logand type ?\s-\^@))
599              (setq list (cons 'super list)))              (push 'super list))
600          (or (zerop (logand type ?\A-\^@))          (or (zerop (logand type ?\A-\^@))
601              (setq list (cons 'alt list)))              (push 'alt list))
602          list))))          list))))
603    
604  (defun event-basic-type (event)  (defun event-basic-type (event)
# Line 694  in the current Emacs session, then this Line 616  in the current Emacs session, then this
616    
617  (defsubst mouse-movement-p (object)  (defsubst mouse-movement-p (object)
618    "Return non-nil if OBJECT is a mouse movement event."    "Return non-nil if OBJECT is a mouse movement event."
619    (and (consp object)    (eq (car-safe object) 'mouse-movement))
        (eq (car object) 'mouse-movement)))  
620    
621  (defsubst event-start (event)  (defsubst event-start (event)
622    "Return the starting position of EVENT.    "Return the starting position of EVENT.
# Line 1886  Use a MESSAGE of \"\" to temporarily cle Line 1807  Use a MESSAGE of \"\" to temporarily cle
1807  See also `with-temp-file' and `with-output-to-string'."  See also `with-temp-file' and `with-output-to-string'."
1808    (declare (indent 0) (debug t))    (declare (indent 0) (debug t))
1809    (let ((temp-buffer (make-symbol "temp-buffer")))    (let ((temp-buffer (make-symbol "temp-buffer")))
1810      `(let ((,temp-buffer      `(let ((,temp-buffer (generate-new-buffer " *temp*")))
             (get-buffer-create (generate-new-buffer-name " *temp*"))))  
1811         (unwind-protect         (unwind-protect
1812             (with-current-buffer ,temp-buffer             (with-current-buffer ,temp-buffer
1813               ,@body)               ,@body)
# Line 2644  The properties used on SYMBOL are `compo Line 2564  The properties used on SYMBOL are `compo
2564    (put symbol 'abortfunc (or abortfunc 'kill-buffer))    (put symbol 'abortfunc (or abortfunc 'kill-buffer))
2565    (put symbol 'hookvar (or hookvar 'mail-send-hook)))    (put symbol 'hookvar (or hookvar 'mail-send-hook)))
2566    
2567    ;; Standardized progress reporting
2568    
2569    ;; Progress reporter has the following structure:
2570    ;;
2571    ;;      (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME
2572    ;;                            MIN-VALUE
2573    ;;                            MAX-VALUE
2574    ;;                            MESSAGE
2575    ;;                            MIN-CHANGE
2576    ;;                            MIN-TIME])
2577    ;;
2578    ;; This weirdeness is for optimization reasons: we want
2579    ;; `progress-reporter-update' to be as fast as possible, so
2580    ;; `(car reporter)' is better than `(aref reporter 0)'.
2581    ;;
2582    ;; NEXT-UPDATE-TIME is a float.  While `float-time' loses a couple
2583    ;; digits of precision, it doesn't really matter here.  On the other
2584    ;; hand, it greatly simplifies the code.
2585    
2586    (defsubst progress-reporter-update (reporter value)
2587      "Report progress of an operation in the echo area.
2588    However, if the change since last echo area update is too small
2589    or not enough time has passed, then do nothing (see
2590    `make-progress-reporter' for details).
2591    
2592    First parameter, REPORTER, should be the result of a call to
2593    `make-progress-reporter'.  Second, VALUE, determines the actual
2594    progress of operation; it must be between MIN-VALUE and MAX-VALUE
2595    as passed to `make-progress-reporter'.
2596    
2597    This function is very inexpensive, you may not bother how often
2598    you call it."
2599      (when (>= value (car reporter))
2600        (progress-reporter-do-update reporter value)))
2601    
2602    (defun make-progress-reporter (message min-value max-value
2603                                           &optional current-value
2604                                           min-change min-time)
2605      "Return progress reporter object usage with `progress-reporter-update'.
2606    
2607    MESSAGE is shown in the echo area.  When at least 1% of operation
2608    is complete, the exact percentage will be appended to the
2609    MESSAGE.  When you call `progress-reporter-done', word \"done\"
2610    is printed after the MESSAGE.  You can change MESSAGE of an
2611    existing progress reporter with `progress-reporter-force-update'.
2612    
2613    MIN-VALUE and MAX-VALUE designate starting (0% complete) and
2614    final (100% complete) states of operation.  The latter should be
2615    larger; if this is not the case, then simply negate all values.
2616    Optional CURRENT-VALUE specifies the progress by the moment you
2617    call this function.  You should omit it or set it to nil in most
2618    cases since it defaults to MIN-VALUE.
2619    
2620    Optional MIN-CHANGE determines the minimal change in percents to
2621    report (default is 1%.)  Optional MIN-TIME specifies the minimal
2622    time before echo area updates (default is 0.2 seconds.)  If
2623    `float-time' function is not present, then time is not tracked
2624    at all.  If OS is not capable of measuring fractions of seconds,
2625    then this parameter is effectively rounded up."
2626    
2627      (unless min-time
2628        (setq min-time 0.2))
2629      (let ((reporter
2630             (cons min-value ;; Force a call to `message' now
2631                   (vector (if (and (fboundp 'float-time)
2632                                    (>= min-time 0.02))
2633                               (float-time) nil)
2634                           min-value
2635                           max-value
2636                           message
2637                           (if min-change (max (min min-change 50) 1) 1)
2638                           min-time))))
2639        (progress-reporter-update reporter (or current-value min-value))
2640        reporter))
2641    
2642    (defun progress-reporter-force-update (reporter value &optional new-message)
2643      "Report progress of an operation in the echo area unconditionally.
2644    
2645    First two parameters are the same as for
2646    `progress-reporter-update'.  Optional NEW-MESSAGE allows you to
2647    change the displayed message."
2648      (let ((parameters (cdr reporter)))
2649        (when new-message
2650          (aset parameters 3 new-message))
2651        (when (aref parameters 0)
2652          (aset parameters 0 (float-time)))
2653        (progress-reporter-do-update reporter value)))
2654    
2655    (defun progress-reporter-do-update (reporter value)
2656      (let* ((parameters   (cdr reporter))
2657             (min-value    (aref parameters 1))
2658             (max-value    (aref parameters 2))
2659             (one-percent  (/ (- max-value min-value) 100.0))
2660             (percentage   (truncate (/ (- value min-value) one-percent)))
2661             (update-time  (aref parameters 0))
2662             (current-time (float-time))
2663             (enough-time-passed
2664              ;; See if enough time has passed since the last update.
2665              (or (not update-time)
2666                  (when (>= current-time update-time)
2667                    ;; Calculate time for the next update
2668                    (aset parameters 0 (+ update-time (aref parameters 5)))))))
2669        ;;
2670        ;; Calculate NEXT-UPDATE-VALUE.  If we are not going to print
2671        ;; message this time because not enough time has passed, then use
2672        ;; 1 instead of MIN-CHANGE.  This makes delays between echo area
2673        ;; updates closer to MIN-TIME.
2674        (setcar reporter
2675                (min (+ min-value (* (+ percentage
2676                                        (if enough-time-passed
2677                                            (aref parameters 4) ;; MIN-CHANGE
2678                                          1))
2679                                     one-percent))
2680                     max-value))
2681        (when (integerp value)
2682          (setcar reporter (ceiling (car reporter))))
2683        ;;
2684        ;; Only print message if enough time has passed
2685        (when enough-time-passed
2686          (if (> percentage 0)
2687              (message "%s%d%%" (aref parameters 3) percentage)
2688            (message "%s" (aref parameters 3))))))
2689    
2690    (defun progress-reporter-done (reporter)
2691      "Print reporter's message followed by word \"done\" in echo area."
2692      (message "%sdone" (aref (cdr reporter) 3)))
2693    
2694  ;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc  ;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
2695  ;;; subr.el ends here  ;;; subr.el ends here

Legend:
Removed from v.1.307.2.24  
changed lines
  Added in v.1.307.2.25

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