Mercurial > hg > xemacs-beta

changeset 3918:049dc907c17a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2007-04-22 19:58:27 by aidan] Make the X11 font menu work again, server side X11 with Mule.
author aidan
date Sun, 22 Apr 2007 19:58:59 +0000
parents b8ded6c3f2a4
children 7a4c7bfe571f
files lisp/ChangeLog lisp/cus-face.el lisp/faces.el lisp/font-menu.el lisp/x-faces.el src/ChangeLog src/faces.c
diffstat 7 files changed, 108 insertions(+), 46 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Sun Apr 22 09:24:12 2007 +0000
+++ b/lisp/ChangeLog	Sun Apr 22 19:58:59 2007 +0000
@@ -1,3 +1,29 @@
+2007-01-02  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* cus-face.el (custom-set-face-update-spec):
+	Fix some formatting. 
+	* faces.el (reset-face):
+	reset-face resets other faces to behave like the default face--it
+	shouldn't do anything if it's handed the default face. 
+	* font-menu.el:
+	* font-menu.el (font-menu-set-font):
+	If the font was initialised from X resources (the tag-set
+	contains 'x-resource) pretend to Custom that it has
+	responsibility for those settings.
+	* x-faces.el:
+	Add a couple of fontconfig functions to the
+	globally-declare-fboundp, to eliminate a couple of byte-compile
+	warnings. 
+	* x-faces.el ('x-resource)): New specifier tag, used to mark when
+	a face's font or other attributes have been initialised from X
+	resources. 
+	* x-faces.el (x-init-face-from-resources):
+	Use the new specifier tag; also, instead of using a fragile
+	explicit list of what would incidentally be specified for the X11
+	Unicode fonts in faces.c, pay attention to the new specifier tag
+	created in that file for the specific purpose of grouping those
+	instantiators together. 
+
 2007-04-22  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* x-font-menu.el (x-reset-device-font-menus-core):
--- a/lisp/cus-face.el	Sun Apr 22 09:24:12 2007 +0000
+++ b/lisp/cus-face.el	Sun Apr 22 19:58:59 2007 +0000
@@ -282,7 +282,7 @@
 ;;;###autoload
 (defun custom-set-face-update-spec (face display plist)
   "Customize the FACE for display types matching DISPLAY, merging
-  in the new items from PLIST."
+in the new items from PLIST."
   (let ((spec (face-spec-update-all-matching (custom-face-get-spec face)
 					     display plist)))
     (put face 'customized-face spec)
--- a/lisp/faces.el	Sun Apr 22 09:24:12 2007 +0000
+++ b/lisp/faces.el	Sun Apr 22 19:58:59 2007 +0000
@@ -398,10 +398,10 @@
 
 The arguments LOCALE, TAG-SET and EXACT-P are the same as for
 `remove-specifier'."
-  (mapc (lambda (x)
-	  (remove-specifier (face-property face x) locale tag-set exact-p))
-	built-in-face-specifiers)
-  nil)
+  ;; Don't reset the default face. 
+  (unless (eq 'default face)
+    (dolist (x built-in-face-specifiers nil)
+      (remove-specifier (face-property face x) locale tag-set exact-p))))
 
 (defun set-face-parent (face parent &optional locale tag-set how-to-add)
   "Set the parent of FACE to PARENT, for all properties.
--- a/lisp/font-menu.el	Sun Apr 22 09:24:12 2007 +0000
+++ b/lisp/font-menu.el	Sun Apr 22 19:58:59 2007 +0000
@@ -365,14 +365,33 @@
 			      (/ (or size from-size)
 				 (specifier-instance font-menu-size-scaling
 						     (selected-device))))
-			     "pt"))))
+			     "pt")))
+            new-spec-list)
+        ;; If the font was initialised from X resources (the tag-set
+        ;; contains 'x-resource) pretend to Custom that it has
+        ;; responsibility for those settings.
+        (map-specifier (face-font 'default)
+                       (lambda (spec locale inst-list arg)
+                         (loop
+                           for (tag-set . inst)
+                           in inst-list
+                           do (setq tag-set (delq 'x-resource tag-set)
+                                    tag-set (delq 'custom tag-set)
+                                    tag-set (cons 'custom tag-set))
+                           (push (cons tag-set inst) new-spec-list)
+                           ;; Need to return nil, else map-specifier stops
+                           finally return nil))
+                       nil nil '(x-resource))
+        (remove-specifier (face-font 'default) nil '(x-resource))
+        (when new-spec-list
+          (add-spec-list-to-specifier (face-font 'default)
+                                      (list (cons 'global new-spec-list))))
 	(custom-set-face-update-spec 'default
 				     (list (list 'type (device-type)))
 				     (list :family (or family from-family)
 					   :size fsize))))
     (message "Font %s" (face-font-name 'default))))
 
-
 ;; #### This should be called `font-menu-maybe-change-face'
 ;; I wonder if a better API wouldn't (face attribute from to)
 (defun font-menu-change-face (face
--- a/lisp/x-faces.el	Sun Apr 22 09:24:12 2007 +0000
+++ b/lisp/x-faces.el	Sun Apr 22 19:58:59 2007 +0000
@@ -74,11 +74,11 @@
      fc-font-name-slant-oblique   fc-font-name-slant-italic
      fc-font-name-slant-roman))
   (globally-declare-fboundp
-    '(fc-pattern-del-size   fc-pattern-get-size   fc-pattern-add-size
-      fc-pattern-del-style  fc-pattern-duplicate  fc-copy-pattern-partial
-      fc-pattern-add-weight fc-pattern-del-weight fc-try-font          
-      fc-pattern-del-slant  fc-pattern-add-slant  fc-name-unparse
-      fc-pattern-get-pixelsize)))
+    '(fc-font-match fc-pattern-del-size fc-pattern-get-size
+      fc-pattern-add-size fc-pattern-del-style fc-pattern-duplicate
+      fc-copy-pattern-partial fc-pattern-add-weight fc-pattern-del-weight
+      fc-try-font fc-pattern-del-slant fc-pattern-add-slant fc-name-parse
+      fc-name-unparse fc-pattern-get-pixelsize)))
 
 (defconst x-font-regexp nil)
 (defconst x-font-regexp-head nil)
@@ -653,6 +653,9 @@
 ;;; state where signalling an error or entering the debugger would likely
 ;;; result in a crash.
 
+;; When we initialise a face from an X resource, note that we did so. 
+(define-specifier-tag 'x-resource)
+
 (defun x-init-face-from-resources (face &optional locale set-anyway)
 
   ;;
@@ -681,6 +684,7 @@
 	 ;; specs.
 	 (x-tag-set '(x default))
 	 (tty-tag-set '(tty default))
+         (our-tag-set '(x x-resource))
 	 (device-class nil)
 	 (face-sym (face-name face))
 	 (name (symbol-name face-sym))
@@ -738,7 +742,8 @@
     (if device-class
 	(setq tag-set (cons device-class tag-set)
 	      x-tag-set (cons device-class x-tag-set)
-	      tty-tag-set (cons device-class tty-tag-set)))
+	      tty-tag-set (cons device-class tty-tag-set)
+              our-tag-set (cons device-class our-tag-set)))
 
     ;;
     ;; If this is the default face, then any unspecified properties should
@@ -782,28 +787,22 @@
 	;; globally.  This means we should override global
 	;; defaults for all X device classes.
 	(remove-specifier (face-font face) locale x-tag-set nil))
-      (set-face-font face fn locale 'x append)
-      ;
-      ; (debug-print "the face is %s, locale %s, specifier %s"
-      ;	       face locale (face-font face))
-      ;
+      (set-face-font face fn locale our-tag-set append)
+
       ;; And retain some of the fallbacks in the generated default face,
       ;; since we don't want to try andale-mono's ISO-10646-1 encoding for
-      ;; Amharic or Thai. This is fragile; it depends on the code in
-      ;; faces.c.
-      (unless (featurep 'xft-fonts)
-        (dolist (assocked '((x encode-as-utf-8 initial)
-                            (x two-dimensional initial)
-                            (x one-dimensional final)
-                            (x two-dimensional final)))
-          (when (and (specifierp (face-font face))
-                     (consp (specifier-fallback (face-font face)))
-                     (setq assocked 
-                           (assoc assocked 
-                                  (specifier-fallback
-                                   (face-font face)))))
-            (set-face-font face (cdr assocked) locale
-                           (nreverse (car assocked)) append)))))
+      ;; Amharic or Thai.
+      (when (and (specifierp (face-font face))
+                 (consp (specifier-fallback (face-font face))))
+        (loop
+          for (tag-set . instantiator)
+          in (specifier-fallback (face-font face))
+          if (memq 'x-coverage-instantiator tag-set)
+          do (add-spec-list-to-specifier
+              (face-font face)
+              (list (cons (or locale 'global)
+                          (list (cons tag-set instantiator))))
+              append))))
 		     
     ;; Kludge-o-rooni.  Set the foreground and background resources for
     ;; X devices only -- otherwise things tend to get all messed up
@@ -814,14 +813,14 @@
 							locale
 							x-tag-set)
 	(remove-specifier (face-foreground face) locale x-tag-set nil))
-      (set-face-foreground face fg locale 'x append))
+      (set-face-foreground face fg locale our-tag-set append))
     (when bg
       (if device-class
 	  (remove-specifier-specs-matching-tag-set-cdrs (face-background face)
 							locale
 							x-tag-set)
 	(remove-specifier (face-background face) locale x-tag-set nil))
-      (set-face-background face bg locale 'x append))
+      (set-face-background face bg locale our-tag-set append))
     (when bgp
       (if device-class
 	  (remove-specifier-specs-matching-tag-set-cdrs (face-background-pixmap
@@ -829,7 +828,7 @@
 							locale
 							x-tag-set)
 	(remove-specifier (face-background-pixmap face) locale x-tag-set nil))
-      (set-face-background-pixmap face bgp locale nil append))
+      (set-face-background-pixmap face bgp locale our-tag-set append))
     (when ulp
       (if device-class
 	  (remove-specifier-specs-matching-tag-set-cdrs (face-property
@@ -838,7 +837,7 @@
 							tty-tag-set)
 	(remove-specifier (face-property face 'underline) locale
 			  tty-tag-set nil))
-      (set-face-underline-p face ulp locale nil append))
+      (set-face-underline-p face ulp locale our-tag-set append))
     (when stp
       (if device-class
 	  (remove-specifier-specs-matching-tag-set-cdrs (face-property
@@ -847,7 +846,7 @@
 							tty-tag-set)
 	(remove-specifier (face-property face 'strikethru)
 			  locale tty-tag-set nil))
-      (set-face-strikethru-p face stp locale nil append))
+      (set-face-strikethru-p face stp locale our-tag-set append))
     (when hp
       (if device-class
 	  (remove-specifier-specs-matching-tag-set-cdrs (face-property
@@ -856,7 +855,7 @@
 							tty-tag-set)
 	(remove-specifier (face-property face 'highlight)
 			  locale tty-tag-set nil))
-      (set-face-highlight-p face hp locale nil append))
+      (set-face-highlight-p face hp locale our-tag-set append))
     (when dp
       (if device-class
 	  (remove-specifier-specs-matching-tag-set-cdrs (face-property
@@ -864,7 +863,7 @@
 							locale
 							tty-tag-set)
 	(remove-specifier (face-property face 'dim) locale tty-tag-set nil))
-      (set-face-dim-p face dp locale nil append))
+      (set-face-dim-p face dp locale our-tag-set append))
     (when bp
       (if device-class
 	  (remove-specifier-specs-matching-tag-set-cdrs (face-property
@@ -873,7 +872,7 @@
 							tty-tag-set)
 	(remove-specifier (face-property face 'blinking) locale
 			  tty-tag-set nil))
-      (set-face-blinking-p face bp locale nil append))
+      (set-face-blinking-p face bp locale our-tag-set append))
     (when rp
       (if device-class
 	  (remove-specifier-specs-matching-tag-set-cdrs (face-property
@@ -882,7 +881,7 @@
 							tty-tag-set)
 	(remove-specifier (face-property face 'reverse) locale
 			  tty-tag-set nil))
-      (set-face-reverse-p face rp locale nil append))
+      (set-face-reverse-p face rp locale our-tag-set append))
     ))
 
 ;; GNU Emacs compatibility. (move to obsolete.el?)
--- a/src/ChangeLog	Sun Apr 22 09:24:12 2007 +0000
+++ b/src/ChangeLog	Sun Apr 22 19:58:59 2007 +0000
@@ -1,3 +1,12 @@
+2007-01-02  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* faces.c:
+	* faces.c (syms_of_faces):
+	* faces.c (complex_vars_of_faces):
+	New symbol and corresponding specifier tag,
+	x-coverage-instantiator, used to group those fonts used for their
+	extensive coverage for obscure characters in x-faces.el. 
+
 2007-04-16  Stephen J. Turnbull  <stephen@xemacs.org>
 
 	* redisplay-x.c (separate_textual_runs_nomule): Oops.  We agreed
--- a/src/faces.c	Sun Apr 22 09:24:12 2007 +0000
+++ b/src/faces.c	Sun Apr 22 19:58:59 2007 +0000
@@ -2011,7 +2011,7 @@
 
 #ifdef MULE
 
-Lisp_Object Qone_dimensional, Qtwo_dimensional;
+Lisp_Object Qone_dimensional, Qtwo_dimensional, Qx_coverage_instantiator;
 
 DEFUN ("specifier-tag-one-dimensional-p", 
        Fspecifier_tag_one_dimensional_p, 
@@ -2108,6 +2108,8 @@
 #ifdef MULE
   DEFSYMBOL (Qone_dimensional);
   DEFSYMBOL (Qtwo_dimensional);
+  DEFSYMBOL (Qx_coverage_instantiator);
+
   /* I would much prefer these were in Lisp. */
   DEFSUBR (Fspecifier_tag_one_dimensional_p);
   DEFSUBR (Fspecifier_tag_two_dimensional_p);
@@ -2308,6 +2310,13 @@
 
     define_specifier_tag (Qencode_as_utf_8, Qnil,
 			  intern("specifier-tag-encode-as-utf-8-p"));
+
+    /* This tag is used to group those instantiators made available in the
+       fallback for the sake of coverage of obscure characters, notably
+       Markus Kuhn's misc-fixed fonts. They will be copied from the fallback
+       when the default face is determined from X resources at startup.  */
+    define_specifier_tag (Qx_coverage_instantiator, Qnil, Qnil);
+
 #endif /* MULE */
 
 #ifdef USE_XFT
@@ -2334,7 +2343,7 @@
     inst_list = 
       Fcons
       (Fcons
-       (list3(device_symbol, Qtwo_dimensional, Qfinal), 
+       (list4(device_symbol, Qtwo_dimensional, Qfinal, Qx_coverage_instantiator), 
 	build_string 
 	("-misc-fixed-medium-r-normal--15-140-75-75-c-90-iso10646-1")),
        inst_list);
@@ -2346,7 +2355,7 @@
     inst_list = 
       Fcons
       (Fcons
-       (list3(device_symbol, Qone_dimensional, Qfinal), 
+       (list4(device_symbol, Qone_dimensional, Qfinal, Qx_coverage_instantiator), 
 	build_string 
 	("-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1")), 
        inst_list);
@@ -2366,7 +2375,7 @@
     inst_list = 
       Fcons
       (Fcons
-       (list3(device_symbol, Qencode_as_utf_8, Qinitial), 
+       (list4(device_symbol, Qencode_as_utf_8, Qinitial, Qx_coverage_instantiator), 
 	build_string 
 	("-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1")), 
        inst_list);