Mercurial > hg > xemacs-beta
changeset 5330:fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
lisp/ChangeLog addition:
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 02 Jan 2011 17:04:13 +0000 |
| parents | 7b391d07b334 |
| children | 7ea837399734 |
| files | lisp/ChangeLog lisp/dialog.el lisp/list-mode.el |
| diffstat | 3 files changed, 248 insertions(+), 256 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sun Jan 02 16:18:26 2011 +0000 +++ b/lisp/ChangeLog Sun Jan 02 17:04:13 2011 +0000 @@ -1,3 +1,11 @@ +2011-01-02 Aidan Kehoe <kehoea@parhasard.net> + + * dialog.el (make-dialog-box): + * list-mode.el (display-completion-list): + These functions used to use cl-parsing-keywords; change them to + use defun* instead, fixing the build. (Not sure what led to me + not including this change in d1b17a33450b!) + 2011-01-02 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el (define-star-compiler-macros):
--- a/lisp/dialog.el Sun Jan 02 16:18:26 2011 +0000 +++ b/lisp/dialog.el Sun Jan 02 17:04:13 2011 +0000 @@ -121,7 +121,9 @@ (apply 'message-box fmt args) (apply 'message fmt args))) -(defun make-dialog-box (type &rest cl-keys) +(defun* make-dialog-box (type &rest rest &key (title "XEmacs") + (parent (selected-frame)) modal properties autosize + spec &allow-other-keys) "Pop up a dialog box. TYPE is a symbol, the type of dialog box. Remaining arguments are keyword-value pairs, specifying the particular characteristics of the @@ -570,112 +572,100 @@ (signal 'quit nil))))) (case type (general - (cl-parsing-keywords - ((:title "XEmacs") - (:parent (selected-frame)) - :modal - :properties - :autosize - :spec) - () - (flet ((create-dialog-box-frame () - (let* ((ftop (frame-property cl-parent 'top)) - (fleft (frame-property cl-parent 'left)) - (fwidth (frame-pixel-width cl-parent)) - (fheight (frame-pixel-height cl-parent)) - (fonth (font-height (face-font 'default))) - (fontw (font-width (face-font 'default))) - (cl-properties (append cl-properties - dialog-frame-plist)) - (dfheight (plist-get cl-properties 'height)) - (dfwidth (plist-get cl-properties 'width)) - (unmapped (plist-get cl-properties - 'initially-unmapped)) - (gutter-spec cl-spec) - (name (or (plist-get cl-properties 'name) "XEmacs")) - (frame nil)) - (plist-remprop cl-properties 'initially-unmapped) - ;; allow the user to just provide a glyph - (or (glyphp cl-spec) (setq cl-spec (make-glyph cl-spec))) - (setq gutter-spec (copy-sequence "\n")) - (set-extent-begin-glyph (make-extent 0 1 gutter-spec) - cl-spec) - ;; under FVWM at least, if I don't specify the - ;; initial position, it ends up always at (0, 0). - ;; xwininfo doesn't tell me that there are any - ;; program-specified position hints, so it must be - ;; an FVWM bug. So just be smashing and position in - ;; the center of the selected frame. - (setq frame - (make-frame - (append cl-properties - `(popup - ,cl-parent initially-unmapped t - menubar-visible-p nil - has-modeline-p nil - default-toolbar-visible-p nil - top-gutter-visible-p t - top-gutter-height ,(* dfheight fonth) - top-gutter ,gutter-spec - minibuffer none - name ,name - modeline-shadow-thickness 0 - vertical-scrollbar-visible-p nil - horizontal-scrollbar-visible-p nil - unsplittable t - internal-border-width 8 - left ,(+ fleft (- (/ fwidth 2) - (/ (* dfwidth - fontw) - 2))) - top ,(+ ftop (- (/ fheight 2) - (/ (* dfheight - fonth) - 2))))))) - (set-face-foreground 'modeline [default foreground] frame) - (set-face-background 'modeline [default background] frame) - ;; resize before mapping - (when cl-autosize - (set-frame-displayable-pixel-size - frame - (image-instance-width - (glyph-image-instance cl-spec - (frame-selected-window frame))) - (image-instance-height - (glyph-image-instance cl-spec - (frame-selected-window frame))))) - ;; somehow, even though the resizing is supposed - ;; to be while the frame is not visible, a - ;; visible resize is perceptible - (unless unmapped (make-frame-visible frame)) - (let ((newbuf (generate-new-buffer " *dialog box*"))) - (set-buffer-dedicated-frame newbuf frame) - (set-frame-property frame 'dialog-box-buffer newbuf) - (set-window-buffer (frame-root-window frame) newbuf) - (with-current-buffer newbuf - (set (make-local-variable 'frame-title-format) - cl-title) - (add-local-hook 'delete-frame-hook - #'(lambda (frame) - (kill-buffer - (frame-property - frame - 'dialog-box-buffer)))))) - frame))) - (if cl-modal - (dialog-box-modal-loop '(create-dialog-box-frame)) - (create-dialog-box-frame))))) + (flet ((create-dialog-box-frame () + (let* ((ftop (frame-property parent 'top)) + (fleft (frame-property parent 'left)) + (fwidth (frame-pixel-width parent)) + (fheight (frame-pixel-height parent)) + (fonth (font-height (face-font 'default))) + (fontw (font-width (face-font 'default))) + (properties (append properties + dialog-frame-plist)) + (dfheight (plist-get properties 'height)) + (dfwidth (plist-get properties 'width)) + (unmapped (plist-get properties + 'initially-unmapped)) + (gutter-spec spec) + (name (or (plist-get properties 'name) "XEmacs")) + (frame nil)) + (plist-remprop properties 'initially-unmapped) + ;; allow the user to just provide a glyph + (or (glyphp spec) (setq spec (make-glyph spec))) + (setq gutter-spec (copy-sequence "\n")) + (set-extent-begin-glyph (make-extent 0 1 gutter-spec) + spec) + ;; under FVWM at least, if I don't specify the + ;; initial position, it ends up always at (0, 0). + ;; xwininfo doesn't tell me that there are any + ;; program-specified position hints, so it must be + ;; an FVWM bug. So just be smashing and position in + ;; the center of the selected frame. + (setq frame + (make-frame + (append properties + `(popup + ,parent initially-unmapped t + menubar-visible-p nil + has-modeline-p nil + default-toolbar-visible-p nil + top-gutter-visible-p t + top-gutter-height ,(* dfheight fonth) + top-gutter ,gutter-spec + minibuffer none + name ,name + modeline-shadow-thickness 0 + vertical-scrollbar-visible-p nil + horizontal-scrollbar-visible-p nil + unsplittable t + internal-border-width 8 + left ,(+ fleft (- (/ fwidth 2) + (/ (* dfwidth + fontw) + 2))) + top ,(+ ftop (- (/ fheight 2) + (/ (* dfheight + fonth) + 2))))))) + (set-face-foreground 'modeline [default foreground] frame) + (set-face-background 'modeline [default background] frame) + ;; resize before mapping + (when autosize + (set-frame-displayable-pixel-size + frame + (image-instance-width + (glyph-image-instance spec + (frame-selected-window frame))) + (image-instance-height + (glyph-image-instance spec + (frame-selected-window frame))))) + ;; somehow, even though the resizing is supposed + ;; to be while the frame is not visible, a + ;; visible resize is perceptible + (unless unmapped (make-frame-visible frame)) + (let ((newbuf (generate-new-buffer " *dialog box*"))) + (set-buffer-dedicated-frame newbuf frame) + (set-frame-property frame 'dialog-box-buffer newbuf) + (set-window-buffer (frame-root-window frame) newbuf) + (with-current-buffer newbuf + (set (make-local-variable 'frame-title-format) + title) + (add-local-hook 'delete-frame-hook + #'(lambda (frame) + (kill-buffer + (frame-property + frame + 'dialog-box-buffer)))))) + frame))) + (if modal + (dialog-box-modal-loop '(create-dialog-box-frame)) + (create-dialog-box-frame)))) (question - (cl-parsing-keywords - ((:modal nil)) - t - (remf cl-keys :modal) - (if cl-modal - (dialog-box-modal-loop `(make-dialog-box-internal ',type - ',cl-keys)) - (make-dialog-box-internal type cl-keys)))) - (t - (make-dialog-box-internal type cl-keys))))) + (remf rest :modal) + (if modal + (dialog-box-modal-loop `(make-dialog-box-internal ',type ',rest)) + (make-dialog-box-internal type rest)))) + (t + (make-dialog-box-internal type rest)))) (defun dialog-box-finish (result) "Exit a modal dialog box, returning RESULT.
--- a/lisp/list-mode.el Sun Jan 02 16:18:26 2011 +0000 +++ b/lisp/list-mode.el Sun Jan 02 17:04:13 2011 +0000 @@ -276,7 +276,11 @@ This string is inserted at the beginning of the buffer. See `display-completion-list'.") -(defun display-completion-list (completions &rest cl-keys) +(defun* display-completion-list (completions &key user-data reference-buffer + (activate-callback 'default-choose-completion) + (help-string completion-default-help-string) + (completion-string "Possible completions are:") + window-width window-height) "Display the list of completions, COMPLETIONS, using `standard-output'. Each element may be just a symbol or string or may be a list of two strings to be printed as if concatenated. @@ -310,158 +314,148 @@ It can find the completion buffer in `standard-output'. If `completion-highlight-first-word-only' is non-nil, then only the start of the string is highlighted." - ;; #### I18N3 should set standard-output to be (temporarily) - ;; output-translating. - (cl-parsing-keywords - ((:activate-callback 'default-choose-completion) - :user-data - :reference-buffer - (:help-string completion-default-help-string) - (:completion-string "Possible completions are:") - :window-width - :window-height) - () - (let ((old-buffer (current-buffer)) - (bufferp (bufferp standard-output))) - (if bufferp - (set-buffer standard-output)) - (if (null completions) - (princ (gettext - "There are no possible completions of what you have typed.")) - (let ((win-width - (or cl-window-width - (if bufferp - ;; We have to use last-nonminibuf-frame here - ;; and not selected-frame because if a - ;; minibuffer-only frame is being used it will - ;; be the selected-frame at the point this is - ;; run. We keep the selected-frame call around - ;; just in case. - (window-width (get-lru-window (last-nonminibuf-frame))) - 80)))) - (let ((count 0) - (max-width 0) - old-max-width) - ;; Find longest completion - (let ((tail completions)) - (while tail - (let* ((elt (car tail)) - (len (cond ((stringp elt) - (length elt)) - ((and (consp elt) - (stringp (car elt)) - (stringp (car (cdr elt)))) - (+ (length (car elt)) - (length (car (cdr elt))))) - (t - (signal 'wrong-type-argument - (list 'stringp elt)))))) - (if (> len max-width) - (setq max-width len)) - (setq count (1+ count) - tail (cdr tail))))) + ;; #### I18N3 should set standard-output to be (temporarily) + ;; output-translating. + (let ((old-buffer (current-buffer)) (bufferp (bufferp standard-output))) + (if bufferp + (set-buffer standard-output)) + (if (null completions) + (princ (gettext + "There are no possible completions of what you have typed.")) + (let ((win-width + (or window-width + (if bufferp + ;; We have to use last-nonminibuf-frame here + ;; and not selected-frame because if a + ;; minibuffer-only frame is being used it will + ;; be the selected-frame at the point this is + ;; run. We keep the selected-frame call around + ;; just in case. + (window-width (get-lru-window (last-nonminibuf-frame))) + 80)))) + (let ((count 0) + (max-width 0) + old-max-width) + ;; Find longest completion + (let ((tail completions)) + (while tail + (let* ((elt (car tail)) + (len (cond ((stringp elt) + (length elt)) + ((and (consp elt) + (stringp (car elt)) + (stringp (car (cdr elt)))) + (+ (length (car elt)) + (length (car (cdr elt))))) + (t + (signal 'wrong-type-argument + (list 'stringp elt)))))) + (if (> len max-width) + (setq max-width len)) + (setq count (1+ count) + tail (cdr tail))))) - (setq max-width (+ 2 max-width)) ; at least two chars between cols - (setq old-max-width max-width) - (let ((rows (let ((cols (min (/ win-width max-width) count))) - (if (<= cols 1) - count - (progn - ;; re-space the columns - (setq max-width (/ win-width cols)) - (if (/= (% count cols) 0) ; want ceiling... - (1+ (/ count cols)) - (/ count cols))))))) - (when - (and cl-window-height - (> rows cl-window-height)) - (setq max-width old-max-width) - (setq rows cl-window-height)) - (when (and (stringp cl-completion-string) - (> (length cl-completion-string) 0)) - (princ (gettext cl-completion-string)) - (terpri)) - (let ((tail completions) - (r 0) - (regexp-string - (if (eq t - completion-highlight-first-word-only) - "[ \t]" - completion-highlight-first-word-only))) - (while (< r rows) - (and (> r 0) (terpri)) - (let ((indent 0) - (column 0) - (tail2 tail)) - (while tail2 - (let ((elt (car tail2))) - (if (/= indent 0) - (if bufferp - (indent-to indent 2) - (while (progn (write-char ?\ ) - (setq column (1+ column)) - (< column indent))))) - (setq indent (+ indent max-width)) - (let ((start (point)) - end) - ;; Frob some mousable extents in there too! - (if (consp elt) - (progn - (princ (car elt)) - (princ (car (cdr elt))) - (or bufferp - (setq column - (+ column - (length (car elt)) - (length (car (cdr elt))))))) - (progn - (princ elt) - (or bufferp - (setq column (+ column (length - elt)))))) - (add-list-mode-item - start - (progn - (setq end (point)) - (or - (and completion-highlight-first-word-only - (goto-char start) - (re-search-forward regexp-string end t) - (match-beginning 0)) - end)) - nil cl-activate-callback cl-user-data) - (goto-char end))) - (setq tail2 (nthcdr rows tail2))) - (setq tail (cdr tail) - r (1+ r))))))))) - (if bufferp - (set-buffer old-buffer))) - (save-excursion - (let ((mainbuf (or cl-reference-buffer (current-buffer)))) - (set-buffer standard-output) - (completion-list-mode) - (make-local-variable 'completion-reference-buffer) - (setq completion-reference-buffer mainbuf) + (setq max-width (+ 2 max-width)) ; at least two chars between cols + (setq old-max-width max-width) + (let ((rows (let ((cols (min (/ win-width max-width) count))) + (if (<= cols 1) + count + (progn + ;; re-space the columns + (setq max-width (/ win-width cols)) + (if (/= (% count cols) 0) ; want ceiling... + (1+ (/ count cols)) + (/ count cols))))))) + (when + (and window-height + (> rows window-height)) + (setq max-width old-max-width) + (setq rows window-height)) + (when (and (stringp completion-string) + (> (length completion-string) 0)) + (princ (gettext completion-string)) + (terpri)) + (let ((tail completions) + (r 0) + (regexp-string + (if (eq t + completion-highlight-first-word-only) + "[ \t]" + completion-highlight-first-word-only))) + (while (< r rows) + (and (> r 0) (terpri)) + (let ((indent 0) + (column 0) + (tail2 tail)) + (while tail2 + (let ((elt (car tail2))) + (if (/= indent 0) + (if bufferp + (indent-to indent 2) + (while (progn (write-char ?\ ) + (setq column (1+ column)) + (< column indent))))) + (setq indent (+ indent max-width)) + (let ((start (point)) + end) + ;; Frob some mousable extents in there too! + (if (consp elt) + (progn + (princ (car elt)) + (princ (car (cdr elt))) + (or bufferp + (setq column + (+ column + (length (car elt)) + (length (car (cdr elt))))))) + (progn + (princ elt) + (or bufferp + (setq column (+ column (length + elt)))))) + (add-list-mode-item + start + (progn + (setq end (point)) + (or + (and completion-highlight-first-word-only + (goto-char start) + (re-search-forward regexp-string end t) + (match-beginning 0)) + end)) + nil activate-callback user-data) + (goto-char end))) + (setq tail2 (nthcdr rows tail2))) + (setq tail (cdr tail) + r (1+ r))))))))) + (if bufferp + (set-buffer old-buffer))) + (save-excursion + (let ((mainbuf (or reference-buffer (current-buffer)))) + (set-buffer standard-output) + (completion-list-mode) + (make-local-variable 'completion-reference-buffer) + (setq completion-reference-buffer mainbuf) ;;; The value 0 is right in most cases, but not for file name completion. ;;; so this has to be turned off. -;;; (setq completion-base-size 0) - (goto-char (point-min)) - (let ((buffer-read-only nil)) - (insert (eval cl-help-string))) - ;; unnecessary FSFmacs crock - ;;(forward-line 1) - ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t) - ;; (let ((beg (match-beginning 0)) - ;; (end (point))) - ;; (if completion-fixup-function - ;; (funcall completion-fixup-function)) - ;; (put-text-property beg (point) 'mouse-face 'highlight) - ;; (put-text-property beg (point) 'list-mode-item t) - ;; (goto-char end))))) - )) - (save-excursion - (set-buffer standard-output) - (run-hooks 'completion-setup-hook)))) +;;; (setq completion-base-size 0) + (goto-char (point-min)) + (let ((buffer-read-only nil)) + (insert (eval help-string))) + ;; unnecessary FSFmacs crock + ;;(forward-line 1) + ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t) + ;; (let ((beg (match-beginning 0)) + ;; (end (point))) + ;; (if completion-fixup-function + ;; (funcall completion-fixup-function)) + ;; (put-text-property beg (point) 'mouse-face 'highlight) + ;; (put-text-property beg (point) 'list-mode-item t) + ;; (goto-char end))))) + )) + (save-excursion + (set-buffer standard-output) + (run-hooks 'completion-setup-hook))) (defvar completion-display-completion-list-function 'display-completion-list "Function to set up the list of completions in the completion buffer.