/[defdoc]/DefDoc/src/font-metrics/tfm-reader.lisp
ViewVC logotype

Contents of /DefDoc/src/font-metrics/tfm-reader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Sun Dec 7 23:27:06 2003 UTC (10 years, 4 months ago) by rjain
Branch: MAIN, defdoc
CVS Tags: start, HEAD
Changes since 1.1: +0 -0 lines
initial import

1 ;;;;
2 ;;;; Here's the actual reader
3 ;;;; From the TeX sources, sections 560ff.
4 ;;;;
5
6 (eval-when (load eval)
7 (handler-bind
8 (logical-pathname-translations "tex-font-metrics")
9 ((file-error
10 #'(lambda (condition)
11 (declare (ignore condition))
12 (setf (logical-pathname-translations "tex-font-metrics")
13 `(("**;*.*.*" "/usr/share/texmf/fonts/tfm/**/")
14 ("**;*" "/usr/share/texmf/fonts/tfm/**/*.tfm")
15 ("**;*" "**/*.tfm")
16 ("**;*.*.*" "**/")
17 ("*.*.*" "/usr/share/texmf/fonts/tfm/public/cm/")
18 ("*" "/usr/share/texmf/fonts/tfm/public/cm/*.tfm"))))))))
19
20 (define-condition font-error (error)
21 ((userid :reader font-error-userid :initarg :userid :type string)
22 (filename :reader font-error-filename :initarg :name :type string))
23 (:report #'(lambda (condition stream)
24 (format stream
25 "Font metrics for font ~A in file ~A are invalid."
26 (font-error-userid condition)
27 (font-error-filename condition)))))
28
29 (defun read-font-info (userid name &key (area t) (size nil))
30 "Reads the specified TFM file and returns the font-info structure
31 corresponding to that file.
32 USERID is the user-specified TeX identifier for the font.
33 NAME is a logical-pathname representing the name of the TFM file,
34 or a physical pathname if AREA is nil.
35 AREA is a logical-pathname with wildcards which will be merged with NAME or
36 T if the defaults should be used (host tex-fonts, type tfm)
37 or NIL if no pathname merging should be done.
38 SIZE is the point size at which the font should be loaded, if positive,
39 the negative of the scale factor to be used, if negative,
40 or NIL if the ``natural'' size of the font should be used.
41
42 Adapted from TeX sources, sections 560ff."
43 (declare (type string userid name)
44 (type (or boolean string pathname) area)
45 (type (or nil rational) size))
46 (let ((file
47 (cond
48 ((eq t area) (merge-pathnames name
49 (make-pathname :host "tex-fonts"
50 :type "tfm")))
51 ((null area) name)
52 (t (merge-pathnames name area)))))
53 (with-open-file (input file
54 :direction :input :element-type 'unsigned-byte)
55 (labels
56 ((abort () (error 'font-error :userid userid :filename name))
57 (read-8 () (the (unsigned-byte 8)
58 (or (read-byte input nil nil)
59 (error))))
60 (read-16 () (the (unsigned-byte 16)
61 (let ((b (read-8)))
62 (if (> b 127)
63 (abort)
64 (+ (* b #o400) (read-8))))))
65 (read-32 () (the (unsigned-byte 32)
66 (let ((b0 (read-8))
67 (b1 (read-8))
68 (b2 (read-8))
69 (b3 (read-8)))
70 (values (+ (* b0 (expt 2 24))
71 (* b1 (expt 2 16))
72 (* b2 (expt 2 8))
73 b3)
74 b0 b1 b2 b3))))
75 (check-existence (c)
76 (check-char-range c)
77 (when (not (check-exists info c)) (abort))))
78 (declare (inline read-8 read-16 read-32))
79 ;;; read the TFM size fields
80 (let* (z
81 (lf (read-16))
82 (lh (read-16))
83 (bc (read-16))
84 (ec (read-16))
85 (dummy (when (or (> bc (+ ec 1)) (> ec 255)) (abort)))
86 (dummy (when (> bc 255) (setq bc 1
87 ec 0)))
88 (nw (read-16))
89 (nh (read-16))
90 (nd (read-16))
91 (ni (read-16))
92 (nl (read-16))
93 (nk (read-16))
94 (ne (read-16))
95 (np (read-16))
96 (dummy
97 (when (/= lf (+ 6 lh (- ec bc -1) nw nh nd ni nl nk ne np))
98 (abort)))
99 ((info (create-font-info bc ec nw nh nd ni nl nk ne np))))
100
101 ;;; read the TFM header
102 (when (< lh 2) (abort))
103 (setf (font-info-check info) (read-32))
104 (setq z (read-16))
105 (setq z (+ (* z #o400) (read-8)))
106 (setq z (+ (* z #o20) (floor (read-8) #o20)))
107 (when (< z (expt 2 16)) (abort))
108 (dotimes (i (* 4 (- lh 2)))
109 ;;; ignore the rest
110 (read-8))
111 (setf (font-design-size info) (setq z (/ z (expt 2 16))))
112 (setf (font-size info)
113 (cond ((not (and size (/= size -1)))
114 (font-design-size info))
115 ((>= size 0) size)
116 (t (/ z (- s))))))
117 (flet ((check-char-range (c) (when (not (< bc c ec)) (abort))))
118 (declare (inline check-char-range))
119 ;;; read character data
120 (dotimes (k (- ec bc -1))
121 (multiple-value-bind (t a b c d) (read-32)
122 (setf (aref (font-info-chars info) k) t)
123 (when (or (>= a nw)
124 (>= (floor b #o20) nh)
125 (>= (floor b #o20) nd)
126 (>= (floor c 4) ni))
127 (abort))
128 (case (floor c 4)
129 (+lig-tag+ (when (>= d nl) (abort)))
130 (+ext-tag+ (when (>= d ne) (abort)))
131 (+list-tag+
132 ;;; check that there is no cycle of characters linked
133 ;;; together by list-tag entries
134 (check-char-range d)
135 (loop
136 with d = d then (char-info-word-rem-byte qw)
137 while (> d (+ k bc))
138 do (when (= d (+ k bc)) (abort))
139 with qw = (char-info info d)
140 while (= (char-info-word-tag qw) +list-tag+))))))
141 ;;; read box dimensions
142 (flet ((read-scaled () (the fix-word (floor (* z (read-32))))))
143 (declare (inline read-scaled))
144 (dotimes (k nw)
145 (setf (aref (font-info-widths font) k) (read-scaled)))
146 (when (/= 0 (aref (font-info-widths font 0))) (abort))
147 (dotimes (k nh)
148 (setf (aref (font-info-heights font) k) (read-scaled)))
149 (when (/= 0 (aref (font-info-heights font 0))) (abort))
150 (dotimes (k nd)
151 (setf (aref (font-info-depths font) k) (read-scaled)))
152 (when (/= 0 (aref (font-info-depths font 0))) (abort))
153 (dotimes (k ni)
154 (setf (aref (font-info-italics font) k) (read-scaled)))
155 (when (/= 0 (aref (font-info-italics font 0))) (abort)))
156 ;;; read ligature/kern programs
157 (let ((bch-label #o77777)
158 (bchar 256))
159 (when (> nl 0)
160 (dotimes (k (- nl +kern-base-offset+))
161 (multiple-value-bind (v a b c d) (read-32)
162 (setf (aref (font-info-lig-kern-progs info) k) v)
163 (if (> a 128)
164 (progn
165 (when (>= (+ (* 256 c) d) nl)
166 (abort))
167 (when (and (= a 255) (= k 0))
168 (setf bchar b)))
169 (progn
170 (when (/= b bchar) (check-existence b))
171 (cond
172 ((< c 128) (check-existence d))
173 ((>= (+ (* 256 (- c 128)) d) nk) (abort)))
174 (when (and (< a 128) (>= (+ k a 1) nl))
175 (abort))))
176 (when (= a 255) (setf bch-label (+ (* 256 c) d)))))
177 (dotimes (k nk)
178 (setf (aref (font-info-kern-progs info) k)
179 (read-scaled))))))
180 ;;; Read extensible char recipes
181 (dotimes (k ne)
182 (multiple-value-bind (v a b c d) (read-32)
183 (setf (aref (font-info-extensible-recipes info) k) v)
184 (when (/= a 0) (check-existence a))
185 (when (/= b 0) (check-existence b))
186 (when (/= c 0) (check-existence c))
187 (check-existence d)))
188 ;;; Read font parameters
189 (setf (font-info-params info)
190 (make-fix-word-vector (max np 7)))
191 (setf (aref (font-info-params info) 0)
192 (let ((x (read-32)))
193 (floor (if (> x (- (expt 2 31) 1))
194 (- x (expt 2 32))
195 x)
196 #o20)))))))

  ViewVC Help
Powered by ViewVC 1.1.5