Permalink
Browse files

translate-default-and-nil-font

As noted on portable-clx some 2 years ago, using the default gcontext
causes CLX to hang waiting for input that will never come.  The change that
caused this dates from February 2003, when the default translate function
was made to query the incoming font for its min- and max-char; the default
font for a GC only has a weird implicit as-yet-unopened font, and so the
query will turn into a server roundtrip, which won't happen properly within
a with-buffer-flush-inhibited.

Do two things: make the default translate function robust to NIL as a font
name (which the documentation explicitly says is legal) and don't create
the proxy font object within the draw-glyphs family, passing NIL instead.

darcs-hash:20090420170827-df18d-12b7777027863c5c36d223b550151660a1fd8f6c.gz
  • Loading branch information...
1 parent f193294 commit 0e05029a5cb2fab7947fc5abdb1be0044e61eadc @csrhodes csrhodes committed Apr 20, 2009
Showing with 12 additions and 15 deletions.
  1. +12 −15 text.lisp
View
@@ -70,8 +70,8 @@
(inline graphic-char-p))
(declare (clx-values integer (or null integer font) (or null integer)))
- (let ((min-char-index (xlib:font-min-char font))
- (max-char-index (xlib:font-max-char font)))
+ (let ((min-char-index (and font (xlib:font-min-char font)))
+ (max-char-index (and font (xlib:font-max-char font))))
(if (stringp src)
(do ((i src-start (index+ i 1))
(j dst-start (index+ j 1))
@@ -80,7 +80,7 @@
i)
(declare (type array-index i j))
(setf char (char->card8 (char src i)))
- (if (or (< char min-char-index) (> char max-char-index))
+ (if (and font (or (< char min-char-index) (> char max-char-index)))
(return i)
(setf (aref dst j) char)))
(do ((i src-start (index+ i 1))
@@ -92,8 +92,9 @@
(setq elt (elt src i))
(when (characterp elt) (setq elt (char->card8 elt)))
(if (or (not (integerp elt))
- (< elt min-char-index)
- (> elt max-char-index))
+ (and font
+ (< elt min-char-index)
+ (> elt max-char-index)))
(return i)
(setf (aref dst j) elt))))))
@@ -478,7 +479,7 @@
(setf (aref vector 0) elt)
(multiple-value-bind (new-start new-font translate-width)
(funcall (or translate #'translate-default)
- vector 0 1 (gcontext-font gcontext t) vector 1)
+ vector 0 1 (gcontext-font gcontext nil) vector 1)
;; Allow translate to set a new font
(when (type? new-font 'font)
(setf (gcontext-font gcontext) new-font)
@@ -549,8 +550,7 @@
(length (index- src-end src-start))
(request-length (* length 2)) ; Leave lots of room for font shifts.
(display (gcontext-display gcontext))
- ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
- (font (gcontext-font gcontext t)))
+ (font (gcontext-font gcontext nil)))
(declare (type array-index src-start src-end length)
(type (or null array-index) next-start)
(type display display))
@@ -652,8 +652,7 @@
(length (index- src-end src-start))
(request-length (* length 3)) ; Leave lots of room for font shifts.
(display (gcontext-display gcontext))
- ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
- (font (gcontext-font gcontext t))
+ (font (gcontext-font gcontext nil))
(buffer (display-tbuf16 display)))
(declare (type array-index src-start src-end length)
(type (or null array-index) next-start)
@@ -759,7 +758,7 @@
(setf (aref vector 0) elt)
(multiple-value-bind (new-start new-font translate-width)
(funcall (or translate #'translate-default)
- vector 0 1 (gcontext-font gcontext t) vector 1)
+ vector 0 1 (gcontext-font gcontext nil) vector 1)
;; Allow translate to set a new font
(when (type? new-font 'font)
(setf (gcontext-font gcontext) new-font)
@@ -836,8 +835,7 @@
(declare (clx-values (or null array-index) (or null int32)))
(do* ((display (gcontext-display gcontext))
(length (index- end start))
- ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
- (font (gcontext-font gcontext t))
+ (font (gcontext-font gcontext nil))
(font-change nil)
(new-start) (translated-width) (chunk))
(nil) ;; forever
@@ -902,8 +900,7 @@
(declare (clx-values (or null array-index) (or null int32)))
(do* ((display (gcontext-display gcontext))
(length (index- end start))
- ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
- (font (gcontext-font gcontext t))
+ (font (gcontext-font gcontext nil))
(font-change nil)
(new-start) (translated-width) (chunk)
(buffer (buffer-tbuf16 display)))

0 comments on commit 0e05029

Please sign in to comment.