Mercurial > hg > xemacs-beta

comparison lisp/packages/lispm-fonts.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; lispm-fonts.el --- quick hack to parse LISPM-style font-shift codes
2
3 ;; Keywords: faces
4
5 ;; Copyright (C) 1992-1993 Free Software Foundation, Inc.
6
7 ;; This file is part of XEmacs.
8
9 ;; XEmacs is free software; you can redistribute it and/or modify it
10 ;; under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; XEmacs is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;; General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with XEmacs; see the file COPYING. If not, write to the Free
21 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
23 ;;; Synched up with: Not in FSF.
24
25 ;; This only copes with MIT/LMI/TI style font shifts, not Symbolics.
26 ;; It doesn't do diagram lines (ha ha). It doesn't do output. That
27 ;; has to wait until it is possible to attach faces to characters
28 ;; instead of just intervals, since this code is really talking about
29 ;; attributes of the text instead of attributes of regions of the
30 ;; buffer. We could do it by mapping over the extents and hacking
31 ;; the overlaps by hand, but that would be hard.
32
33 (make-face 'variable)
34 (or (face-differs-from-default-p 'variable)
35 (set-face-font 'variable
36 "-*-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*"))
37
38 (make-face 'variable-bold)
39 (or (face-differs-from-default-p 'variable-bold)
40 (progn
41 ;; This is no good because helvetica-12-bold is a LOT larger than
42 ;; helvetica-12-medium. Someone really blew it there.
43 ;; (copy-face 'variable 'variable-bold)
44 ;; (make-face-bold 'variable-bold)
45 (set-face-font 'variable-bold
46 "-*-helvetica-bold-r-*-*-*-100-*-*-*-*-*-*")))
47
48 (make-face 'variable-italic)
49 (or (face-differs-from-default-p 'variable-italic)
50 (progn
51 (copy-face 'variable-bold 'variable-italic) ; see above
52 (make-face-unbold 'variable-italic)
53 (make-face-italic 'variable-italic)))
54
55 (make-face 'variable-bold-italic)
56 (or (face-differs-from-default-p 'variable-bold-italic)
57 (progn
58 (copy-face 'variable-bold 'variable-bold-italic)
59 (make-face-italic 'variable-bold-italic)))
60
61 (defconst lispm-font-to-face
62 '(("tvfont" . default)
63 ("cptfont" . default)
64 ("cptfontb" . bold)
65 ("cptfonti" . italic)
66 ("cptfontbi" . bold-italic)
67 ("base-font" . default)
68 ("bigfnt" . bold)
69 ("cmb8" . variable-bold)
70 ("higher-medfnb" . bold)
71 ("higher-tr8" . default)
72 ("medfnb" . bold)
73 ("medfnt" . normal)
74 ("medfntb" . bold)
75 ("wider-font" . bold)
76 ("wider-medfnt" . bold)
77 ("mets" . variable-large)
78 ("metsb" . variable-large-bold)
79 ("metsbi" . variable-large-bold-italic)
80 ("metsi" . variable-large-italic)
81 ("cmr5" . variable)
82 ("cmr10" . variable)
83 ("cmr18" . variable)
84 ("cmold" . variable)
85 ("cmdunh" . variable)
86 ("hl10" . variable)
87 ("hl10b" . variable-bold)
88 ("hl12" . variable)
89 ("hl12b" . variable-bold)
90 ("hl12bi" . variable-bold-italic)
91 ("hl12i" . variable-italic)
92 ("hl6" . variable)
93 ("hl7" . variable)
94 ("tr10" . variable)
95 ("tr10b" . variable-bold)
96 ("tr10bi" . variable-bold-italic)
97 ("tr10i" . variable-italic)
98 ("tr12" . variable)
99 ("tr12b" . variable-bold)
100 ("tr12bi" . variable-bold-italic)
101 ("tr12i" . variable-italic)
102 ("tr18" . variable-large)
103 ("tr18b" . variable-large-bold)
104 ("tr8" . variable)
105 ("tr8b" . variable-bold)
106 ("tr8i" . variable-italic)
107 ("5x5" . small)
108 ("tiny" . small)
109 ("43vxms" . variable-large)
110 ("courier" . bold)
111 ("adobe-courier10" . default)
112 ("adobe-courier14" . bold)
113 ("adobe-courier10b" . bold)
114 ("adobe-courier14b" . bold)
115 ("adobe-hl12" . variable)
116 ("adobe-hl14" . variable)
117 ("adobe-hl14b" . variable-bold)
118 )
119 "Alist of LISPM font names to Emacs face names.")
120
121
122 (defun lispm-font-to-face (lispm-font)
123 (if (symbolp lispm-font)
124 (setq lispm-font (symbol-name lispm-font)))
125 (let ((case-fold-search t)
126 face)
127 (setq lispm-font (downcase lispm-font))
128 (if (string-match "^fonts:+" lispm-font)
129 (setq lispm-font (substring lispm-font (match-end 0))))
130 (if (setq face (cdr (assoc lispm-font lispm-font-to-face)))
131 (if (find-face face)
132 face
133 (message "warning: unknown face %s" face)
134 'default)
135 (message "warning: unknown Lispm font %s" (upcase lispm-font))
136 'default)))
137
138 (defvar fonts) ; the -*- line of the file will set this.
139
140 (defun lispm-fontify-hack-local-variables ()
141 ;; Sometimes code has font-shifts in the -*- line, which means that the
142 ;; local variables will have been read incorrectly by the emacs-lisp reader.
143 ;; In particular, the `fonts' variable might be corrupted. So if there
144 ;; are font-shifts in the prop line, re-parse it.
145 (if (or (not (boundp 'fonts))
146 (null 'fonts)
147 (let ((case-fold-search t))
148 (and (looking-at "[ \t]*;.*-\\*-.*fonts[ \t]*:.*-\\*-")
149 (looking-at ".*\^F"))))
150 (save-excursion
151 (save-restriction
152 (end-of-line)
153 (narrow-to-region (point-min) (point))
154 (goto-char (point-min))
155 (while (re-search-forward "\^F[0-9a-zA-Z*]" nil t)
156 (delete-region (match-beginning 0) (match-end 0)))
157 (let ((enable-local-variables 'query))
158 (hack-local-variables))))))
159
160 (defun lispm-fontify-buffer ()
161 (save-excursion
162 (goto-char (point-min))
163 (if (fboundp 'font-lock-mode) (font-lock-mode 0))
164 (lispm-fontify-hack-local-variables)
165 (let ((font-stack nil)
166 (p (point))
167 c)
168 (while (search-forward "\^F" nil t)
169 (delete-char -1)
170 (setq c (following-char))
171 (delete-char 1)
172 (cond ((= c ?\^F)
173 (insert "\^F"))
174 ((= c ?*)
175 (if (and font-stack (/= p (point)))
176 (set-extent-face (make-extent p (point)) (car font-stack)))
177 (setq p (point))
178 (setq font-stack (cdr font-stack)))
179 ((or (< c ?0) (> c ?Z)) ; error...
180 nil)
181 ((>= (setq c (- c ?0)) (length fonts)) ; error...
182 nil)
183 (t
184 (if (and font-stack (/= p (point)))
185 (set-extent-face (make-extent p (point)) (car font-stack)))
186 (setq font-stack (cons (lispm-font-to-face (nth c fonts))
187 font-stack))
188 (setq p (point)))))
189 (if (and font-stack (/= p (point)))
190 (set-extent-face (make-extent p (point)) (car font-stack))))))