* tinycustom.el (custom-declare-face): New function.

(defface): Use it.

diff --git a/ChangeLog b/ChangeLog
index eb7f1ce..10ca700 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2001-12-05  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+       * tinycustom.el (custom-declare-face): New function.
+       (defface): Use it.
+
 2001-10-15  Katsumi Yamaoka  <yamaoka@jpl.org>
 
        * poe.el (format-time-string): Support the 3rd arg `universal'.

diff --git a/tinycustom.el b/tinycustom.el
index 3d32c00..5646036 100644 (file)
--- a/tinycustom.el
+++ b/tinycustom.el
@@ -29,7 +29,7 @@
 ;; (custom.el bundled with v19 is old; does not have following macros.)
 ;;
 ;; DEFCUSTOM below has the same effect as the original DEFVAR has.
-;; DEFFACE below interprets almost of all arguments.
+;; DEFFACE below interprets almost all arguments.
 ;; DEFGROUP and DEFINE-WIDGET below are just nop macro.
 
 ;;; Code:
@@ -59,14 +59,68 @@ your background is light, or nil (default) if you want Emacs to
 examine the brightness for you.  However, the old Emacsen might not
 examine the brightness, so you should set this value definitely.")
 
-(defmacro-maybe-cond defface (face spec doc &rest args)
+(defun-maybe-cond custom-declare-face (face spec doc &rest args)
+  "Like `defface', but FACE is evaluated as a normal argument.
+Note that this function does not have the full specification; DOC or
+ARGS are ignored and some keywords are ignored in SPEC except for
+`:foreground', `:background', `:bold', `:italic' and `:underline'.
+It does nothing if FACE has been defined."
+  ((fboundp 'make-face)
+   (or (find-face face)
+       (let ((colorp (and window-system (x-display-color-p)))
+            display atts req item match done)
+        (make-face face)
+        (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 'type req)
+                          (setq match (or (eq window-system item)
+                                          (and (not window-system)
+                                               (eq 'tty item)))))
+                         ((eq 'class req)
+                          (setq match (or (and colorp
+                                               (eq 'color item))
+                                          (and (not colorp)
+                                               (memq item
+                                                     '(grayscale mono))))))
+                         ((eq 'background req)
+                          (setq match (eq (or frame-background-mode 'light)
+                                          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
+   nil))
+
+(defmacro-maybe defface (face spec doc &rest args)
   "Declare FACE as a customizable face that defaults to SPEC.
 FACE does not need to be quoted.
 
-Third argument DOC is the face documentation, it is ignored.
+Third argument DOC is the face documentation.
 
-It does nothing if FACE has been bound, otherwise set the face
-attributes according to SPEC.
+If FACE has been set with `custom-set-face', set the face attributes
+as specified by that function, otherwise set the face attributes
+according to SPEC.
 
 The remaining arguments should have the form
 
@@ -74,13 +128,13 @@ The remaining arguments should have the form
 
 The following KEYWORDs are defined:
 
-:group  VALUE should be a customization group, but it is ignored.
+:group  VALUE should be a customization group.
+        Add FACE to that group.
 
 SPEC should be an alist of the form ((DISPLAY ATTS)...).
 
-ATTS is of the form (KEY VALUE) where KEY is a symbol of `:foreground',
-`:background', `:bold', `:italic' or `:underline'.  The other KEYs are
-ignored.
+ATTS is a list of face attributes and their values.  The possible
+attributes are defined in the variable `custom-face-attributes'.
 
 The ATTS of the first entry in SPEC where the DISPLAY matches the
 frame should take effect in that frame.  DISPLAY can either be the
@@ -96,57 +150,20 @@ match one of the ITEM.  The following REQ are defined:
 `class' (the frame's color support)
   Should be one of `color', `grayscale', or `mono'.
 
-`background' (the value of `frame-background-mode', what color is used
-for the background text)
-  Should be one of `light' or `dark'."
-  ((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 'type req)
-                  (setq match (or (eq window-system item)
-                                  (and (not window-system)
-                                       (eq 'tty item)))))
-                 ((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
-   nil ;; do nothing.
-   ))
+`background' (what color is used for the background text)
+  Should be one of `light' or `dark'.
+
+Read the section about customization in the Emacs Lisp manual for more
+information."
+  (nconc (list 'custom-declare-face (list 'quote face) spec doc)
+        ;; Quote colon keywords.
+        (let (rest)
+          (while args
+            (setq rest (cons (list 'quote (car args)) rest)
+                  args (cdr args)
+                  rest (cons (car args) rest)
+                  args (cdr args)))
+          (nreverse rest))))
 
 (defmacro-maybe define-widget (name class doc &rest args)
   "Define a new widget type named NAME from CLASS.