-\f
-;;; non-X-specific interface
-
-(defun make-face-bold (face &optional frame noerror)
- "Make the font of the given face be bold, if possible.
-If NOERROR is non-nil, return nil on failure."
- (interactive (list (read-face-name "Make which face bold: ")))
- (if (and (eq frame t) (listp (face-font face t)))
- (set-face-font face (if (memq 'italic (face-font face t))
- '(bold italic) '(bold))
- t)
- (let (font)
- (if (null frame)
- (let ((frames (frame-list)))
- ;; Make this face bold in global-face-data.
- (make-face-bold face t noerror)
- ;; Make this face bold in each frame.
- (while frames
- (make-face-bold face (car frames) noerror)
- (setq frames (cdr frames))))
- (setq face (internal-get-face face frame))
- (setq font (or (face-font face frame)
- (face-font face t)))
- (if (listp font)
- (setq font nil))
- (setq font (or font
- (face-font 'default frame)
- (cdr (assq 'font (frame-parameters frame)))))
- (or (and font (make-face-bold-internal face frame font))
- ;; We failed to find a bold version of the font.
- noerror
- (error "No bold version of %S" font))))))
-
-(defun make-face-bold-internal (face frame font)
- (let (f2)
- (or (and (setq f2 (x-make-font-bold font))
- (internal-try-face-font face f2 frame))
- (and (setq f2 (x-make-font-demibold font))
- (internal-try-face-font face f2 frame)))))
-
-(defun make-face-italic (face &optional frame noerror)
- "Make the font of the given face be italic, if possible.
-If NOERROR is non-nil, return nil on failure."
- (interactive (list (read-face-name "Make which face italic: ")))
- (if (and (eq frame t) (listp (face-font face t)))
- (set-face-font face (if (memq 'bold (face-font face t))
- '(bold italic) '(italic))
- t)
- (let (font)
- (if (null frame)
- (let ((frames (frame-list)))
- ;; Make this face italic in global-face-data.
- (make-face-italic face t noerror)
- ;; Make this face italic in each frame.
- (while frames
- (make-face-italic face (car frames) noerror)
- (setq frames (cdr frames))))
- (setq face (internal-get-face face frame))
- (setq font (or (face-font face frame)
- (face-font face t)))
- (if (listp font)
- (setq font nil))
- (setq font (or font
- (face-font 'default frame)
- (cdr (assq 'font (frame-parameters frame)))))
- (or (and font (make-face-italic-internal face frame font))
- ;; We failed to find an italic version of the font.
- noerror
- (error "No italic version of %S" font))))))
-
-(defun make-face-italic-internal (face frame font)
- (let (f2)
- (or (and (setq f2 (x-make-font-italic font))
- (internal-try-face-font face f2 frame))
- (and (setq f2 (x-make-font-oblique font))
- (internal-try-face-font face f2 frame)))))
-
-(defun make-face-bold-italic (face &optional frame noerror)
- "Make the font of the given face be bold and italic, if possible.
-If NOERROR is non-nil, return nil on failure."
- (interactive (list (read-face-name "Make which face bold-italic: ")))
- (if (and (eq frame t) (listp (face-font face t)))
- (set-face-font face '(bold italic) t)
- (let (font)
- (if (null frame)
- (let ((frames (frame-list)))
- ;; Make this face bold-italic in global-face-data.
- (make-face-bold-italic face t noerror)
- ;; Make this face bold in each frame.
- (while frames
- (make-face-bold-italic face (car frames) noerror)
- (setq frames (cdr frames))))
- (setq face (internal-get-face face frame))
- (setq font (or (face-font face frame)
- (face-font face t)))
- (if (listp font)
- (setq font nil))
- (setq font (or font
- (face-font 'default frame)
- (cdr (assq 'font (frame-parameters frame)))))
- (or (and font (make-face-bold-italic-internal face frame font))
- ;; We failed to find a bold italic version.
- noerror
- (error "No bold italic version of %S" font))))))
-
-(defun make-face-bold-italic-internal (face frame font)
- (let (f2 f3)
- (or (and (setq f2 (x-make-font-italic font))
- (not (equal font f2))
- (setq f3 (x-make-font-bold f2))
- (not (equal f2 f3))
- (internal-try-face-font face f3 frame))
- (and (setq f2 (x-make-font-oblique font))
- (not (equal font f2))
- (setq f3 (x-make-font-bold f2))
- (not (equal f2 f3))
- (internal-try-face-font face f3 frame))
- (and (setq f2 (x-make-font-italic font))
- (not (equal font f2))
- (setq f3 (x-make-font-demibold f2))
- (not (equal f2 f3))
- (internal-try-face-font face f3 frame))
- (and (setq f2 (x-make-font-oblique font))
- (not (equal font f2))
- (setq f3 (x-make-font-demibold f2))
- (not (equal f2 f3))
- (internal-try-face-font face f3 frame)))))
-
-(defun make-face-unbold (face &optional frame noerror)
- "Make the font of the given face be non-bold, if possible.
-If NOERROR is non-nil, return nil on failure."
- (interactive (list (read-face-name "Make which face non-bold: ")))
- (if (and (eq frame t) (listp (face-font face t)))
- (set-face-font face (if (memq 'italic (face-font face t))
- '(italic) nil)
- t)
- (let (font font1)
- (if (null frame)
- (let ((frames (frame-list)))
- ;; Make this face unbold in global-face-data.
- (make-face-unbold face t noerror)
- ;; Make this face unbold in each frame.
- (while frames
- (make-face-unbold face (car frames) noerror)
- (setq frames (cdr frames))))
- (setq face (internal-get-face face frame))
- (setq font1 (or (face-font face frame)
- (face-font face t)))
- (if (listp font1)
- (setq font1 nil))
- (setq font1 (or font1
- (face-font 'default frame)
- (cdr (assq 'font (frame-parameters frame)))))
- (setq font (and font1 (x-make-font-unbold font1)))
- (or (if font (internal-try-face-font face font frame))
- noerror
- (error "No unbold version of %S" font1))))))
-
-(defun make-face-unitalic (face &optional frame noerror)
- "Make the font of the given face be non-italic, if possible.
-If NOERROR is non-nil, return nil on failure."
- (interactive (list (read-face-name "Make which face non-italic: ")))
- (if (and (eq frame t) (listp (face-font face t)))
- (set-face-font face (if (memq 'bold (face-font face t))
- '(bold) nil)
- t)
- (let (font font1)
- (if (null frame)
- (let ((frames (frame-list)))
- ;; Make this face unitalic in global-face-data.
- (make-face-unitalic face t noerror)
- ;; Make this face unitalic in each frame.
- (while frames
- (make-face-unitalic face (car frames) noerror)
- (setq frames (cdr frames))))
- (setq face (internal-get-face face frame))
- (setq font1 (or (face-font face frame)
- (face-font face t)))
- (if (listp font1)
- (setq font1 nil))
- (setq font1 (or font1
- (face-font 'default frame)
- (cdr (assq 'font (frame-parameters frame)))))
- (setq font (and font1 (x-make-font-unitalic font1)))
- (or (if font (internal-try-face-font face font frame))
- noerror
- (error "No unitalic version of %S" font1))))))
-\f
-(defvar list-faces-sample-text
- "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- "*Text string to display as the sample text for `list-faces-display'.")
-
-;; The name list-faces would be more consistent, but let's avoid a conflict
-;; with Lucid, which uses that name differently.
-(defun list-faces-display ()
- "List all faces, using the same sample text in each.
-The sample text is a string that comes from the variable
-`list-faces-sample-text'.
-
-It is possible to give a particular face name different appearances in
-different frames. This command shows the appearance in the
-selected frame."
- (interactive)
- (let ((faces (sort (face-list) (function string-lessp)))
- (face nil)
- (frame (selected-frame))
- disp-frame window)
- (with-output-to-temp-buffer "*Faces*"
- (save-excursion
- (set-buffer standard-output)
- (setq truncate-lines t)
- (while faces
- (setq face (car faces))
- (setq faces (cdr faces))
- (insert (format "%25s " (symbol-name face)))
- (let ((beg (point)))
- (insert list-faces-sample-text)
- (insert "\n")
- (put-text-property beg (1- (point)) 'face face)
- ;; If the sample text has multiple lines, line up all of them.
- (goto-char beg)
- (forward-line 1)
- (while (not (eobp))
- (insert " ")
- (forward-line 1))))
- (goto-char (point-min))))
- ;; If the *Faces* buffer appears in a different frame,
- ;; copy all the face definitions from FRAME,
- ;; so that the display will reflect the frame that was selected.
- (setq window (get-buffer-window (get-buffer "*Faces*") t))
- (setq disp-frame (if window (window-frame window)
- (car (frame-list))))
- (or (eq frame disp-frame)
- (let ((faces (face-list)))
- (while faces
- (copy-face (car faces) (car faces) frame disp-frame)
- (setq faces (cdr faces)))))))
-
-(defun describe-face (face)
- "Display the properties of face FACE."
- (interactive (list (read-face-name "Describe face: ")))
- (with-output-to-temp-buffer "*Help*"
- (princ "Properties of face `")
- (princ (face-name face))
- (princ "':") (terpri)
- (princ "Foreground: ") (princ (face-foreground face)) (terpri)
- (princ "Background: ") (princ (face-background face)) (terpri)
- (princ " Font: ") (princ (face-font face)) (terpri)
- (princ "Underlined: ") (princ (if (face-underline-p face) "yes" "no")) (terpri)
- (princ " Stipple: ") (princ (or (face-stipple face) "none")) (terpri)
- (terpri)
- (princ "Documentation:") (terpri)
- (let ((doc (face-doc-string face)))
- (if doc
- (princ doc)
- (princ "not documented as a face.")))))
-\f
-;;; Setting a face based on a SPEC.
-
-(defun face-spec-set (face spec &optional frame)
- "Set FACE's face attributes according to the first matching entry in SPEC.
-If optional FRAME is non-nil, set it for that frame only.
-If it is nil, then apply SPEC to each frame individually.
-See `defface' for information about SPEC."
- (let ((tail spec))
- (while tail
- (let* ((entry (car tail))
- (display (nth 0 entry))
- (attrs (nth 1 entry)))
- (setq tail (cdr tail))
- ;; If the font was set automatically, clear it out
- ;; to allow it to be set it again.
- (unless (face-font-explicit face frame)
- (set-face-font face nil frame))
- (modify-face face nil nil nil nil nil nil frame)
- (when (face-spec-set-match-display display frame)
- (face-spec-set-1 face frame attrs ':foreground 'set-face-foreground)
- (face-spec-set-1 face frame attrs ':background 'set-face-background)
- (face-spec-set-1 face frame attrs ':stipple 'set-face-stipple)
- (face-spec-set-1 face frame attrs ':bold 'set-face-bold-p)
- (face-spec-set-1 face frame attrs ':italic 'set-face-italic-p)
- (face-spec-set-1 face frame attrs ':underline 'set-face-underline-p)
- (face-spec-set-1 face frame attrs ':inverse-video
- 'set-face-inverse-video-p)
- (setq tail nil)))))
- (if (null frame)
- (let ((frames (frame-list))
- frame)
- (while frames
- (setq frame (car frames)
- frames (cdr frames))
- (face-spec-set face (or (get face 'saved-face)
- (get face 'face-defface-spec))
- frame)
- (face-spec-set face spec frame)))))
-
-(defun face-spec-set-1 (face frame plist property function)
- (while (and plist (not (eq (car plist) property)))
- (setq plist (cdr (cdr plist))))
- (if plist
- (funcall function face (nth 1 plist) frame)))
-
-(defun face-spec-set-match-display (display frame)
- "Non-nil iff DISPLAY matches FRAME.
-DISPLAY is part of a spec such as can be used in `defface'.
-If FRAME is nil, the current FRAME is used."
- (let* ((conjuncts display)
- conjunct req options
- ;; t means we have succeeded against all
- ;; the conjunts in DISPLAY that have been tested so far.
- (match t))
- (if (eq conjuncts t)
- (setq conjuncts nil))
- (while (and conjuncts match)
- (setq conjunct (car conjuncts)
- conjuncts (cdr conjuncts)
- req (car conjunct)
- options (cdr conjunct)
- match (cond ((eq req 'type)
- (memq window-system options))
- ((eq req 'class)
- (memq (frame-parameter frame 'display-type) options))
- ((eq req 'background)
- (memq (frame-parameter frame 'background-mode)
- options))
- (t
- (error "Unknown req `%S' with options `%S'"
- req options)))))
- match))
-\f
-;; Like x-create-frame but also set up the faces.
-
-(defun x-create-frame-with-faces (&optional parameters)
- ;; Read this frame's geometry resource, if it has an explicit name,
- ;; and put the specs into PARAMETERS.
- (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"))))
- (if res-geometry
- (let ((parsed (x-parse-geometry res-geometry)))
- ;; If the resource specifies a position,
- ;; call the position and size "user-specified".
- (if (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)))))
- (let (frame)
- (if (null global-face-data)
- (progn
- (setq frame (x-create-frame parameters))
- (frame-set-background-mode frame))
- (let* ((visibility-spec (assq 'visibility parameters))
- success faces rest)
- (setq frame (x-create-frame (cons '(visibility . nil) parameters)))
- (unwind-protect
- (progn
- ;; Copy the face alist, copying the face vectors
- ;; and emptying out their attributes.
- (setq faces
- (mapcar '(lambda (elt)
- (cons (car elt)
- (vector 'face
- (face-name (cdr elt))
- (face-id (cdr elt))
- nil nil nil nil nil nil nil)))
- global-face-data))
- (set-frame-face-alist frame faces)
-
- ;; Handle the reverse-video frame parameter
- ;; and X resource. x-create-frame does not handle this one.
- (if (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)
- (let ((resource (x-get-resource "reverseVideo"
- "ReverseVideo")))
- (if resource
- (cons nil (member (downcase resource)
- '("on" "true")))))))
- (let* ((params (frame-parameters frame))
- (bg (cdr (assq 'foreground-color params)))
- (fg (cdr (assq 'background-color params))))
- (modify-frame-parameters frame
- (list (cons 'foreground-color fg)
- (cons 'background-color bg)))
- (if (equal bg (cdr (assq 'border-color params)))
- (modify-frame-parameters frame
- (list (cons 'border-color fg))))
- (if (equal bg (cdr (assq 'mouse-color params)))
- (modify-frame-parameters frame
- (list (cons 'mouse-color fg))))
- (if (equal bg (cdr (assq 'cursor-color params)))
- (modify-frame-parameters frame
- (list (cons 'cursor-color fg))))))
-
- (frame-set-background-mode frame)
-
- (face-set-after-frame-default frame)
-
- ;; Make the frame visible, if desired.
- (if (null visibility-spec)
- (make-frame-visible frame)
- (modify-frame-parameters frame (list visibility-spec)))
- (setq success t))
- (or success
- (delete-frame frame)))))
- frame))
-
-;; Update a frame's faces after the frame font changes.
-;; This is called from modify-frame-parameters
-;; as well as from elsewhere in this file.
-(defun face-set-after-frame-default (frame)
- (let ((rest (frame-face-alist frame)))
- (while rest
- ;; Set up each face, first from the defface information,
- ;; then the global face data, and then the X resources.
- (let* ((face (car (car rest)))
- (spec (or (get face 'saved-face)
- (get face 'face-defface-spec)))
- (global (cdr (assq face global-face-data)))
- (local (cdr (car rest))))
- (when spec
- (face-spec-set face spec frame))
- (face-fill-in face global frame)
- (make-face-x-resource-internal local frame))
- (setq rest (cdr rest)))))