Mercurial > hg > xemacs-beta

view lisp/gtk-faces.el @ 1330:4542b72c005e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2003-03-01 07:25:26 by ben] build patch Makefile.in.in: Move src deletions to src/Makefile.in.in. dump-paths.el, dumped-lisp.el: Delete. Combine stuff into setup-paths.el. find-paths.el: Removed. Make this file contain generic routines only. Move stuff to compute Emacs roots to setup-paths.el. startup.el: Removed. Move these variables into setup-paths.el. setup-paths.el, startup.el: Removed. Combine all high-level code for computing the paths into setup-paths.el. Create new function startup-find-load-path to encapsulate all logic for computing `load-path'. Eliminate invocation-directory and invocation-name parameters since there is no point (false generality) -- the code references other globals, which cannot be specified. Eliminate some code duplicated between setup-paths.el and startup.el. Clean up the debug-paths code and output load-path in addition. Add logic to paths-emacs-root-p to support separated source and build trees. loadup.el, make-docfile.el, update-elc-2.el, update-elc.el: Rewrite to allow for separated source and build trees, as may occur in MS Windows. NOTE TO BUILD HACKERS: loadup.el, make-docfile.el, update-elc.el and update-elc-2.el made two assumptions that are no longer correct: (1) The source and build trees are in the same place. (2) They can make assumptions about where `.' is. These files now compute the locations of the source and build roots at the top of the file. *ALL* constant file names or path snippets must now be made absolute using expand-file-name and one of these roots. dumped-lisp.el, packages.el: Removed. Remove some unused lists of Lisp files. packages-hardcoded-lisp (empty, in any case) moved to dumped-lisp.el. startup.el: When a compiled init file is out-of-date wrt the uncompiled version, load the uncompiled version and issue a nasty warning. update-elc-2.el: Force touching of auto-autoloads files when REBUILD_AUTOLOADS was set. update-elc.el: Fix code that checks whether dumping is necessary to check against xemacs.dmp, not xemacs.exe, when Unix and pdump. lwlib-Xm.c: Fix compile warning. README, config.inc.samp, xemacs.mak: -- Major reorganization and cleanup. -- Add support for separated build tree and source tree. -- Delete all support for X Windows building, since it's totally bit-rotten and will never be fixed up. Instruct people to use Cygwin if they want such support. make-build-dir: New script to create a skeleton build tree for use with separated build and source tree compilation. m/acorn.h, m/alliant-2800.h, m/alliant.h, m/altos.h, m/amdahl.h, m/arm.h, m/att3b.h, m/aviion.h, m/clipper.h, m/cnvrgnt.h, m/convex.h, m/cydra5.h, m/delta.h, m/delta88k.h, m/dpx2.h, m/elxsi.h, m/ews4800r.h, m/gould.h, m/hp800.h, m/hp9000s300.h, m/i860.h, m/ibmps2-aix.h, m/ibmrs6000.h, m/ibmrt-aix.h, m/ibmrt.h, m/intel386.h, m/iris4d.h, m/iris5d.h, m/iris6d.h, m/irist.h, m/m68k.h, m/masscomp.h, m/mg1.h, m/mips-nec.h, m/mips-siemens.h, m/mips.h, m/nh3000.h, m/nh4000.h, m/ns32000.h, m/plexus.h, m/powerpc.h, m/sequent-ptx.h, m/sequent.h, m/sgi-challenge.h, m/stride.h, m/tad68k.h, m/targon31.h, m/tekxd88.h, m/template.h, m/tower32.h, m/tower32v3.h, m/ustation.h, m/wicat.h, m/xps100.h, data.c, doc.c, editfns.c, emacs.c, lrecord.h, ntheap.c, process-unix.c, sysdep.c, unexec.c: Delete all support for bit-rotten CANNOT_DUMP. Just use pdump. Makefile.in.in: Lots o' cleanup. Use names like LISP, SRC instead of lispdir, srcdir, for consistency with xemacs.mak and the conventions in the rest of the file. Eliminate use of ${...} in favor of $(...), to make it easier to move code between this file and xemacs.mak. Fix dependency handling wrt NEEDTODUMP to eliminate problems some people (e.g. Vin) have been seeing with non-GNU makes. Write a long section about the subtle but oh-so-important differences in dependency processing between nmake, make, and GNU make. Add unicode-encapsulate target, from xemacs.mak. chartab.c, lrecord.h: Fix crash due to attempt to free objects across dump/undump.
author ben
date Sat, 01 Mar 2003 07:25:56 +0000
parents 79c6ff3eef26
children 7d06a8bf47d2
line wrap: on
line source

;;; gtk-faces.el --- GTK-specific face frobnication, aka black magic.

;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996 Ben Wing.
;; Copyright (c) 2000 William Perry

;; Author: William M. Perry <wmperry@gnu.org>
;; Maintainer: XEmacs Development Team
;; Keywords: extensions, internal, dumped

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: Not synched.

;;; Commentary:

;; This file is dumped with XEmacs (when GTK support is compiled in).

(globally-declare-fboundp
 '(gtk-init-pointers
   gtk-font-selection-dialog-new
   gtk-widget-set-sensitive gtk-font-selection-dialog-apply-button
   gtk-signal-connect gtk-main-quit
   gtk-font-selection-dialog-ok-button
   gtk-font-selection-dialog-get-font-name gtk-widget-destroy
   font-menu-set-font font-family font-size
   gtk-font-selection-dialog-cancel-button gtk-widget-show-all
   gtk-main gtk-style-info))

(eval-when-compile
  (defmacro gtk-style-munge-face (face attribute value)
    (let ((func (intern (format "face-%s" (eval attribute)))))
      `(add-spec-to-specifier (,func ,face) ,value nil '(gtk default) 'prepend))))

;;; gtk-init-device-faces is responsible for initializing default
;;; values for faces on a newly created device.
;;;
(defun gtk-init-device-faces (device)
  ;;
  ;; If the "default" face didn't have a font specified, try to pick one.
  ;;
  (when (eq (device-type device) 'gtk)
    (let* ((style (gtk-style-info device))
	   (normal 0)			; GTK_STATE_NORMAL
	   ;;(active 1)			; GTK_STATE_ACTIVE
	   (prelight 2)			; GTK_STATE_PRELIGHT
	   (selected 3)			; GTK_STATE_SELECTED
	   ;;(insensitive 4)		; GTK_STATE_INSENSITIVE
	   )
      (gtk-style-munge-face 'highlight 'foreground
			    (nth prelight (plist-get style 'text)))
      (gtk-style-munge-face 'highlight 'background
			    (nth prelight (plist-get style 'background)))
      (gtk-style-munge-face 'zmacs-region 'foreground
			    (nth selected (plist-get style 'text)))
      (gtk-style-munge-face 'zmacs-region 'background
			    (nth selected (plist-get style 'background)))
      (gtk-style-munge-face 'toolbar 'background
			    (nth normal (plist-get style 'base)))
      (gtk-style-munge-face 'toolbar 'foreground
			    (nth normal (plist-get style 'text)))
      (set-face-background 'modeline [toolbar background] '(gtk default))
      (set-face-foreground 'modeline [toolbar foreground] '(gtk default))
      )
    (gtk-init-pointers)))

;;; This is called from `init-frame-faces', which is called from
;;; init_frame_faces() which is called from Fmake_frame(), to perform
;;; any device-specific initialization.
;;;
(defun gtk-init-frame-faces (frame)
  )

(defun gtk-init-global-faces ()
  )


;;; Lots of this stolen from x-faces.el - I'm not sure if this will
;;; require a rewrite for win32 or not?
(defconst gtk-font-regexp nil)
(defconst gtk-font-regexp-head nil)
(defconst gtk-font-regexp-head-2 nil)
(defconst gtk-font-regexp-weight nil)
(defconst gtk-font-regexp-slant nil)
(defconst gtk-font-regexp-pixel nil)
(defconst gtk-font-regexp-point nil)
(defconst gtk-font-regexp-foundry-and-family nil)
(defconst gtk-font-regexp-registry-and-encoding nil)
(defconst gtk-font-regexp-spacing nil)

;;; Regexps matching font names in "Host Portable Character Representation."
;;;
(let ((- 		"[-?]")
      (foundry		"[^-]*")
      (family 		"[^-]*")
      (weight		"\\(bold\\|demibold\\|medium\\|black\\)")	; 1
;     (weight\?		"\\(\\*\\|bold\\|demibold\\|medium\\|\\)")	; 1
      (weight\?		"\\([^-]*\\)")					; 1
      (slant		"\\([ior]\\)")					; 2
;     (slant\?		"\\([ior?*]?\\)")				; 2
      (slant\?		"\\([^-]?\\)")					; 2
;     (swidth		"\\(\\*\\|normal\\|semicondensed\\|\\)")	; 3
      (swidth		"\\([^-]*\\)")					; 3
;     (adstyle		"\\(\\*\\|sans\\|\\)")				; 4
      (adstyle		"\\([^-]*\\)")					; 4
      (pixelsize	"\\(\\*\\|[0-9]+\\)")				; 5
      (pointsize	"\\(\\*\\|0\\|[0-9][0-9]+\\)")			; 6
;      (resx		"\\(\\*\\|[0-9][0-9]+\\)")			; 7
;      (resy		"\\(\\*\\|[0-9][0-9]+\\)")			; 8
      (resx		"\\([*0]\\|[0-9][0-9]+\\)")			; 7
      (resy		"\\([*0]\\|[0-9][0-9]+\\)")			; 8
      (spacing		"[cmp?*]")
      (avgwidth		"\\(\\*\\|[0-9]+\\)")				; 9
      (registry		"[^-]*") ; some fonts have omitted registries
;      (encoding	".+")		; note that encoding may contain "-"...
      (encoding	"[^-]+")		; false!
      )
  (setq gtk-font-regexp
	(purecopy
	 (concat "\\`\\*?[-?*]"
		 foundry - family - weight\? - slant\? - swidth - adstyle -
		 pixelsize - pointsize - resx - resy - spacing - avgwidth -
		 registry - encoding "\\'"
		 )))
  (setq gtk-font-regexp-head
	(purecopy
          (concat "\\`[-?*]" foundry - family - weight\? - slant\?
		  "\\([-*?]\\|\\'\\)")))
  (setq gtk-font-regexp-head-2
	(purecopy
          (concat "\\`[-?*]" foundry - family - weight\? - slant\?
		  - swidth - adstyle - pixelsize - pointsize
		  "\\([-*?]\\|\\'\\)")))
  (setq gtk-font-regexp-slant (purecopy (concat - slant -)))
  (setq gtk-font-regexp-weight (purecopy (concat - weight -)))
  ;; if we can't match any of the more specific regexps (unfortunate) then
  ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits
  ;; is pixels.  Bogus as hell.
  (setq gtk-font-regexp-pixel (purecopy "[-?*]\\([0-9][0-9]?\\)[-?*]"))
  (setq gtk-font-regexp-point (purecopy "[-?*]\\([0-9][0-9]+\\)[-?*]"))
  ;; the following two are used by x-font-menu.el.
  (setq gtk-font-regexp-foundry-and-family
	(purecopy (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)))
  (setq gtk-font-regexp-registry-and-encoding
	(purecopy (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")))
  (setq gtk-font-regexp-spacing
	(purecopy (concat - "\\(" spacing "\\)" - avgwidth
			  - registry - encoding "\\'")))
  )

(defvaralias 'x-font-regexp 'gtk-font-regexp)
(defvaralias 'x-font-regexp-head 'gtk-font-regexp-head)
(defvaralias 'x-font-regexp-head-2 'gtk-font-regexp-head-2)
(defvaralias 'x-font-regexp-weight 'gtk-font-regexp-weight)
(defvaralias 'x-font-regexp-slant 'gtk-font-regexp-slant)
(defvaralias 'x-font-regexp-pixel 'gtk-font-regexp-pixel)
(defvaralias 'x-font-regexp-point 'gtk-font-regexp-point)
(defvaralias 'x-font-regexp-foundry-and-family 'gtk-font-regexp-foundry-and-family)
(defvaralias 'x-font-regexp-registry-and-encoding 'gtk-font-regexp-registry-and-encoding)
(defvaralias 'x-font-regexp-spacing 'gtk-font-regexp-spacing)

(defun gtk-frob-font-weight (font which)
  (if (font-instance-p font) (setq font (font-instance-name font)))
  (cond ((null font) nil)
	((or (string-match gtk-font-regexp font)
	     (string-match gtk-font-regexp-head font)
	     (string-match gtk-font-regexp-weight font))
	 (concat (substring font 0 (match-beginning 1)) which
		 (substring font (match-end 1))))
	(t nil)))

(defun gtk-frob-font-slant (font which)
  (if (font-instance-p font) (setq font (font-instance-name font)))
  (cond ((null font) nil)
	((or (string-match gtk-font-regexp font)
	     (string-match gtk-font-regexp-head font))
	 (concat (substring font 0 (match-beginning 2)) which
		 (substring font (match-end 2))))
	((string-match gtk-font-regexp-slant font)
	 (concat (substring font 0 (match-beginning 1)) which
		 (substring font (match-end 1))))
	(t nil)))

(defun gtk-make-font-bold (font &optional device)
  (or (try-font-name (gtk-frob-font-weight font "bold") device)
      (try-font-name (gtk-frob-font-weight font "black") device)
      (try-font-name (gtk-frob-font-weight font "demibold") device)))

(defun gtk-make-font-unbold (font &optional device)
  (try-font-name (gtk-frob-font-weight font "medium") device))

(defcustom try-oblique-before-italic-fonts t
  "*If nil, italic fonts are searched before oblique fonts.
If non-nil, oblique fonts are tried before italic fonts.  This is mostly
applicable to adobe-courier fonts"
  :type 'boolean
  :tag "Try Oblique Before Italic Fonts"
  :group 'x)
(define-obsolete-variable-alias '*try-oblique-before-italic-fonts*
  'try-oblique-before-italic-fonts)

(defun gtk-make-font-italic (font &optional device)
  (if try-oblique-before-italic-fonts
      (or (try-font-name (gtk-frob-font-slant font "o") device)
	  (try-font-name (gtk-frob-font-slant font "i") device))
    (or (try-font-name (gtk-frob-font-slant font "i") device)
	(try-font-name (gtk-frob-font-slant font "o") device))))

(defun gtk-make-font-unitalic (font &optional device)
  (try-font-name (gtk-frob-font-slant font "r") device))

(defun gtk-make-font-bold-italic (font &optional device)
  (if try-oblique-before-italic-fonts
      (or (try-font-name
	   (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device)
	  (try-font-name
	   (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device)
	  (try-font-name
	   (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device)
	  (try-font-name
	   (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device)
	  (try-font-name
	   (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device)
	  (try-font-name
	   (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device))
    (or (try-font-name
	 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device)
	(try-font-name
	 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device)
	(try-font-name
	 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device)
	(try-font-name
	 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device)
	(try-font-name
	 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device)
	(try-font-name
	 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device))))

(defun gtk-choose-font ()
  (interactive)
  (require 'x-font-menu)
  (require 'font)
  (let ((locale (if font-menu-this-frame-only-p
		    (selected-frame)
		  nil))
	(dialog nil))
    (setq dialog (gtk-font-selection-dialog-new "Choose default font..."))
    (put dialog 'modal t)
    (put dialog 'type 'dialog)

    (gtk-widget-set-sensitive (gtk-font-selection-dialog-apply-button dialog) nil)
    (gtk-signal-connect dialog 'destroy (lambda (&rest ignored) (gtk-main-quit)))
    (gtk-signal-connect (gtk-font-selection-dialog-ok-button dialog)
			'clicked
			(lambda (button data)
			  (let* ((dialog (car data))
				 (font (font-create-object
					(gtk-font-selection-dialog-get-font-name dialog))))
			    (gtk-widget-destroy dialog)
			    (font-menu-set-font (car (font-family font)) nil (* 10 (font-size font)))))
			(cons dialog locale))
    (gtk-signal-connect (gtk-font-selection-dialog-cancel-button dialog)
			'clicked
			(lambda (button dialog)
			  (gtk-widget-destroy dialog)) dialog)

    (gtk-widget-show-all dialog)
    (gtk-main)))