/[cmucl]/src/clx/fonts.lisp
ViewVC logotype

Diff of /src/clx/fonts.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.1.1 by ram, Mon Jan 13 15:10:44 1992 UTC revision 1.7 by rtoy, Wed Jun 17 18:22:46 2009 UTC
# Line 16  Line 16 
16  ;;; express or implied warranty.  ;;; express or implied warranty.
17  ;;;  ;;;
18    
19    #+cmu
20    (ext:file-comment "$Id$")
21    
22  (in-package :xlib)  (in-package :xlib)
23    
24  ;; The char-info stuff is here instead of CLX because of uses of int16->card16.  ;; The char-info stuff is here instead of CLX because of uses of int16->card16.
# Line 31  Line 34 
34  ;  ;; signalling might be better.  ;  ;; signalling might be better.
35  ;  (declare (type font font)  ;  (declare (type font font)
36  ;          (type integer index)  ;          (type integer index)
37  ;          (values (or null integer))))  ;          (clx-values (or null integer))))
38    
39  ;(defun max-char-<metric> (font)  ;(defun max-char-<metric> (font)
40  ;  ;; Note: I have tentatively chosen separate accessors over allowing :min and  ;  ;; Note: I have tentatively chosen separate accessors over allowing :min and
41  ;  ;; :max as an index above.  ;  ;; :max as an index above.
42  ;  (declare (type font font)  ;  (declare (type font font)
43  ;          (values integer)))  ;          (clx-values integer)))
44    
45  ;(defun min-char-<metric> (font)  ;(defun min-char-<metric> (font)
46  ;  (declare (type font font)  ;  (declare (type font font)
47  ;          (values integer)))  ;          (clx-values integer)))
48    
49  ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.  ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
50    
# Line 64  Line 67 
67                         `(defun ,name (font index)                         `(defun ,name (font index)
68                            (declare (type font font)                            (declare (type font font)
69                                     (type array-index index))                                     (type array-index index))
70                            (declare (values (or null ,type)))                            (declare (clx-values (or null ,type)))
71                            (when (and (font-name font)                            (when (and (font-name font)
72                                       (index>= (font-max-char font) index (font-min-char font)))                                       (index>= (font-max-char font) index (font-min-char font)))
73                              (the ,type                              (the ,type
# Line 91  Line 94 
94                       (push                       (push
95                         `(defun ,name (font)                         `(defun ,name (font)
96                            (declare (type font font))                            (declare (type font font))
97                            (declare (values (or null ,type)))                            (declare (clx-values (or null ,type)))
98                            (when (font-name font)                            (when (font-name font)
99                              (the ,type                              (the ,type
100                                   ,(from                                   ,(from
# Line 103  Line 106 
106                       (push                       (push
107                         `(defun ,name (font)                         `(defun ,name (font)
108                            (declare (type font font))                            (declare (type font font))
109                            (declare (values (or null ,type)))                            (declare (clx-values (or null ,type)))
110                            (when (font-name font)                            (when (font-name font)
111                              (the ,type                              (the ,type
112                                   ,(from                                   ,(from
# Line 119  Line 122 
122                                  fields))                                  fields))
123                   (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))                   (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
124                   (let ((result (make-array ,(length fields) :element-type 'int16)))                   (let ((result (make-array ,(length fields) :element-type 'int16)))
125                     (declare (type char-info-vec result)                     (declare (type char-info-vec result))
                             (array-register result))  
126                     ,@(do* ((field fields (cdr field))                     ,@(do* ((field fields (cdr field))
127                             (var (caar field) (caar field))                             (var (caar field) (caar field))
128                             (type (cadar field) (cadar field))                             (type (cadar field) (cadar field))
# Line 147  Line 149 
149    ;; The protocol QueryFont request happens on-demand under the covers.    ;; The protocol QueryFont request happens on-demand under the covers.
150    (declare (type display display)    (declare (type display display)
151             (type stringable name))             (type stringable name))
152    (declare (values font))    (declare (clx-values font))
153    (let* ((name-string (string-downcase (string name)))    (let* ((name-string (string-downcase (string name)))
154           (font (car (member name-string (display-font-cache display)           (font (car (member name-string (display-font-cache display)
155                              :key 'font-name                              :key 'font-name
# Line 157  Line 159 
159        (setq font (make-font :display display :name name-string))        (setq font (make-font :display display :name name-string))
160        (setq font-id (allocate-resource-id display font 'font))        (setq font-id (allocate-resource-id display font 'font))
161        (setf (font-id-internal font) font-id)        (setf (font-id-internal font) font-id)
162        (with-buffer-request (display *x-openfont*)        (with-buffer-request (display +x-openfont+)
163          (resource-id font-id)          (resource-id font-id)
164          (card16 (length name-string))          (card16 (length name-string))
165          (pad16 nil)          (pad16 nil)
166          (string name-string))          (string name-string))
167        (push font (display-font-cache display)))        (push font (display-font-cache display)))
168      (incf (font-reference-count font))      (incf (font-reference-count font))
169        (unless (font-font-info-internal font)
170          (query-font font))
171      font))      font))
172    
173  (defun open-font-internal (font)  (defun open-font-internal (font)
174    ;; Called "under the covers" to open a font object    ;; Called "under the covers" to open a font object
175    (declare (type font font))    (declare (type font font))
176    (declare (values resource-id))    (declare (clx-values resource-id))
177    (let* ((name-string (font-name font))    (let* ((name-string (font-name font))
178           (display (font-display font))           (display (font-display font))
179           (id (allocate-resource-id display font 'font)))           (id (allocate-resource-id display font 'font)))
180      (setf (font-id-internal font) id)      (setf (font-id-internal font) id)
181      (with-buffer-request (display *x-openfont*)      (with-buffer-request (display +x-openfont+)
182        (resource-id id)        (resource-id id)
183        (card16 (length name-string))        (card16 (length name-string))
184        (pad16 nil)        (pad16 nil)
# Line 193  Line 197 
197  (defun query-font (font)  (defun query-font (font)
198    ;; Internal function called by font and char info accessors    ;; Internal function called by font and char info accessors
199    (declare (type font font))    (declare (type font font))
200    (declare (values font-info))    (declare (clx-values font-info))
201    (let ((display (font-display font))    (let ((display (font-display font))
202          font-id          font-id
203          font-info          font-info
204          props)          props)
205      (setq font-id (font-id font)) ;; May issue an open-font request      (setq font-id (font-id font)) ;; May issue an open-font request
206      (with-buffer-request-and-reply (display *x-queryfont* 60)      (with-buffer-request-and-reply (display +x-queryfont+ 60)
207           ((resource-id font-id))           ((resource-id font-id))
208        (let* ((min-byte2 (card16-get 40))        (let* ((min-byte2 (card16-get 40))
209               (max-byte2 (card16-get 42))               (max-byte2 (card16-get 42))
# Line 250  Line 254 
254        ;; Remove font from cache        ;; Remove font from cache
255        (setf (display-font-cache display) (delete font (display-font-cache display)))        (setf (display-font-cache display) (delete font (display-font-cache display)))
256        ;; Close the font        ;; Close the font
257        (with-buffer-request (display *x-closefont*)        (with-buffer-request (display +x-closefont+)
258          (resource-id id)))))          (resource-id id)))))
259    
260  (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))  (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
# Line 258  Line 262 
262             (type string pattern)             (type string pattern)
263             (type card16 max-fonts)             (type card16 max-fonts)
264             (type t result-type)) ;; CL type             (type t result-type)) ;; CL type
265    (declare (values (sequence string)))    (declare (clx-values (clx-sequence string)))
266    (let ((string (string pattern)))    (let ((string (string pattern)))
267      (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16))      (with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16))
268           ((card16 max-fonts (length string))           ((card16 max-fonts (length string))
269            (string string))            (string string))
270        (values        (values
271          (read-sequence-string          (read-sequence-string
272            buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*)))))            buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))))
273    
274  (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))  (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
275    ;; Note: Was called list-fonts-with-info.    ;; Note: Was called list-fonts-with-info.
# Line 278  Line 282 
282             (type string pattern)             (type string pattern)
283             (type card16 max-fonts)             (type card16 max-fonts)
284             (type t result-type)) ;; CL type             (type t result-type)) ;; CL type
285    (declare (values (sequence font)))    (declare (clx-values (clx-sequence font)))
286    (let ((string (string pattern))    (let ((string (string pattern))
287          (result nil))          (result nil))
288      (with-buffer-request-and-reply (display *x-listfontswithinfo* 60      (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60
289                                              :sizes (8 16) :multiple-reply t)                                              :sizes (8 16) :multiple-reply t)
290           ((card16 max-fonts (length string))           ((card16 max-fonts (length string))
291            (string string))            (string string))
# Line 331  Line 335 
335  (defun font-path (display &key (result-type 'list))  (defun font-path (display &key (result-type 'list))
336    (declare (type display display)    (declare (type display display)
337             (type t result-type)) ;; CL type             (type t result-type)) ;; CL type
338    (declare (values (sequence (or string pathname))))    (declare (clx-values (clx-sequence (or string pathname))))
339    (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16))    (with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16))
340         ()         ()
341      (values      (values
342        (read-sequence-string        (read-sequence-string
343          buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*))))          buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))
344    
345  (defun set-font-path (display paths)  (defun set-font-path (display paths)
346    (declare (type display display)    (declare (type display display)
347             (type sequence paths)) ;; (sequence (or string pathname))             (type (clx-sequence (or string pathname)) paths))
348    (let ((path-length (length paths))    (let ((path-length (length paths))
349          (request-length 8))          (request-length 8))
350      ;; Find the request length      ;; Find the request length
# Line 348  Line 352 
352        (let* ((string (string (elt paths i)))        (let* ((string (string (elt paths i)))
353               (len (length string)))               (len (length string)))
354          (incf request-length (1+ len))))          (incf request-length (1+ len))))
355      (with-buffer-request (display *x-setfontpath* :length request-length)      (with-buffer-request (display +x-setfontpath+ :length request-length)
356        (length (ceiling request-length 4))        (length (ceiling request-length 4))
357        (card16 path-length)        (card16 path-length)
358        (pad16 nil)        (pad16 nil)

Legend:
Removed from v.1.2.1.1  
changed lines
  Added in v.1.7

  ViewVC Help
Powered by ViewVC 1.1.5