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

Diff of /src/clx/text.lisp

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

revision 1.8 by fgilham, Tue Aug 21 15:49:28 2007 UTC revision 1.8.14.1 by rtoy, Wed Jun 17 15:46:26 2009 UTC
# Line 18  Line 18 
18  ;;; express or implied warranty.  ;;; express or implied warranty.
19  ;;;  ;;;
20    
 #+cmu  
 (ext:file-comment "$Id$")  
   
21  (in-package :xlib)  (in-package :xlib)
22    
23  ;; Strings are broken up into chunks of this size  ;; Strings are broken up into chunks of this size
# Line 73  Line 70 
70             (inline graphic-char-p))             (inline graphic-char-p))
71    (declare (clx-values integer (or null integer font) (or null integer)))    (declare (clx-values integer (or null integer font) (or null integer)))
72    
73    (let ((min-char-index (xlib:font-min-char font))    (let ((min-char-index (and font (xlib:font-min-char font)))
74          (max-char-index (xlib:font-max-char font)))          (max-char-index (and font (xlib:font-max-char font))))
75      (if (stringp src)      (if (stringp src)
76          (do ((i src-start (index+ i 1))          (do ((i src-start (index+ i 1))
77               (j dst-start (index+ j 1))               (j dst-start (index+ j 1))
# Line 83  Line 80 
80               i)               i)
81            (declare (type array-index i j))            (declare (type array-index i j))
82            (setf char (char->card8 (char src i)))            (setf char (char->card8 (char src i)))
83            (if (or (< char min-char-index) (> char max-char-index))            (if (and font (or (< char min-char-index) (> char max-char-index)))
84                (return i)                (return i)
85                (setf (aref dst j) char)))                (setf (aref dst j) char)))
86          (do ((i src-start (index+ i 1))          (do ((i src-start (index+ i 1))
# Line 95  Line 92 
92            (setq elt (elt src i))            (setq elt (elt src i))
93            (when (characterp elt) (setq elt (char->card8 elt)))            (when (characterp elt) (setq elt (char->card8 elt)))
94            (if (or (not (integerp elt))            (if (or (not (integerp elt))
95                    (< elt min-char-index)                    (and font
96                    (> elt max-char-index))                         (< elt min-char-index)
97                           (> elt max-char-index)))
98                (return i)                (return i)
99                (setf (aref dst j) elt))))))                (setf (aref dst j) elt))))))
100    
# Line 481  Line 479 
479        (setf (aref vector 0) elt)        (setf (aref vector 0) elt)
480        (multiple-value-bind (new-start new-font translate-width)        (multiple-value-bind (new-start new-font translate-width)
481            (funcall (or translate #'translate-default)            (funcall (or translate #'translate-default)
482                     vector 0 1 (gcontext-font gcontext t) vector 1)                     vector 0 1 (gcontext-font gcontext nil) vector 1)
483          ;; Allow translate to set a new font          ;; Allow translate to set a new font
484          (when (type? new-font 'font)          (when (type? new-font 'font)
485            (setf (gcontext-font gcontext) new-font)            (setf (gcontext-font gcontext) new-font)
# Line 552  Line 550 
550           (length (index- src-end src-start))           (length (index- src-end src-start))
551           (request-length (* length 2))          ; Leave lots of room for font shifts.           (request-length (* length 2))          ; Leave lots of room for font shifts.
552           (display (gcontext-display gcontext))           (display (gcontext-display gcontext))
553           ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...           (font (gcontext-font gcontext nil)))
          (font (gcontext-font gcontext t)))  
554      (declare (type array-index src-start src-end length)      (declare (type array-index src-start src-end length)
555               (type (or null array-index) next-start)               (type (or null array-index) next-start)
556               (type display display))               (type display display))
# Line 655  Line 652 
652           (length (index- src-end src-start))           (length (index- src-end src-start))
653           (request-length (* length 3))          ; Leave lots of room for font shifts.           (request-length (* length 3))          ; Leave lots of room for font shifts.
654           (display (gcontext-display gcontext))           (display (gcontext-display gcontext))
655           ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...           (font (gcontext-font gcontext nil))
          (font (gcontext-font gcontext t))  
656           (buffer (display-tbuf16 display)))           (buffer (display-tbuf16 display)))
657      (declare (type array-index src-start src-end length)      (declare (type array-index src-start src-end length)
658               (type (or null array-index) next-start)               (type (or null array-index) next-start)
# Line 762  Line 758 
758        (setf (aref vector 0) elt)        (setf (aref vector 0) elt)
759        (multiple-value-bind (new-start new-font translate-width)        (multiple-value-bind (new-start new-font translate-width)
760            (funcall (or translate #'translate-default)            (funcall (or translate #'translate-default)
761                     vector 0 1 (gcontext-font gcontext t) vector 1)                     vector 0 1 (gcontext-font gcontext nil) vector 1)
762          ;; Allow translate to set a new font          ;; Allow translate to set a new font
763          (when (type? new-font 'font)          (when (type? new-font 'font)
764            (setf (gcontext-font gcontext) new-font)            (setf (gcontext-font gcontext) new-font)
# Line 839  Line 835 
835    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
836    (do* ((display (gcontext-display gcontext))    (do* ((display (gcontext-display gcontext))
837          (length (index- end start))          (length (index- end start))
838          ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...          (font (gcontext-font gcontext nil))
         (font (gcontext-font gcontext t))  
839          (font-change nil)          (font-change nil)
840          (new-start) (translated-width) (chunk))          (new-start) (translated-width) (chunk))
841         (nil) ;; forever         (nil) ;; forever
# Line 905  Line 900 
900    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
901    (do* ((display (gcontext-display gcontext))    (do* ((display (gcontext-display gcontext))
902          (length (index- end start))          (length (index- end start))
903          ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...          (font (gcontext-font gcontext nil))
         (font (gcontext-font gcontext t))  
904          (font-change nil)          (font-change nil)
905          (new-start) (translated-width) (chunk)          (new-start) (translated-width) (chunk)
906          (buffer (buffer-tbuf16 display)))          (buffer (buffer-tbuf16 display)))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.8.14.1

  ViewVC Help
Powered by ViewVC 1.1.5