X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Ffaces.el;h=568c7ae458cc4584855f54a35c25060c8ef7c06e;hb=694cc60fa4524e34914cb444129eeb1f3a6a8b98;hp=eff6c160a20a18b6a6bb62541c3d5cd4df246626;hpb=d8bd7eee3147c839d3c74d1823c139cd54867a75;p=chise%2Fxemacs-chise.git diff --git a/lisp/faces.el b/lisp/faces.el index eff6c16..568c7ae 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -842,12 +842,12 @@ the function to be called on it." ;; happen if that locale has no instantiators. So signal ;; an error to indicate this. - + (setq temp-sp (copy-specifier sp)) (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) (not (face-property face property 'global))) (copy-specifier (face-property 'default property) - temp-sp 'global)) + temp-sp 'global)) (if (and (valid-specifier-locale-p locale) (not (specifier-specs temp-sp locale))) (error "Property must have a specification in locale %S" locale)) @@ -907,6 +907,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 +930,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 +954,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. @@ -1298,7 +1324,7 @@ If FRAME is nil, return the default frame properties." (defun face-spec-update-all-matching (spec display plist) "Update all entries in the face spec that could match display to -have the entries from the new plist and return the new spec" +have the entries from the new plist and return the new spec." (mapcar (lambda (e) (let ((entries (car e)) @@ -1326,8 +1352,8 @@ have the entries from the new plist and return the new spec" (setq new-options (cddr new-options))) (list entries options)))) (copy-sequence spec))) - - + + (defun face-spec-set-match-display (display &optional frame) "Return non-nil if DISPLAY matches FRAME. @@ -1636,7 +1662,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 +1687,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))) @@ -1781,25 +1806,25 @@ in that frame; otherwise change each frame." (if (featurep 'xpm) (setq xpm-color-symbols (list - (purecopy '("foreground" (face-foreground 'default))) - (purecopy '("background" (face-background 'default))) - (purecopy '("backgroundToolBarColor" - (or - (and - (featurep 'x) - (x-get-resource "backgroundToolBarColor" - "BackgroundToolBarColor" 'string - nil nil 'warn)) - - (face-background 'toolbar)))) - (purecopy '("foregroundToolBarColor" - (or - (and - (featurep 'x) - (x-get-resource "foregroundToolBarColor" - "ForegroundToolBarColor" 'string - nil nil 'warn)) - (face-foreground 'toolbar)))) + '("foreground" (face-foreground 'default)) + '("background" (face-background 'default)) + '("backgroundToolBarColor" + (or + (and + (featurep 'x) + (x-get-resource "backgroundToolBarColor" + "BackgroundToolBarColor" 'string + nil nil 'warn)) + + (face-background 'toolbar))) + '("foregroundToolBarColor" + (or + (and + (featurep 'x) + (x-get-resource "foregroundToolBarColor" + "ForegroundToolBarColor" 'string + nil nil 'warn)) + (face-foreground 'toolbar))) ))) (when (featurep 'tty)