From: yamaoka <yamaoka>
Date: Fri, 3 Sep 1999 12:32:57 +0000 (+0000)
Subject: (defface): Set the face attributes according to SPEC.
X-Git-Tag: apel-9_22~13
X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fapel.git;a=commitdiff_plain;h=fbcf20b160239af2b3eb72ac2b49101f25001457

(defface): Set the face attributes according to SPEC.
---

diff --git a/tinycustom.el b/tinycustom.el
index 0a19686..921bdbe 100644
--- a/tinycustom.el
+++ b/tinycustom.el
@@ -52,15 +52,53 @@ This is a defcustom only for emulating purpose.
 Its effect is just as same as that of defvar."
   (` (defvar (, symbol) (, value) (, doc))))
     
-(defmacro-maybe-cond defface (face value doc &rest args) 
-      "Declare FACE as a customizable face that defaults to SPEC.
-FACE does not need to be quoted.
-\[custom emulating macro]"
-      ((fboundp 'make-face)
-       (` (make-face (quote (, face)))))
-      (t
-       ;; do nothing.
-       ))
+(defmacro-maybe-cond defface (face spec doc &rest args)
+  "Declare FACE as a customizable face that defaults to SPEC.
+FACE does not need to be quoted.  [custom emulating macro]"
+  ((fboundp 'make-face)
+   (` (let ((name (quote (, face))))
+	(or
+	 (find-face name)
+	 (let ((face (make-face name))
+	       (spec (, spec))
+	       (colorp (and window-system (x-display-color-p)))
+	       display atts req item match done)
+	   (while (and spec (not done))
+	     (setq display (car (car spec))
+		   atts (car (cdr (car spec)))
+		   spec (cdr spec))
+	     (cond
+	      ((consp display)
+	       (setq match t)
+	       (while (and display match)
+		 (setq req (car (car display))
+		       item (car (cdr (car display)))
+		       display (cdr display))
+		 (cond
+		  ((eq 'class req)
+		   (setq match (or (and colorp (eq 'color item))
+				   (and (not colorp)
+					(memq item '(grayscale mono))))))
+		  ((eq 'background req)
+		   (setq match (eq frame-background-mode item)))))
+	       (setq done match))
+	      ((eq t display)
+	       (setq done t))))
+	   (if done
+	       (let ((alist '((:foreground . set-face-foreground)
+			      (:background . set-face-background)
+			      (:bold . set-face-bold-p)
+			      (:italic . set-face-italic-p)
+			      (:underline . set-face-underline-p)))
+		     function)
+		 (while atts
+		   (if (setq function (cdr (assq (car atts) alist)))
+		       (funcall function face (car (cdr atts))))
+		   (setq atts (cdr (cdr atts))))))
+	   face)))))
+  (t
+   ;; do nothing.
+   ))
 
 (defmacro-maybe define-widget (name class doc &rest args)
   "Define a new widget type named NAME from CLASS.