This commit was generated by cvs2svn to compensate for changes in r5057,

[chise/xemacs-chise.git.1] / lisp / faces.el

diff --git a/lisp/faces.el b/lisp/faces.el
index 953025b..4e34298 100644 (file)
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -761,7 +761,10 @@ See `face-property-instance' for the semantics of the DOMAIN argument."
     (and (face-equal-loop common-props face1 face2 domain)
         (cond ((eq 'tty (device-type device))
                (face-equal-loop tty-props face1 face2 domain))
+              ;; #### Why isn't this (console-on-window-system-p (device-console device))?
+              ;; #### FIXME!
               ((or (eq 'x (device-type device))
+                   (eq 'gtk (device-type device))
                    (eq 'mswindows (device-type device)))
                (face-equal-loop win-props face1 face2 domain))
               (t t)))))
@@ -907,6 +910,12 @@ the function to be called on it."
       (setq inst-list (cdr inst-list)))
     (or result first-valid)))
 
+(defcustom face-frob-from-locale-first nil
+  "*If non nil, use kludgy way of frobbing fonts suitable for non-mule
+multi-charset environments."
+  :group 'faces
+  :type 'boolean)
+
 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
                              tty-thunk ws-thunk standard-face-mapping)
   ;; another kludge to make things more intuitive.  If we're
@@ -924,14 +933,20 @@ the function to be called on it."
   (let* ((the-locale (cond ((null locale) 'global)
                           ((valid-specifier-locale-p locale) locale)
                           (t nil)))
-        (specs (and the-locale (face-font face the-locale nil t)))
-        (change-it (and specs (cdr (assoc specs standard-face-mapping)))))
+        (spec-list
+         (and
+          the-locale
+          (specifier-spec-list (get (get-face face) 'font) the-locale tags t)))
+        (change-it
+         (and
+          spec-list
+          (cdr (assoc (cdadar spec-list) standard-face-mapping)))))
     (if (and change-it
             (not (memq (face-name (find-face face))
                        '(default bold italic bold-italic))))
        (progn
          (or (equal change-it t)
-             (set-face-property face 'font change-it the-locale))
+             (set-face-property face 'font change-it the-locale tags))
          (funcall tty-thunk))
       (let* ((domain (cond ((null the-locale) nil)
                           ((valid-specifier-domain-p the-locale) the-locale)
@@ -942,20 +957,34 @@ the function to be called on it."
                            (selected-device))
                           (t nil)))
             (inst (and domain (face-property-instance face 'font domain))))
-       (funcall tty-thunk)
-       (funcall ws-thunk)
        ;; If it's reasonable to do the inherit-from-standard-face trick,
        ;; and it's called for, then do it now.
-       (or (null domain)
-           (not (equal inst (face-property-instance face 'font domain)))
-           ;; don't do it for standard faces, or you'll get inheritance loops.
-           ;; #### This makes XEmacs seg fault! fix this bug.
-           (memq (face-name (find-face face))
-                 '(default bold italic bold-italic))
-           (not (equal (face-property-instance face 'font domain)
-                       (face-property-instance unfrobbed-face 'font domain)))
+       (if (and
+            face-frob-from-locale-first
+            (eq the-locale 'global)
+            domain
+            (equal inst (face-property-instance face 'font domain))
+            ;; don't do it for standard faces, or you'll get inheritance loops.
+            ;; #### This makes XEmacs seg fault! fix this bug.
+            (not (memq (face-name (find-face face))
+                       '(default bold italic bold-italic)))
+            (equal (face-property-instance face 'font domain)
+                   (face-property-instance unfrobbed-face 'font domain)))
            (set-face-property face 'font (vector frobbed-face)
-                              the-locale tags))))))
+                              the-locale tags)
+         ;; and only otherwise try to build new property value artificially
+         (funcall tty-thunk)
+         (funcall ws-thunk)
+         (and
+          domain
+          (equal inst (face-property-instance face 'font domain))
+          ;; don't do it for standard faces, or you'll get inheritance loops.
+          ;; #### This makes XEmacs seg fault! fix this bug.
+          (not (memq (face-name (find-face face))
+                     '(default bold italic bold-italic)))
+          (equal (face-property-instance face 'font domain)
+                 (face-property-instance unfrobbed-face 'font domain))
+          (set-face-property face 'font (vector frobbed-face) the-locale tags)))))))
 
 (defun make-face-bold (face &optional locale tags)
   "Make FACE bold in LOCALE, if possible.
@@ -992,7 +1021,10 @@ circumstances."
      (when (featurep 'tty)
        (set-face-highlight-p face t locale (cons 'tty tags))))
    (lambda ()
-     ;; handle X/MS Windows specific entries
+     ;; handle window-system specific entries
+     (when (featurep 'gtk)
+       (frob-face-property face 'font 'gtk-make-font-bold
+                          '(gtk) locale tags))
      (when (featurep 'x)
        (frob-face-property face 'font 'x-make-font-bold
                           '(x) locale tags))
@@ -1019,7 +1051,10 @@ how this function works."
      (when (featurep 'tty)
        (set-face-underline-p face t locale (cons 'tty tags))))
    (lambda ()
-     ;; handle X specific entries
+     ;; handle window-system specific entries
+     (when (featurep 'gtk)
+       (frob-face-property face 'font 'gtk-make-font-italic
+                          '(gtk) locale tags))
      (when (featurep 'x)
        (frob-face-property face 'font 'x-make-font-italic
                           '(x) locale tags))
@@ -1047,7 +1082,10 @@ argument and for more specifics on exactly how this function works."
        (set-face-highlight-p face t locale (cons 'tty tags))
        (set-face-underline-p face t locale (cons 'tty tags))))
    (lambda ()
-     ;; handle X specific entries
+     ;; handle window-system specific entries
+     (when (featurep 'gtk)
+       (frob-face-property face 'font 'gtk-make-font-bold-italic
+                          '(gtk) locale tags))
      (when (featurep 'x)
        (frob-face-property face 'font 'x-make-font-bold-italic
                           '(x) locale tags))
@@ -1074,7 +1112,10 @@ specifics on exactly how this function works."
      (when (featurep 'tty)
        (set-face-highlight-p face nil locale (cons 'tty tags))))
    (lambda ()
-     ;; handle X specific entries
+     ;; handle window-system specific entries
+     (when (featurep 'gtk)
+       (frob-face-property face 'font 'gtk-make-font-unbold
+                          '(gtk) locale tags))
      (when (featurep 'x)
        (frob-face-property face 'font 'x-make-font-unbold
                           '(x) locale tags))
@@ -1101,7 +1142,10 @@ specifics on exactly how this function works."
      (when (featurep 'tty)
        (set-face-underline-p face nil locale (cons 'tty tags))))
    (lambda ()
-     ;; handle X specific entries
+     ;; handle window-system specific entries
+     (when (featurep 'gtk)
+       (frob-face-property face 'font 'gtk-make-font-unitalic
+                          '(gtk) locale tags))
      (when (featurep 'x)
        (frob-face-property face 'font 'x-make-font-unitalic
                           '(x) locale tags))
@@ -1451,6 +1495,8 @@ and 'global)."
     ;; Then do any device-specific initialization.
     (cond ((eq 'x (device-type device))
           (x-init-device-faces device))
+         ((eq 'gtk (device-type device))
+          (gtk-init-device-faces device))
          ((eq 'mswindows (device-type device))
           (mswindows-init-device-faces device))
          ;; Nothing to do for TTYs?
@@ -1466,6 +1512,8 @@ and 'global)."
     ;; Then do any frame-specific initialization.
     (cond ((eq 'x (frame-type frame))
           (x-init-frame-faces frame))
+         ((eq 'gtk (frame-type frame))
+          (gtk-init-frame-faces frame))
          ((eq 'mswindows (frame-type frame))
           (mswindows-init-frame-faces frame))
          ;; Is there anything which should be done for TTY's?
@@ -1482,7 +1530,9 @@ and 'global)."
   (loop for face in (face-list) do
        (init-face-from-resources face 'global))
   ;; Further X frobbing.
-  (x-init-global-faces)
+  (and (featurep 'x) (x-init-global-faces))
+  (and (featurep 'gtk) (gtk-init-global-faces))
+
   ;; for bold and the like, make the global specification be bold etc.
   ;; if the user didn't already specify a value.  These will also be
   ;; frobbed further in init-other-random-faces.
@@ -1636,7 +1686,7 @@ expected in this case, other types of image data will not work.
 If the optional FRAME argument is provided, change only
 in that frame; otherwise change each frame."
   (while (not (find-face face))
-    (setq face (signal 'wrong-type-argument (list 'facep face))))
+    (setq face (wrong-type-argument 'facep face)))
   (let ((bitmap-path (ecase (console-type)
                       (x         x-bitmap-file-path)
                       (mswindows mswindows-bitmap-file-path)))
@@ -1661,8 +1711,7 @@ in that frame; otherwise change each frame."
                   (and (listp pixmap) (= (length pixmap) 3)))))
        (setq pixmap (signal 'wrong-type-argument
                             (list 'stipple-pixmap-p pixmap)))))
-    (while (and frame (not (framep frame)))
-      (setq frame (signal 'wrong-type-argument (list 'framep frame))))
+    (check-type frame (or null frame))
     (set-face-background-pixmap face instantiator frame)))
 
 \f
@@ -1712,6 +1761,7 @@ in that frame; otherwise change each frame."
                     'global)
 (set-face-background-pixmap 'highlight
                            '(((x default mono) . "gray1")
+;;                           ((gtk default mono) . "gray1")
                              ((mswindows default mono) . "gray1"))
                            'global)
 
@@ -1723,6 +1773,7 @@ in that frame; otherwise change each frame."
                     'global)
 (set-face-background-pixmap 'zmacs-region
                            '(((x default mono) . "gray3")
+;;                           ((gtk default mono) . "gray3")
                              ((mswindows default mono) . "gray3"))
                            'global)
 
@@ -1730,6 +1781,9 @@ in that frame; otherwise change each frame."
                     '(((x default color) . "gray68")
                       ((x default grayscale) . "gray68")
                       ((x default mono) . [default foreground])
+;;                    ((gtk default color) . "gray68")
+;;                    ((gtk default grayscale) . "gray68")
+;;                    ((gtk default mono) . [default foreground])
                       ((mswindows default color) . "gray68")
                       ((mswindows default grayscale) . "gray68")
                       ((mswindows default mono) . [default foreground]))
@@ -1747,6 +1801,7 @@ in that frame; otherwise change each frame."
                     'global)
 (set-face-background-pixmap 'primary-selection
                            '(((x default mono) . "gray3")
+                             ;;((gtk default mono) . "gray3")
                              ((mswindows default mono) . "gray3"))
                            'global)
 
@@ -1754,18 +1809,24 @@ in that frame; otherwise change each frame."
                     '(((x default color) . "paleturquoise")
                       ((x default color) . "green")
                       ((x default grayscale) . "gray53")
+                      ;;((gtk default color) . "paleturquoise")
+                      ;;((gtk default color) . "green")
+                      ;;((gtk default grayscale) . "gray53")
                       ((mswindows default color) . "paleturquoise")
                       ((mswindows default color) . "green")
                       ((mswindows default grayscale) . "gray53"))
                     'global)
 (set-face-background-pixmap 'secondary-selection
                            '(((x default mono) . "gray1")
+                             ;;((gtk default mono) . "gray1")
                              ((mswindows default mono) . "gray1"))
                            'global)
 
 (set-face-background 'isearch
                     '(((x default color) . "paleturquoise")
                       ((x default color) . "green")
+                      ;;((gtk default color) . "paleturquoise")
+                      ;;((gtk default color) . "green")
                       ((mswindows default color) . "paleturquoise")
                       ((mswindows default color) . "green"))
                     'global)