[COMMIT] Make functions in frame.el more general.

APPROVE COMMIT NOTE; this patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1230646949 0 # Node ID 44129f301385e892320cacced2696acdbdf6a1df # Parent 8775d3b5487437a87fa8c75338b7c3fc6cb7a2e1 Make functions in frame.el more general. (This results in better behaviour on Carbon, notably.) 2008-12-30 Aidan Kehoe <kehoea(a)parhasard.net&gt; * frame.el (display-mouse-p): (display-popup-menus-p): (display-images-p): (display-selections-p): (display-visual-class): Make all these functions more general, do not hard code device type symbols where that is inappropriate. diff -r 8775d3b54874 -r 44129f301385 lisp/ChangeLog --- a/lisp/ChangeLog Mon Dec 29 23:36:00 2008 +0900 +++ b/lisp/ChangeLog Tue Dec 30 14:22:29 2008 +0000 ＠＠ -1,3 +1,13 ＠＠ +2008-12-30 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * frame.el (display-mouse-p): + (display-popup-menus-p): + (display-images-p): + (display-selections-p): + (display-visual-class): + Make all these functions more general, do not hard code device + type symbols where that is inappropriate. + 2008-12-27 Aidan Kehoe <kehoea(a)parhasard.net&gt; * loadhist.el (symbol-file): diff -r 8775d3b54874 -r 44129f301385 lisp/frame.el --- a/lisp/frame.el Mon Dec 29 23:36:00 2008 +0900 +++ b/lisp/frame.el Tue Dec 30 14:22:29 2008 +0000 ＠＠ -1179,21 +1179,29 ＠＠ "Return non-nil if DISPLAY has a mouse available. DISPLAY can be a frame, a device, a console, or nil (meaning the selected frame)." - (case (framep-on-display display) - ;; We assume X, NeXTstep, and GTK *always* have a pointing device - ((x ns gtk) t) - (mswindows (> (declare-boundp mswindows-num-mouse-buttons) 0)) - (tty + (let (type) + (setq display (display-device display) + type (device-type display)) + (cond + ((eq 'mswindows type) + (> (declare-boundp mswindows-num-mouse-buttons) 0)) + ((device-on-window-system-p display) + ;; We assume X, NeXTstep, and GTK and the rest always have a pointing + ;; device. + t) + ((eq 'tty type) (and-fboundp 'gpm-is-supported-p - (gpm-is-supported-p (display-device display)))) - (t nil))) + (gpm-is-supported-p display))) + (t nil)))) (defun display-popup-menus-p (&optional display) "Return non-nil if popup menus are supported on DISPLAY. DISPLAY can be a frame, a device, a console, or nil (meaning the selected frame). Support for popup menus requires that the mouse be available." + (setq display (display-device display)) (and - (memq (framep-on-display display) '(x ns gtk mswindows)) + (featurep 'menubar) + (device-on-window-system-p display) (display-mouse-p display))) (defun display-graphic-p (&optional display) ＠＠ -1203,13 +1211,17 ＠＠ that use a window system such as X, and false for text-only terminals. DISPLAY can be a frame, a device, a console, or nil (meaning the selected frame)." - (memq (framep-on-display display) '(x ns gtk mswindows))) + (device-on-window-system-p display)) (defun display-images-p (&optional display) "Return non-nil if DISPLAY can display images. DISPLAY can be a frame, a device, a console, or nil (meaning the selected frame)." - (display-graphic-p display)) + (and (memq (image-instance-type (specifier-instance + (glyph-image xemacs-logo) + display)) + '(color-pixmap mono-pixmap)) + t)) (defalias 'display-multi-frame-p 'display-graphic-p) (defalias 'display-multi-font-p 'display-graphic-p) ＠＠ -1221,7 +1233,11 ＠＠ `clipboard'. DISPLAY can be a frame, a device, a console, or nil (meaning the selected frame)." - (memq (framep-on-display display) '(x ns gtk mswindows))) + (or + (device-on-window-system-p display) + ;; GPM supports #'get-selection-foreign, but not #'own-selection. + (and-fboundp 'gpm-is-supported-p + (gpm-is-supported-p display)))) (defun display-screens (&optional display) "Return the number of screens associated with DISPLAY." ＠＠ -1269,15 +1285,21 ＠＠ "Returns the visual class of DISPLAY. The value is one of the symbols `static-gray', `gray-scale', `static-color', `pseudo-color', `true-color', or `direct-color'." - (case (framep-on-display display) - (x (declare-fboundp (x-display-visual-class (display-device display)))) - (gtk (declare-fboundp (gtk-display-visual-class (display-device display)))) - (mswindows (let ((planes (display-planes display))) - (cond ((eq planes 1) 'static-gray) - ((eq planes 4) 'static-color) - ((> planes 8) 'true-color) - (t 'pseudo-color)))) - (t 'static-gray))) + (let (type planes) + (setq display (display-device display) + type (device-type display)) + (cond + ((eq 'x type) + (declare-fboundp (x-display-visual-class display))) + ((eq 'gtk type) + (declare-fboundp (gtk-display-visual-class display))) + ((device-on-window-system-p display) + (setq planes (display-planes display)) + (cond ((eq planes 1) 'static-gray) + ((eq planes 4) 'static-color) + ((> planes 8) 'true-color) + (t 'pseudo-color))) + (t 'static-gray))))  ;; XEmacs change: omit the Emacs 18 compatibility functions: -- ¿Dónde estará ahora mi sobrino Yoghurtu Nghé, que tuvo que huir precipitadamente de la aldea por culpa de la escasez de rinocerontes? _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches