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