mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-17 23:02:31 -08:00
367 lines
12 KiB
Common Lisp
367 lines
12 KiB
Common Lisp
;;; -*- 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)
|