/usr/share/common-lisp/source/clx/fonts.lisp is in cl-clx-sbcl 0.7.4.20160323-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;; The char-info stuff is here instead of CLX because of uses of int16->card16.
; To allow efficient storage representations, the type char-info is not
; required to be a structure.
;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
;(defun char-<metric> (font index)
; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
; ;; (or an in-bounds index on a pseudo font), although returning zero or
; ;; signalling might be better.
; (declare (type font font)
; (type integer index)
; (clx-values (or null integer))))
;(defun max-char-<metric> (font)
; ;; Note: I have tentatively chosen separate accessors over allowing :min and
; ;; :max as an index above.
; (declare (type font font)
; (clx-values integer)))
;(defun min-char-<metric> (font)
; (declare (type font font)
; (clx-values integer)))
;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
(deftype char-info-vec () '(simple-array int16 (*)))
(macrolet ((def-char-info-accessors (useless-name &body fields)
`(within-definition (,useless-name def-char-info-accessors)
,@(do ((field fields (cdr field))
(n 0 (1+ n))
(name) (type)
(result nil))
((endp field) result)
(setq name (xintern 'char- (caar field)))
(setq type (cadar field))
(flet ((from (form)
(if (eq type 'int16)
form
`(,(xintern 'int16-> type) ,form))))
(push
`(defun ,name (font index)
(declare (type font font)
(type array-index index))
(declare (clx-values (or null ,type)))
(when (and (font-name font)
(index>= (font-max-char font) index (font-min-char font)))
(the ,type
,(from
`(the int16
(let ((char-info-vector (font-char-infos font)))
(declare (type char-info-vec char-info-vector))
(if (index-zerop (length char-info-vector))
;; Fixed width font
(aref (the char-info-vec
(font-max-bounds font))
,n)
;; Variable width font
(aref char-info-vector
(index+
(index*
6
(index-
index
(font-min-char font)))
,n)))))))))
result)
(setq name (xintern 'min-char- (caar field)))
(push
`(defun ,name (font)
(declare (type font font))
(declare (clx-values (or null ,type)))
(when (font-name font)
(the ,type
,(from
`(the int16
(aref (the char-info-vec (font-min-bounds font))
,n))))))
result)
(setq name (xintern 'max-char- (caar field)))
(push
`(defun ,name (font)
(declare (type font font))
(declare (clx-values (or null ,type)))
(when (font-name font)
(the ,type
,(from
`(the int16
(aref (the char-info-vec (font-max-bounds font))
,n))))))
result)))
(defun make-char-info
(&key ,@(mapcar
#'(lambda (field)
`(,(car field) (required-arg ,(car field))))
fields))
(declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
(let ((result (make-array ,(length fields) :element-type 'int16)))
(declare (type char-info-vec result))
,@(do* ((field fields (cdr field))
(var (caar field) (caar field))
(type (cadar field) (cadar field))
(n 0 (1+ n))
(result nil))
((endp field) (nreverse result))
(push `(setf (aref result ,n)
,(if (eq type 'int16)
var
`(,(xintern type '->int16) ,var)))
result))
result)))))
(def-char-info-accessors ignore
(left-bearing int16)
(right-bearing int16)
(width int16)
(ascent int16)
(descent int16)
(attributes card16)))
(defun open-font (display name)
;; Font objects may be cached and reference counted locally within the display
;; object. This function might not execute a with-display if the font is cached.
;; The protocol QueryFont request happens on-demand under the covers.
(declare (type display display)
(type stringable name))
(declare (clx-values font))
(let* ((name-string (string-downcase (string name)))
(font (car (member name-string (display-font-cache display)
:key 'font-name
:test 'equal)))
font-id)
(unless font
(setq font (make-font :display display :name name-string))
(setq font-id (allocate-resource-id display font 'font))
(setf (font-id-internal font) font-id)
(with-buffer-request (display +x-openfont+)
(resource-id font-id)
(card16 (length name-string))
(pad16 nil)
(string name-string))
(push font (display-font-cache display)))
(incf (font-reference-count font))
(unless (font-font-info-internal font)
(query-font font))
font))
(defun open-font-internal (font)
;; Called "under the covers" to open a font object
(declare (type font font))
(declare (clx-values resource-id))
(let* ((name-string (font-name font))
(display (font-display font))
(id (allocate-resource-id display font 'font)))
(setf (font-id-internal font) id)
(with-buffer-request (display +x-openfont+)
(resource-id id)
(card16 (length name-string))
(pad16 nil)
(string name-string))
(push font (display-font-cache display))
(incf (font-reference-count font))
id))
(defun discard-font-info (font)
;; Discards any state that can be re-obtained with QueryFont. This is
;; simply a performance hint for memory-limited systems.
(declare (type font font))
(setf (font-font-info-internal font) nil
(font-char-infos-internal font) nil))
(defun query-font (font)
;; Internal function called by font and char info accessors
(declare (type font font))
(declare (clx-values font-info))
(let ((display (font-display font))
font-id
font-info
props)
(setq font-id (font-id font)) ;; May issue an open-font request
(with-buffer-request-and-reply (display +x-queryfont+ 60)
((resource-id font-id))
(let* ((min-byte2 (card16-get 40))
(max-byte2 (card16-get 42))
(min-byte1 (card8-get 49))
(max-byte1 (card8-get 50))
(min-char min-byte2)
(max-char (index+ (index-ash max-byte1 8) max-byte2))
(nfont-props (card16-get 46))
(nchar-infos (index* (card32-get 56) 6))
(char-info (make-array nchar-infos :element-type 'int16)))
(setq font-info
(make-font-info
:direction (member8-get 48 :left-to-right :right-to-left)
:min-char min-char
:max-char max-char
:min-byte1 min-byte1
:max-byte1 max-byte1
:min-byte2 min-byte2
:max-byte2 max-byte2
:all-chars-exist-p (boolean-get 51)
:default-char (card16-get 44)
:ascent (int16-get 52)
:descent (int16-get 54)
:min-bounds (char-info-get 8)
:max-bounds (char-info-get 24)))
(setq props (sequence-get :length (index* 2 nfont-props) :format int32
:result-type 'list :index 60))
(sequence-get :length nchar-infos :format int16 :data char-info
:index (index+ 60 (index* 2 nfont-props 4)))
(setf (font-char-infos-internal font) char-info)
(setf (font-font-info-internal font) font-info)))
;; Replace atom id's with keywords in the plist
(do ((p props (cddr p)))
((endp p))
(setf (car p) (atom-name display (car p))))
(setf (font-info-properties font-info) props)
font-info))
(defun close-font (font)
;; This might not generate a protocol request if the font is reference
;; counted locally.
(declare (type font font))
(when (and (not (plusp (decf (font-reference-count font))))
(font-id-internal font))
(let ((display (font-display font))
(id (font-id-internal font)))
(declare (type display display))
;; Remove font from cache
(setf (display-font-cache display) (delete font (display-font-cache display)))
;; Close the font
(with-buffer-request (display +x-closefont+)
(resource-id id)))))
(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
(declare (type display display)
(type string pattern)
(type card16 max-fonts)
(type t result-type)) ;; CL type
(declare (clx-values (clx-sequence string)))
(let ((string (string pattern)))
(with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16))
((card16 max-fonts (length string))
(string string))
(values
(read-sequence-string
buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))))
(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
;; Note: Was called list-fonts-with-info.
;; Returns "pseudo" fonts that contain basic font metrics and properties, but
;; no per-character metrics and no resource-ids. These pseudo fonts will be
;; converted (internally) to real fonts dynamically as needed, by issuing an
;; OpenFont request. However, the OpenFont might fail, in which case the
;; invalid-font error can arise.
(declare (type display display)
(type string pattern)
(type card16 max-fonts)
(type t result-type)) ;; CL type
(declare (clx-values (clx-sequence font)))
(let ((string (string pattern))
(result nil))
(with-buffer-request-and-reply (display +x-listfontswithinfo+ 60
:sizes (8 16) :multiple-reply t)
((card16 max-fonts (length string))
(string string))
(cond ((zerop (card8-get 1)) t)
(t
(let* ((name-len (card8-get 1))
(min-byte2 (card16-get 40))
(max-byte2 (card16-get 42))
(min-byte1 (card8-get 49))
(max-byte1 (card8-get 50))
(min-char min-byte2)
(max-char (index+ (index-ash max-byte1 8) max-byte2))
(nfont-props (card16-get 46))
(font
(make-font
:display display
:name nil
:font-info-internal
(make-font-info
:direction (member8-get 48 :left-to-right :right-to-left)
:min-char min-char
:max-char max-char
:min-byte1 min-byte1
:max-byte1 max-byte1
:min-byte2 min-byte2
:max-byte2 max-byte2
:all-chars-exist-p (boolean-get 51)
:default-char (card16-get 44)
:ascent (int16-get 52)
:descent (int16-get 54)
:min-bounds (char-info-get 8)
:max-bounds (char-info-get 24)
:properties (sequence-get :length (index* 2 nfont-props)
:format int32
:result-type 'list
:index 60)))))
(setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
(push font result))
nil)))
;; Replace atom id's with keywords in the plist
(dolist (font result)
(do ((p (font-properties font) (cddr p)))
((endp p))
(setf (car p) (atom-name display (car p)))))
(coerce (nreverse result) result-type)))
(defun font-path (display &key (result-type 'list))
(declare (type display display)
(type t result-type)) ;; CL type
(declare (clx-values (clx-sequence (or string pathname))))
(with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16))
()
(values
(read-sequence-string
buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))
(defun set-font-path (display paths)
(declare (type display display)
(type (clx-sequence (or string pathname)) paths))
(let ((path-length (length paths))
(request-length 8))
;; Find the request length
(dotimes (i path-length)
(let* ((string (string (elt paths i)))
(len (length string)))
(incf request-length (1+ len))))
(with-buffer-request (display +x-setfontpath+ :length request-length)
(length (ceiling request-length 4))
(card16 path-length)
(pad16 nil)
(progn
(incf buffer-boffset 8)
(dotimes (i path-length)
(let* ((string (string (elt paths i)))
(len (length string)))
(card8-put 0 len)
(string-put 1 string :appending t :header-length 1)
(incf buffer-boffset (1+ len))))
(setf (buffer-boffset display) (lround buffer-boffset)))))
paths)
(defsetf font-path set-font-path)
|