+ ;; 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")))
+ parsed)
+ (if res-geometry
+ (progn
+ (setq 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 (cons '(user-position . t)
+ (cons '(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)
+ (setq frame (x-create-frame parameters))
+ (let* ((visibility-spec (assq 'visibility parameters))
+ (faces (copy-alist global-face-data))
+ success
+ (rest faces))
+ (setq frame (x-create-frame (cons '(visibility . nil) parameters)))
+ (unwind-protect
+ (progn
+ (set-frame-face-alist frame faces)
+
+ (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))))))
+ ;; Copy the vectors that represent the faces.
+ ;; Also fill them in from X resources.
+ (while rest
+ (let ((global (cdr (car rest))))
+ (setcdr (car rest) (vector 'face
+ (face-name (cdr (car rest)))
+ (face-id (cdr (car rest)))
+ nil nil nil nil nil))
+ (face-fill-in (car (car rest)) global frame))
+ (make-face-x-resource-internal (cdr (car rest)) frame t)
+ (setq rest (cdr rest)))
+ (if (null visibility-spec)
+ (make-frame-visible frame)
+ (modify-frame-parameters frame (list visibility-spec)))
+ (setq success t))
+ (or success
+ (delete-frame frame)))))
+ ;; Set up the background-mode frame parameter
+ ;; so that programs can decide good ways of highlighting
+ ;; on this frame.
+ (let ((bg-resource (x-get-resource ".backgroundMode"
+ "BackgroundMode"))
+ (params (frame-parameters frame))
+ (bg-mode))
+ (setq bg-mode
+ (cond (bg-resource (intern (downcase bg-resource)))
+ ((< (apply '+ (x-color-values
+ (cdr (assq 'background-color params))
+ frame))
+ (/ (apply '+ (x-color-values "white" frame)) 3))
+ 'dark)
+ (t 'light)))
+ (modify-frame-parameters frame
+ (list (cons 'background-mode bg-mode)
+ (cons 'display-type
+ (cond ((x-display-color-p frame)
+ 'color)
+ ((x-display-grayscale-p frame)
+ 'grayscale)
+ (t 'mono))))))
+ frame))
+
+;; Update a frame's faces when we change its default font.
+(defun frame-update-faces (frame)
+ (let* ((faces global-face-data)
+ (rest faces))
+ (while rest
+ (let* ((face (car (car rest)))
+ (font (face-font face t)))
+ (if (listp font)
+ (let ((bold (memq 'bold font))
+ (italic (memq 'italic font)))
+ ;; Ignore any previous (string-valued) font, it might not even
+ ;; be the right size anymore.
+ (set-face-font face nil frame)
+ (cond ((and bold italic)
+ (make-face-bold-italic face frame t))
+ (bold
+ (make-face-bold face frame t))
+ (italic
+ (make-face-italic face frame t)))))
+ (setq rest (cdr rest)))
+ frame)))
+
+;; Update the colors of FACE, after FRAME's own colors have been changed.
+;; This applies only to faces with global color specifications
+;; that are not simple constants.
+(defun frame-update-face-colors (frame)
+ (let ((faces global-face-data))
+ (while faces
+ (condition-case nil
+ (let* ((data (cdr (car faces)))
+ (face (car (car faces)))
+ (foreground (face-foreground data))
+ (background (face-background data)))
+ ;; If the global spec is a specific color,
+ ;; which doesn't depend on the frame's attributes,
+ ;; we don't need to recalculate it now.
+ (or (listp foreground)
+ (setq foreground nil))
+ (or (listp background)
+ (setq background nil))
+ ;; If we are going to frob this face at all,
+ ;; reinitialize it first.
+ (if (or foreground background)
+ (progn (set-face-foreground face nil frame)
+ (set-face-background face nil frame)))
+ (if foreground
+ (face-try-color-list 'set-face-foreground
+ face foreground frame))
+ (if background
+ (face-try-color-list 'set-face-background
+ face background frame)))
+ (error nil))
+ (setq faces (cdr faces)))))
+
+;; Fill in the face FACE from frame-independent face data DATA.
+;; DATA should be the non-frame-specific ("global") face vector
+;; for the face. FACE should be a face name or face object.
+;; FRAME is the frame to act on; it must be an actual frame, not nil or t.
+(defun face-fill-in (face data frame)
+ (condition-case nil
+ (let ((foreground (face-foreground data))
+ (background (face-background data))
+ (font (face-font data))
+ (stipple (face-stipple data)))
+ (set-face-underline-p face (face-underline-p data) frame)
+ (if foreground
+ (face-try-color-list 'set-face-foreground
+ face foreground frame))
+ (if background
+ (face-try-color-list 'set-face-background
+ face background frame))
+ (if (listp font)
+ (let ((bold (memq 'bold font))
+ (italic (memq 'italic font)))
+ (cond ((and bold italic)
+ (make-face-bold-italic face frame))
+ (bold
+ (make-face-bold face frame))
+ (italic
+ (make-face-italic face frame))))
+ (if font
+ (set-face-font face font frame)))
+ (if stipple
+ (set-face-stipple face stipple frame)))
+ (error nil)))
+
+;; Assuming COLOR is a valid color name,
+;; return t if it can be displayed on FRAME.
+(defun face-color-supported-p (frame color background-p)
+ (and window-system
+ (or (x-display-color-p frame)
+ ;; A black-and-white display can implement these.
+ (member color '("black" "white"))
+ ;; A black-and-white display can fake gray for background.
+ (and background-p
+ (face-color-gray-p color frame))
+ ;; A grayscale display can implement colors that are gray (more or less).
+ (and (x-display-grayscale-p frame)
+ (face-color-gray-p color frame)))))
+
+;; Use FUNCTION to store a color in FACE on FRAME.
+;; COLORS is either a single color or a list of colors.
+;; If it is a list, try the colors one by one until one of them
+;; succeeds. We signal an error only if all the colors failed.
+;; t as COLORS or as an element of COLORS means to invert the face.
+;; That can't fail, so any subsequent elements after the t are ignored.
+(defun face-try-color-list (function face colors frame)
+ (if (stringp colors)
+ (if (face-color-supported-p frame colors
+ (eq function 'set-face-background))
+ (funcall function face colors frame))
+ (if (eq colors t)
+ (invert-face face frame)
+ (let (done)
+ (while (and colors (not done))
+ (if (or (memq (car colors) '(t underline))
+ (face-color-supported-p frame (car colors)
+ (eq function 'set-face-background)))
+ (if (cdr colors)
+ ;; If there are more colors to try, catch errors
+ ;; and set `done' if we succeed.
+ (condition-case nil
+ (progn
+ (cond ((eq (car colors) t)
+ (invert-face face frame))
+ ((eq (car colors) 'underline)
+ (set-face-underline-p face t frame))
+ (t
+ (funcall function face (car colors) frame)))
+ (setq done t))
+ (error nil))
+ ;; If this is the last color, let the error get out if it fails.
+ ;; If it succeeds, we will exit anyway after this iteration.
+ (cond ((eq (car colors) t)
+ (invert-face face frame))
+ ((eq (car colors) 'underline)
+ (set-face-underline-p face t frame))
+ (t
+ (funcall function face (car colors) frame)))))
+ (setq colors (cdr colors)))))))