cgit.sxemacs.org Git - sxemacs/blob - lisp/font.el

   1 ;;; font.el --- New font model
   2 ;; Author: wmperry
   3 ;; Created: 1997/09/05 15:44:37
   4 ;; Version: 1.52
   5 ;; Keywords: faces
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
   9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of SXEmacs.
  12 ;;;
  13 ;; SXEmacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; SXEmacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 (require 'cus-face)
  27
  28 (globally-declare-fboundp
  29  '(x-list-fonts internal-facep fontsetp
  30                 get-font-info get-fontset-info font-color-rgb-components
  31                 font-rgb-color-p cancel-function-timers run-at-time
  32                 set-font-oblique-p set-font-italic-p set-font-bold-p
  33                 font-dropcaps-p font-bigcaps-p font-smallcaps-p font-blink-p
  34                 font-reverse-p font-strikethru-p font-linethrough-p
  35                 font-overline-p font-underline-p font-dim-p font-oblique-p
  36                 font-italic-p font-bold-p))
  37
  38 (globally-declare-boundp 'global-face-data)
  39
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41 ;;; The emacsen compatibility package - load it up before anything else
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 (require 'cl)
  44
  45 (eval-and-compile
  46   (defvar device-fonts-cache)
  47   (condition-case ()
  48       (require 'custom)
  49     (error nil))
  50   (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
  51       nil ;; We've got what we needed
  52     ;; We have the old custom-library, hack around it!
  53     (defmacro defgroup (&rest args)
  54       nil)
  55     (defmacro defcustom (var value doc &rest args)
  56       `(defvar ,var ,value ,doc))))
  57
  58 (if (not (fboundp 'try-font-name))
  59     (defun try-font-name (fontname &rest args)
  60       (case window-system
  61         ((x) (car-safe (x-list-fonts fontname)))
  62         (otherwise nil))))
  63
  64 (if (not (fboundp 'facep))
  65     (defun facep (face)
  66       "Return t if X is a face name or an internal face vector."
  67       (if (not window-system)
  68           nil                           ; FIXME if FSF ever does TTY faces
  69         (and (or (internal-facep face)
  70                  (and (symbolp face) (assq face global-face-data)))
  71              t))))
  72
  73 (if (not (fboundp 'set-face-property))
  74     (defun set-face-property (face property value &optional locale
  75                                    tag-set how-to-add)
  76       "Change a property of FACE."
  77       (and (symbolp face)
  78            (put face property value))))
  79
  80 (if (not (fboundp 'face-property))
  81     (defun face-property (face property &optional locale tag-set exact-p)
  82       "Return FACE's value of the given PROPERTY."
  83       (and (symbolp face) (get face property))))
  84
  85 (require 'disp-table)
  86
  87 (eval-and-compile
  88   (unless (fboundp #'<<)
  89     (fset #'<< #'lsh))
  90   (unless (fboundp #'&)
  91     (fset #'& #'logand))
  92   (unless (fboundp #'|)
  93     (fset #'| #'logior))
  94   (unless (fboundp #'~)
  95     (fset #'~ #'lognot))
  96   (unless (fboundp #'>>)
  97     (defun >> (value count)
  98       (<< value (- count)))))
  99
 100 \f
 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 102 ;;; Lots of variables / keywords for use later in the program
 103 ;;; Not much should need to be modified
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
 106   "Whether we are running in XEmacs or not.")
 107
 108 (defmacro define-font-keywords (&rest keys)
 109   `(eval-and-compile
 110      (let ((keywords (quote ,keys)))
 111        (while keywords
 112          (or (boundp (car keywords))
 113              (set (car keywords) (car keywords)))
 114          (setq keywords (cdr keywords))))))
 115
 116 (defconst font-window-system-mappings
 117   '((x         . (x-font-create-name x-font-create-object))
 118     (tty       . (tty-font-create-plist tty-font-create-object)))
 119   "An assoc list mapping device types to a list of translations.
 120
 121 The first function creates a font name from a font descriptor object.
 122 The second performs the reverse translation.")
 123
 124 (defconst x-font-weight-mappings
 125   '((:extra-light . "extralight")
 126     (:light       . "light")
 127     (:demi-light  . "demilight")
 128     (:demi        . "demi")
 129     (:book        . "book")
 130     (:medium      . "medium")
 131     (:normal      . "medium")
 132     (:demi-bold   . "demibold")
 133     (:bold        . "bold")
 134     (:extra-bold  . "extrabold"))
 135   "An assoc list mapping keywords to actual Xwindow specific strings
 136 for use in the 'weight' field of an X font string.")
 137
 138 (defconst font-possible-weights
 139   (mapcar 'car x-font-weight-mappings))
 140
 141 (defvar font-rgb-file nil
 142   "Where the RGB file was found.")
 143
 144 (defvar font-maximum-slippage "1pt"
 145   "How much a font is allowed to vary from the desired size.")
 146
 147 ;; Canonical (internal) sizes are in points.
 148 ;; Registry
 149 (define-font-keywords :family :style :size :registry :encoding)
 150
 151 (define-font-keywords
 152   :weight :extra-light :light :demi-light :medium :normal :demi-bold
 153   :bold :extra-bold)
 154
 155 (defvar font-style-keywords nil)
 156
 157 (defsubst set-font-family (fontobj family)
 158   (aset fontobj 1 family))
 159
 160 (defsubst set-font-weight (fontobj weight)
 161   (aset fontobj 3 weight))
 162
 163 (defsubst set-font-style (fontobj style)
 164   (aset fontobj 5 style))
 165
 166 (defsubst set-font-size (fontobj size)
 167   (aset fontobj 7 size))
 168
 169 (defsubst set-font-registry (fontobj reg)
 170   (aset fontobj 9 reg))
 171
 172 (defsubst set-font-encoding (fontobj enc)
 173   (aset fontobj 11 enc))
 174
 175 (defsubst font-family (fontobj)
 176   (aref fontobj 1))
 177
 178 (defsubst font-weight (fontobj)
 179   (aref fontobj 3))
 180
 181 (defsubst font-style (fontobj)
 182   (aref fontobj 5))
 183
 184 (defsubst font-size (fontobj)
 185   (aref fontobj 7))
 186
 187 (defsubst font-registry (fontobj)
 188   (aref fontobj 9))
 189
 190 (defsubst font-encoding (fontobj)
 191   (aref fontobj 11))
 192
 193 (eval-when-compile
 194   (defmacro define-new-mask (attr mask)
 195     `(progn
 196        (setq font-style-keywords
 197              (cons (cons (quote ,attr)
 198                          (cons
 199                           (quote ,(intern (format "set-font-%s-p" attr)))
 200                           (quote ,(intern (format "font-%s-p" attr)))))
 201                    font-style-keywords))
 202        (defconst ,(intern (format "font-%s-mask" attr)) (<< 1 ,mask)
 203          ,(format
 204            "Bitmask for whether a font is to be rendered in %s or not."
 205            attr))
 206        (defun ,(intern (format "font-%s-p" attr)) (fontobj)
 207          ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr)
 208          (if (/= 0 (& (font-style fontobj)
 209                       ,(intern (format "font-%s-mask" attr))))
 210              t
 211            nil))
 212        (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val)
 213          ,(format "Set whether FONTOBJ will be renderd in `%s' or not."
 214                   attr)
 215          (cond
 216           (val
 217            (set-font-style fontobj (| (font-style fontobj)
 218                                       ,(intern
 219                                         (format "font-%s-mask" attr)))))
 220           ((,(intern (format "font-%s-p" attr)) fontobj)
 221            (set-font-style fontobj (- (font-style fontobj)
 222                                       ,(intern
 223                                         (format "font-%s-mask" attr)))))))
 224        )))
 225
 226 (let ((mask 0))
 227   (define-new-mask bold        (setq mask (1+ mask)))
 228   (define-new-mask italic      (setq mask (1+ mask)))
 229   (define-new-mask oblique     (setq mask (1+ mask)))
 230   (define-new-mask dim         (setq mask (1+ mask)))
 231   (define-new-mask underline   (setq mask (1+ mask)))
 232   (define-new-mask overline    (setq mask (1+ mask)))
 233   (define-new-mask linethrough (setq mask (1+ mask)))
 234   (define-new-mask strikethru  (setq mask (1+ mask)))
 235   (define-new-mask reverse     (setq mask (1+ mask)))
 236   (define-new-mask blink       (setq mask (1+ mask)))
 237   (define-new-mask smallcaps   (setq mask (1+ mask)))
 238   (define-new-mask bigcaps     (setq mask (1+ mask)))
 239   (define-new-mask dropcaps    (setq mask (1+ mask))))
 240
 241 (defvar font-caps-display-table
 242   (let ((table (make-display-table))
 243         (i 0))
 244     ;; Standard ASCII characters
 245     (while (< i 26)
 246       (aset table (+ i ?a) (+ i ?A))
 247       (setq i (1+ i)))
 248     ;; Now ISO translations
 249     (setq i 224)
 250  &nb