/[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 by rms, Mon Jun 10 09:01:08 2002 UTC revision 1.307.2.1 by miles, Wed Jun 12 01:53:21 2002 UTC
# Line 263  Non-strings in LIST are ignored." Line 263  Non-strings in LIST are ignored."
263      (setq list (cdr list)))      (setq list (cdr list)))
264    list)    list)
265    
266    (defmacro with-lexical-binding (&rest body)
267      "Execute the statements in BODY using lexical binding."
268      `(let ((internal-interpreter-environment internal-interpreter-environment))
269         (setq internal-interpreter-environment '(t))
270         ,@body))
271    
272    
273  ;;;; Keymap support.  ;;;; Keymap support.
274    
# Line 677  as returned by the `event-start' and `ev Line 683  as returned by the `event-start' and `ev
683    (nth 3 position))    (nth 3 position))
684    
685    
686    ;;;; Keyboard menu prompting
687    
688    (defvar key-menu-event-face 'underline
689      "Face used to highlight the events in the keyboard-menu prompt.
690    Used by `key-menu-prompt'.")
691    (defvar key-menu-initial-separator "  "
692      "String used to separate a keyboard-menu prompt from the first key description.
693    Used by `key-menu-prompt'.")
694    (defvar key-menu-separator ",  "
695      "String used to separate adjacent keyboard-menu key descriptions.
696    Used by `key-menu-prompt'.")
697    (defvar key-menu-long-prompt-line-prefix "    "
698      "A prefix for entry lines when the menu prompt is very long.
699    Used by `key-menu-prompt'.")
700    
701    (defvar key-menu-format-entry-function nil
702      "If non-nil, a function to format a single entry in a keyboard-menu.
703    The function should return a string representing the entry, and will be
704    given the following arguments:
705      (EVENT PROMPT &OPTIONAL BINDING TOGGLE-TYPE TOGGLE-STATE)
706      EVENT is the key to be pressed
707      PROMPT is a string describing the entry
708      BINDING is a `global' binding for this function
709      TOGGLE-TYPE may be either nil, `:radio', or `:toggle'
710      If TOGGLE-TYPE is non-nil, TOGGLE-STATE is that toggle's state.")
711    
712    (defvar key-menu-more-prompt (propertize "--more--" 'face '(:inverse-video t))
713      "Appended to the last line of a keyboard-menu indicating more lines follow.")
714    
715    (defun key-menu-format-entry (event prompt
716                                        &optional binding toggle-type toggle-state)
717      "Return a string representing a single keyboard-menu binding.
718    The arguments are:
719      EVENT is the key to be pressed
720      PROMPT is a string describing the entry
721      BINDING is a `global' binding for this function
722      TOGGLE-TYPE may be either nil, `:radio', or `:toggle'
723      If TOGGLE-TYPE is non-nil, TOGGLE-STATE is that toggle's state."
724      (if (eq event (aref prompt 0))
725          (format "%s%s"
726                  (propertize (char-to-string event)
727                              'face key-menu-event-face)
728                  (substring prompt 1))
729        (format "%s = %s"
730                (propertize (char-to-string event)
731                            'face key-menu-event-face)
732                prompt)))
733    
734    (defun key-menu-format-prompt (prompt entries max-width max-height)
735      (let* ((prompt-width (string-width prompt))
736             (cur-line "")
737             (prefix nil)
738             (prefix-width
739              ;; a guess, at first
740              (+ prompt-width (string-width key-menu-initial-separator)))
741             (sep "")
742             (string prompt)
743             (cur-height 0)
744             (cur-line-width prefix-width)
745             (more-width (string-width key-menu-more-prompt)))
746        (while (and entries (< cur-height max-height))
747          (let* ((entry
748                  (pop entries))
749                 (entry-string
750                  (apply
751                   (or key-menu-format-entry-function #'key-menu-format-entry)
752                   entry))
753                 (entry-width
754                  (string-width entry-string))
755                 (appended-width
756                  (+ cur-line-width (string-width sep) entry-width)))
757            ;; If this is the first line, first see if we'd be better off
758            ;; wrapping right after the prompt (because the prompt string is
759            ;; unusually long).  Note that we only do so if there are (1)
760            ;; less than 4 entries already on the first line, and (2) the
761            ;; prompt is greater than 12 characters wide; these values are
762            ;; completely arbitrary.
763            (when (and (eq string prompt)
764                       (>= appended-width max-width)
765                       (> prompt-width (/ max-width 4))
766                       (> max-height 1))
767              ;; Wrap after the prompt
768              (setq cur-line-width (- cur-line-width prefix-width))
769              (setq prefix key-menu-long-prompt-line-prefix
770                    prefix-width (string-width prefix))
771              (setq string (concat string "\n")
772                    cur-line-width (+ cur-line-width prefix-width)
773                    appended-width (+ cur-line-width (string-width sep) entry-width)
774                    cur-height (1+ cur-height)))
775            ;; See if we have to wrap before the current entry (note that
776            ;; this might happen even if we just wrapped after the prompt
777            ;; above).
778            (if (if (or (< (1+ cur-height) max-height) (null entries))
779                    (< appended-width max-width)
780                  (< (+ appended-width more-width) max-width))
781                ;; It's OK to append the current entry, so do so
782                (setq cur-line (concat cur-line sep entry-string)
783                      cur-line-width appended-width)
784              ;; We have to wrap the current line first, and then append it
785              (if prefix
786                  (setq string (concat string prefix cur-line))
787                (setq string (concat string key-menu-initial-separator cur-line)
788                      prefix (make-string prefix-width ? )))
789              (setq cur-height (1+ cur-height))
790              (if (< cur-height max-height)
791                  ;; Start a new line
792                  (setq cur-line entry-string
793                        cur-line-width (+ entry-width prefix-width)
794                        string (concat string "\n"))
795                ;; Have to give up, because there's no more room.
796                (setq string (concat string
797                                     (make-string (- max-width
798                                                     cur-line-width
799                                                     (string-width
800                                                      key-menu-more-prompt)
801                                                     1)
802                                                  ? )
803                                     key-menu-more-prompt))
804                ;; Put back ENTRY for later consideration
805                (push entry entries)))
806            ;; Update sep to the normal inter-entry value
807            (setq sep key-menu-separator)))
808        ;; The final menu
809        (unless entries
810          ;; tack on the last line
811          (unless prefix
812            (setq prefix key-menu-initial-separator))
813          (setq string (concat string prefix cur-line)))
814        ;; Return a list of the menu string and any remaining entries
815        (cons string entries)))
816    
817    
818    (defun key-menu-prompt (menu)
819      "Display the keyboard-menu MENU, and read the user's response.
820    This function is appropiate for `key-menu-prompt-function', which see."
821      (let* ((prompt (concat (car menu) ":"))
822             (frame (window-frame (minibuffer-window)))
823             (max-width (frame-width frame))
824             (max-height
825              (cond ((or (not resize-mini-windows)
826                         (not (numberp max-mini-window-height)))
827                     1)
828                    ((integerp max-mini-window-height)
829                     max-mini-window-height)
830                    (t
831                     (max 1 (truncate (* (frame-height frame)
832                                         max-mini-window-height))))))
833             (answer nil)
834             (entries (cdr menu))
835             (cur-entries entries)
836             (prev-entries-stack nil))
837        (while (null answer)
838          (let* ((page
839                  (key-menu-format-prompt prompt cur-entries max-width max-height))
840                 (next-entries (cdr page)))
841            (setq answer (read-char (car page)))
842            (when (or next-entries prev-entries-stack)
843              (cond ((eq answer ? )
844                     (push cur-entries prev-entries-stack)
845                     (setq cur-entries (or next-entries entries))
846                     (setq answer nil))
847                    ((eq answer ?\C-?)
848                     (setq cur-entries (or (pop prev-entries-stack) entries))
849                     (setq answer nil))))))
850        answer))
851    
852    ;; `key-menu-prompt-function' is defined in src/keyboard.c
853    (setq key-menu-prompt-function 'key-menu-prompt)
854    
855    
856  ;;;; Obsolescent names for functions.  ;;;; Obsolescent names for functions.
857    
858  (defalias 'dot 'point)  (defalias 'dot 'point)
# Line 1905  configuration." Line 2081  configuration."
2081    (and (consp object)    (and (consp object)
2082         (eq (car object) 'frame-configuration)))         (eq (car object) 'frame-configuration)))
2083    
 (defun functionp (object)  
   "Non-nil iff OBJECT is a type of object that can be called as a function."  
   (or (and (symbolp object) (fboundp object)  
            (condition-case nil  
                (setq object (indirect-function object))  
              (error nil))  
            (eq (car-safe object) 'autoload)  
            (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))  
       (subrp object) (byte-code-function-p object)  
       (eq (car-safe object) 'lambda)))  
   
2084  (defun interactive-form (function)  (defun interactive-form (function)
2085    "Return the interactive form of FUNCTION.    "Return the interactive form of FUNCTION.
2086  If function is a command (see `commandp'), value is a list of the form  If function is a command (see `commandp'), value is a list of the form

Legend:
Removed from v.1.307  
changed lines
  Added in v.1.307.2.1

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