X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/311a84c06b6ebca702475d69fba0406127b98e55..b336bfcdf39f1e4d35bff4a7bd01d3b4bca8f516:/lisp/faces.el diff --git a/lisp/faces.el b/lisp/faces.el index bbc7d32e3a..900e96ed04 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1,7 +1,8 @@ ;;; faces.el --- Lisp faces ;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. +;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal @@ -69,10 +70,11 @@ a font height that isn't optimal." ;; unavailable, and we fall back on the courier and helv families, ;; which are generally available. (defcustom face-font-family-alternatives + (mapcar (lambda (arg) (mapcar 'purecopy arg)) '(("Monospace" "courier" "fixed") ("courier" "CMU Typewriter Text" "fixed") ("Sans Serif" "helv" "helvetica" "arial" "fixed") - ("helv" "helvetica" "arial" "fixed")) + ("helv" "helvetica" "arial" "fixed"))) "Alist of alternative font family names. Each element has the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...). If fonts of family FAMILY can't be loaded, try ALTERNATIVE1, then @@ -87,6 +89,7 @@ ALTERNATIVE2 etc." ;; This is defined originally in xfaces.c. (defcustom face-font-registry-alternatives + (mapcar (lambda (arg) (mapcar 'purecopy arg)) (if (eq system-type 'windows-nt) '(("iso8859-1" "ms-oemlatin") ("gb2312.1980" "gb2312" "gbk" "gb18030") @@ -96,7 +99,7 @@ ALTERNATIVE2 etc." '(("gb2312.1980" "gb2312.80&gb8565.88" "gbk" "gb18030") ("jisx0208.1990" "jisx0208.1983" "jisx0208.1978") ("ksc5601.1989" "ksx1001.1992" "ksc5601.1987") - ("muletibetan-2" "muletibetan-0"))) + ("muletibetan-2" "muletibetan-0")))) "Alist of alternative font registry names. Each element has the form (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...). If fonts of registry REGISTRY can be loaded, font selection @@ -283,6 +286,11 @@ If FRAME is omitted or nil, use the selected frame." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom face-x-resources + (mapcar + (lambda (arg) + ;; FIXME; can we purecopy some of the conses too? + (cons (car arg) + (cons (purecopy (car (cdr arg))) (purecopy (cdr (cdr arg)))))) '((:family (".attributeFamily" . "Face.AttributeFamily")) (:foundry (".attributeFoundry" . "Face.AttributeFoundry")) (:width (".attributeWidth" . "Face.AttributeWidth")) @@ -302,7 +310,7 @@ If FRAME is omitted or nil, use the selected frame." (:bold (".attributeBold" . "Face.AttributeBold")) (:italic (".attributeItalic" . "Face.AttributeItalic")) (:font (".attributeFont" . "Face.AttributeFont")) - (:inherit (".attributeInherit" . "Face.AttributeInherit"))) + (:inherit (".attributeInherit" . "Face.AttributeInherit")))) "List of X resources and classes for face attributes. Each element has the form (ATTRIBUTE ENTRY1 ENTRY2...) where ATTRIBUTE is the name of a face attribute, and each ENTRY is a cons of the form @@ -338,7 +346,7 @@ specifies an invalid attribute." (defun set-face-attributes-from-resources (face frame) "Set attributes of FACE from X resources for FRAME." - (when (memq (framep frame) '(x w32 ns)) + (when (memq (framep frame) '(x w32)) (dolist (definition face-x-resources) (let ((attribute (car definition))) (dolist (entry (cdr definition)) @@ -552,7 +560,7 @@ If FACE is a face-alias, get the documentation for the target face." (if alias (progn (setq doc (get alias 'face-documentation)) - (format "%s is an alias for the face `%s'.%s" face alias + (format "%s is an alias for the face `%s'.%s" face alias (if doc (format "\n%s" doc) ""))) (get face 'face-documentation)))) @@ -582,7 +590,7 @@ the default for new frames (this is done automatically each time an attribute is changed on all frames). ARGS must come in pairs ATTRIBUTE VALUE. ATTRIBUTE must be a valid -face attribute name. All attributes can be set to `unspecified'; +face attribute name. All attributes can be set to `unspecified'; this fact is not further mentioned below. The following attributes are recognized: @@ -725,12 +733,12 @@ like an underlying face would be, with higher priority than underlying faces." (when (and (stringp family) (string-match "\\([^-]*\\)-\\([^-]*\\)" family)) (unless foundry - (setq foundry (match-string 2 family))) - (setq family (match-string 1 family))) - (when (stringp family) + (setq foundry (match-string 1 family))) + (setq family (match-string 2 family))) + (when (or (stringp family) (eq family 'unspecified)) (internal-set-lisp-face-attribute face :family (purecopy family) where)) - (when (stringp foundry) + (when (or (stringp foundry) (eq foundry 'unspecified)) (internal-set-lisp-face-attribute face :foundry (purecopy foundry) where))) (while args @@ -980,9 +988,9 @@ Otherwise, return a single face." (defun face-valid-attribute-values (attribute &optional frame) "Return valid values for face attribute ATTRIBUTE. The optional argument FRAME is used to determine available fonts -and colors. If it is nil or not specified, the selected frame is -used. Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value -out of a set of discrete values. Value is `integerp' if ATTRIBUTE expects +and colors. If it is nil or not specified, the selected frame is used. +Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value out +of a set of discrete values. Value is `integerp' if ATTRIBUTE expects an integer value." (let ((valid (case attribute @@ -1020,7 +1028,7 @@ an integer value." ((:height) 'integerp) (:stipple - (and (memq (window-system frame) '(x w32 ns)) + (and (memq (window-system frame) '(x ns)) ; No stipple on w32 (mapcar #'list (apply #'nconc (mapcar (lambda (dir) @@ -1039,7 +1047,7 @@ an integer value." valid))) -(defvar face-attribute-name-alist +(defconst face-attribute-name-alist '((:family . "font family") (:foundry . "font foundry") (:width . "character set width") @@ -1227,7 +1235,7 @@ Value is a list (FACE NEW-VALUE) where FACE is the face read ;;; Listing faces. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar list-faces-sample-text +(defconst list-faces-sample-text "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ" "*Text string to display as the sample text for `list-faces-display'.") @@ -1265,8 +1273,7 @@ arg, prompt for a regular expression." (setq max-length (1+ max-length) line-format (format "%%-%ds" max-length)) (with-help-window "*Faces*" - (save-excursion - (set-buffer standard-output) + (with-current-buffer standard-output (setq truncate-lines t) (insert (substitute-command-keys @@ -1347,56 +1354,79 @@ If FRAME is omitted or nil, use the selected frame." (:inherit . "Inherit"))) (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x))) attrs)))) - (help-setup-xref (list #'describe-face face) (interactive-p)) + (help-setup-xref (list #'describe-face face) + (called-interactively-p 'interactive)) (unless face (setq face 'default)) (if (not (listp face)) (setq face (list face))) (with-help-window (help-buffer) - (save-excursion - (set-buffer standard-output) + (with-current-buffer standard-output (dolist (f face) (if (stringp f) (setq f (intern f))) - (insert "Face: " (symbol-name f)) - (if (not (facep f)) - (insert " undefined face.\n") - (let ((customize-label "customize this face") - file-name) - (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) - (princ (concat " (" customize-label ")\n")) - (insert "Documentation: " - (or (face-documentation f) - "Not documented as a face.") - "\n") - (with-current-buffer standard-output - (save-excursion - (re-search-backward - (concat "\\(" customize-label "\\)") nil t) - (help-xref-button 1 'help-customize-face f))) - (setq file-name (find-lisp-object-file-name f 'defface)) - (when file-name - (princ "Defined in `") - (princ (file-name-nondirectory file-name)) - (princ "'") - ;; Make a hyperlink to the library. - (save-excursion - (re-search-backward "`\\([^`']+\\)'" nil t) - (help-xref-button 1 'help-face-def f file-name)) - (princ ".") - (terpri) - (terpri)) - (dolist (a attrs) - (let ((attr (face-attribute f (car a) frame))) - (insert (make-string (- max-width (length (cdr a))) ?\s) - (cdr a) ": " (format "%s" attr)) - (if (and (eq (car a) :inherit) - (not (eq attr 'unspecified))) - ;; Make a hyperlink to the parent face. - (save-excursion - (re-search-backward ": \\([^:]+\\)" nil t) - (help-xref-button 1 'help-face attr))) - (insert "\n"))))) - (terpri)))))) + ;; We may get called for anonymous faces (i.e., faces + ;; expressed using prop-value plists). Those can't be + ;; usefully customized, so ignore them. + (when (symbolp f) + (insert "Face: " (symbol-name f)) + (if (not (facep f)) + (insert " undefined face.\n") + (let ((customize-label "customize this face") + file-name) + (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) + (princ (concat " (" customize-label ")\n")) + ;; FIXME not sure how much of this belongs here, and + ;; how much in `face-documentation'. The latter is + ;; not used much, but needs to return nil for + ;; undocumented faces. + (let ((alias (get f 'face-alias)) + (face f) + obsolete) + (when alias + (setq face alias) + (insert + (format "\n %s is an alias for the face `%s'.\n%s" + f alias + (if (setq obsolete (get f 'obsolete-face)) + (format " This face is obsolete%s; use `%s' instead.\n" + (if (stringp obsolete) + (format " since %s" obsolete) + "") + alias) + "")))) + (insert "\nDocumentation:\n" + (or (face-documentation face) + "Not documented as a face.") + "\n\n")) + (with-current-buffer standard-output + (save-excursion + (re-search-backward + (concat "\\(" customize-label "\\)") nil t) + (help-xref-button 1 'help-customize-face f))) + (setq file-name (find-lisp-object-file-name f 'defface)) + (when file-name + (princ "Defined in `") + (princ (file-name-nondirectory file-name)) + (princ "'") + ;; Make a hyperlink to the library. + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-face-def f file-name)) + (princ ".") + (terpri) + (terpri)) + (dolist (a attrs) + (let ((attr (face-attribute f (car a) frame))) + (insert (make-string (- max-width (length (cdr a))) ?\s) + (cdr a) ": " (format "%s" attr)) + (if (and (eq (car a) :inherit) + (not (eq attr 'unspecified))) + ;; Make a hyperlink to the parent face. + (save-excursion + (re-search-backward ": \\([^:]+\\)" nil t) + (help-xref-button 1 'help-face attr))) + (insert "\n"))))) + (terpri))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1843,28 +1873,22 @@ according to the `background-mode' and `display-type' frame parameters." (bg-color (frame-parameter frame 'background-color)) (terminal-bg-mode (terminal-parameter frame 'background-mode)) (tty-type (tty-type frame)) + (default-bg-mode + (if (or (window-system frame) + (and tty-type + (string-match "^\\(xterm\\|\\rxvt\\|dtterm\\|eterm\\)" + tty-type))) + 'light + 'dark)) + (non-default-bg-mode (if (eq default-bg-mode 'light) 'dark 'light)) (bg-mode (cond (frame-background-mode) (bg-resource (intern (downcase bg-resource))) (terminal-bg-mode) - ((and (null (window-system frame)) - ;; Unspecified frame background color can only - ;; happen on tty's. - (member bg-color '(nil unspecified "unspecified-bg"))) - ;; There is no way to determine the background mode - ;; automatically, so we make a guess based on the - ;; terminal type. - (if (and tty-type - (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)" - tty-type)) - 'light - 'dark)) ((equal bg-color "unspecified-fg") ; inverted colors - (if (and tty-type - (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)" - tty-type)) - 'dark - 'light)) + non-default-bg-mode) + ((not (color-values bg-color frame)) + default-bg-mode) ((>= (apply '+ (color-values bg-color frame)) ;; Just looking at the screen, colors whose ;; values add up to .6 of the white total @@ -1923,21 +1947,25 @@ according to the `background-mode' and `display-type' frame parameters." (defun x-handle-named-frame-geometry (parameters) "Add geometry parameters for a named frame to parameter list PARAMETERS. Value is the new parameter list." - (let* ((name (or (cdr (assq 'name parameters)) - (cdr (assq 'name default-frame-alist)))) - (x-resource-name name) - (res-geometry (if name (x-get-resource "geometry" "Geometry")))) - (when res-geometry - (let ((parsed (x-parse-geometry res-geometry))) - ;; If the resource specifies a position, call the position - ;; and size "user-specified". - (when (or (assq 'top parsed) - (assq 'left parsed)) - (setq parsed (append '((user-position . t) (user-size . t)) parsed))) - ;; Put the geometry parameters at the end. Copy - ;; default-frame-alist so that they go after it. - (setq parameters (append parameters default-frame-alist parsed)))) - parameters)) + ;; Note that `x-resource-name' has a global meaning. + (let ((x-resource-name (or (cdr (assq 'name parameters)) + (cdr (assq 'name default-frame-alist))))) + (when x-resource-name + ;; Before checking X resources, we must have an X connection. + (or (window-system) + (x-display-list) + (x-open-connection (or (cdr (assq 'display parameters)) + x-display-name))) + (let (res-geometry parsed) + (and (setq res-geometry (x-get-resource "geometry" "Geometry")) + (setq parsed (x-parse-geometry res-geometry)) + (setq parameters + (append parameters default-frame-alist parsed + ;; If the resource specifies a position, + ;; take note of that. + (if (or (assq 'top parsed) (assq 'left parsed)) + '((user-position . t) (user-size . t))))))))) + parameters) (defun x-handle-reverse-video (frame parameters) @@ -2008,7 +2036,7 @@ Calculate the face definitions using the face specs, custom theme settings, X resources, and `face-new-frame-defaults'. Finally, apply any relevant face attributes found amongst the frame parameters in PARAMETERS and `default-frame-alist'." - (dolist (face (nreverse (face-list))) + (dolist (face (nreverse (face-list))) ;Why reverse? --Stef (condition-case () (progn ;; Initialize faces from face spec and custom theme. @@ -2016,7 +2044,7 @@ frame parameters in PARAMETERS and `default-frame-alist'." ;; X resouces for the default face are applied during ;; x-create-frame. (and (not (eq face 'default)) - (memq (window-system frame) '(x w32 ns)) + (memq (window-system frame) '(x w32)) (make-face-x-resource-internal face frame)) ;; Apply attributes specified by face-new-frame-defaults (internal-merge-in-global-face face frame)) @@ -2136,7 +2164,7 @@ terminal type to a different value." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Compatiblity with 20.2 +;;; Compatibility with 20.2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Update a frame's faces when we change its default font. @@ -2256,9 +2284,14 @@ terminal type to a different value." "Basic face for highlighting." :group 'basic-faces) +;; Region face: under NS, default to the system-defined selection +;; color (optimized for the fixed white background of other apps), +;; if background is light. (defface region '((((class color) (min-colors 88) (background dark)) :background "blue3") + (((class color) (min-colors 88) (background light) (type ns)) + :background "ns_selection_color") (((class color) (min-colors 88) (background light)) :background "lightgoldenrod2") (((class color) (min-colors 16) (background dark)) @@ -2336,6 +2369,8 @@ terminal type to a different value." :version "21.1" :group 'mode-line-faces :group 'basic-faces) +;; No need to define aliases of this form for new faces. +(define-obsolete-face-alias 'modeline 'mode-line "21.1") (defface mode-line-inactive '((default @@ -2352,6 +2387,7 @@ terminal type to a different value." :version "22.1" :group 'mode-line-faces :group 'basic-faces) +(define-obsolete-face-alias 'modeline-inactive 'mode-line-inactive "22.1") (defface mode-line-highlight '((((class color) (min-colors 88)) @@ -2362,6 +2398,7 @@ terminal type to a different value." :version "22.1" :group 'mode-line-faces :group 'basic-faces) +(define-obsolete-face-alias 'modeline-highlight 'mode-line-highlight "22.1") (defface mode-line-emphasis '((t (:weight bold))) @@ -2377,12 +2414,7 @@ Use the face `mode-line-highlight' for features that can be selected." :version "22.1" :group 'mode-line-faces :group 'basic-faces) - -;; Make `modeline' an alias for `mode-line', for compatibility. -(put 'modeline 'face-alias 'mode-line) -(put 'modeline-inactive 'face-alias 'mode-line-inactive) -(put 'modeline-highlight 'face-alias 'mode-line-highlight) -(put 'modeline-buffer-id 'face-alias 'mode-line-buffer-id) +(define-obsolete-face-alias 'modeline-buffer-id 'mode-line-buffer-id "22.1") (defface header-line '((default @@ -2504,6 +2536,9 @@ Note: Other faces cannot inherit from the cursor face." :group 'menu :group 'basic-faces) +(defface help-argument-name '((((supports :slant italic)) :inherit italic)) + "Face to highlight argument names in *Help* buffers." + :group 'help) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Manipulating font names. @@ -2548,16 +2583,16 @@ Note: Other faces cannot inherit from the cursor face." (encoding "[^-]+") ) (setq x-font-regexp - (concat "\\`\\*?[-?*]" + (purecopy (concat "\\`\\*?[-?*]" foundry - family - weight\? - slant\? - swidth - adstyle - pixelsize - pointsize - resx - resy - spacing - avgwidth - registry - encoding "\\*?\\'" - )) + ))) (setq x-font-regexp-head - (concat "\\`[-?*]" foundry - family - weight\? - slant\? - "\\([-*?]\\|\\'\\)")) - (setq x-font-regexp-slant (concat - slant -)) - (setq x-font-regexp-weight (concat - weight -)) + (purecopy (concat "\\`[-?*]" foundry - family - weight\? - slant\? + "\\([-*?]\\|\\'\\)"))) + (setq x-font-regexp-slant (purecopy (concat - slant -))) + (setq x-font-regexp-weight (purecopy (concat - weight -))) nil)