/[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.7 by emarsden, Sun Jul 20 15:55:23 2003 UTC revision 1.8 by fgilham, Tue Aug 21 15:49:28 2007 UTC
# Line 17  Line 17 
17  ;;; Texas Instruments Incorporated provides this software "as is" without  ;;; Texas Instruments Incorporated provides this software "as is" without
18  ;;; express or implied warranty.  ;;; express or implied warranty.
19  ;;;  ;;;
20    
21  #+cmu  #+cmu
22  (ext:file-comment  (ext:file-comment "$Id$")
   "$Header$")  
23    
24  (in-package :xlib)  (in-package :xlib)
25    
# Line 34  Line 34 
34  ;; returned.  ;; returned.
35    
36  (deftype translation-function ()  (deftype translation-function ()
37      #+explorer t
38      #-explorer
39    '(function (sequence array-index array-index (or null font) vector array-index)    '(function (sequence array-index array-index (or null font) vector array-index)
40               (values array-index (or null int16 font) (or null int32))))               (values array-index (or null int16 font) (or null int32))))
41    
# Line 70  Line 72 
72             (type vector dst)             (type vector dst)
73             (inline graphic-char-p))             (inline graphic-char-p))
74    (declare (clx-values integer (or null integer font) (or null integer)))    (declare (clx-values integer (or null integer font) (or null integer)))
75    font ;;not used  
76    (if (stringp src)    (let ((min-char-index (xlib:font-min-char font))
77        (do ((i src-start (index+ i 1))          (max-char-index (xlib:font-max-char font)))
78             (j dst-start (index+ j 1))      (if (stringp src)
79             (char))          (do ((i src-start (index+ i 1))
80            ((index>= i src-end)               (j dst-start (index+ j 1))
81             i)               (char))
82          (declare (type array-index i j))              ((index>= i src-end)
83          (if (graphic-char-p (setq char (char src i)))               i)
84              (setf (aref dst j) (char->card8 char))            (declare (type array-index i j))
85            (return i)))            (setf char (char->card8 (char src i)))
86        (do ((i src-start (index+ i 1))            (if (or (< char min-char-index) (> char max-char-index))
87             (j dst-start (index+ j 1))                (return i)
88             (elt))                (setf (aref dst j) char)))
89            ((index>= i src-end)          (do ((i src-start (index+ i 1))
90             i)               (j dst-start (index+ j 1))
91          (declare (type array-index i j))               (elt))
92          (setq elt (elt src i))              ((index>= i src-end)
93          (cond ((and (characterp elt) (graphic-char-p elt))               i)
94                 (setf (aref dst j) (char->card8 elt)))            (declare (type array-index i j))
95                ((integerp elt)            (setq elt (elt src i))
96                 (setf (aref dst j) elt))            (when (characterp elt) (setq elt (char->card8 elt)))
97                (t            (if (or (not (integerp elt))
98                 (return i))))))                    (< elt min-char-index)
99                      (> elt max-char-index))
100                  (return i)
101                  (setf (aref dst j) elt))))))
102    
103  ;; There is a question below of whether translate should always be required, or  ;; There is a question below of whether translate should always be required, or
104  ;; if not, what the default should be or where it should come from.  For  ;; if not, what the default should be or where it should come from.  For
# Line 111  Line 116 
116    (declare (type sequence sequence)    (declare (type sequence sequence)
117             (type (or font gcontext) font))             (type (or font gcontext) font))
118    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
119             (dynamic-extent translate))             #+clx-ansi-common-lisp
120               (dynamic-extent translate)
121               #+(and lispm (not clx-ansi-common-lisp))
122               (sys:downward-funarg #+Genera * #-Genera translate))
123    (declare (clx-values width ascent descent left right    (declare (clx-values width ascent descent left right
124                    font-ascent font-descent direction                    font-ascent font-descent direction
125                    (or null array-index)))                    (or null array-index)))
# Line 138  Line 146 
146        (do* ((wbuf (display-tbuf16 display))        (do* ((wbuf (display-tbuf16 display))
147              (src-end (or end (length sequence)))              (src-end (or end (length sequence)))
148              (src-start start (index+ src-start buf-end))              (src-start start (index+ src-start buf-end))
149              (end (index-min src-end (index+ src-start *buffer-text16-size*))              (end (index-min src-end (index+ src-start +buffer-text16-size+))
150                   (index-min src-end (index+ src-start *buffer-text16-size*)))                   (index-min src-end (index+ src-start +buffer-text16-size+)))
151              (buf-end 0)              (buf-end 0)
152              (new-font)              (new-font)
153              (font-ascent 0)              (font-ascent 0)
# Line 215  Line 223 
223             (type array-index start)             (type array-index start)
224             (type (or null array-index) end))             (type (or null array-index) end))
225    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
226             (dynamic-extent translate))             #+clx-ansi-common-lisp
227               (dynamic-extent translate)
228               #+(and lispm (not clx-ansi-common-lisp))
229               (sys:downward-funarg #+Genera * #-Genera translate))
230    (declare (clx-values integer (or null integer)))    (declare (clx-values integer (or null integer)))
231    (when (type? font 'gcontext)    (when (type? font 'gcontext)
232      (force-gcontext-changes font)      (force-gcontext-changes font)
# Line 231  Line 242 
242        (do* ((wbuf (display-tbuf16 display))        (do* ((wbuf (display-tbuf16 display))
243              (src-end (or end (length sequence)))              (src-end (or end (length sequence)))
244              (src-start start (index+ src-start buf-end))              (src-start start (index+ src-start buf-end))
245              (end (index-min src-end (index+ src-start *buffer-text16-size*))              (end (index-min src-end (index+ src-start +buffer-text16-size+))
246                   (index-min src-end (index+ src-start *buffer-text16-size*)))                   (index-min src-end (index+ src-start +buffer-text16-size+)))
247              (buf-end 0)              (buf-end 0)
248              (new-font)              (new-font)
249              (stop-p nil))              (stop-p nil))
# Line 258  Line 269 
269            (setq font new-font))))            (setq font new-font))))
270      (values width next-start)))      (values width next-start)))
271    
272  (defun text-extents-server (font string start end)  (defun text-extents-server (font sequence start end)
273    (declare (type font font)    (declare (type font font)
274             (type sequence string)             (type sequence sequence)
275             (type array-index start end))             (type array-index start end))
276    (declare (clx-values width ascent descent left right font-ascent font-descent direction))    (declare (clx-values width ascent descent left right font-ascent font-descent direction))
277    (let ((display (font-display font))    (let ((display (font-display font))
# Line 269  Line 280 
280      (declare (type display display)      (declare (type display display)
281               (type array-index length)               (type array-index length)
282               (type resource-id font-id))               (type resource-id font-id))
283      (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes (8 16 32))      (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32))
284           (((data boolean) (oddp length))           (((data boolean) (oddp length))
285            (length (index+ (index-ceiling length 2) 2))            (length (index+ (index-ceiling length 2) 2))
286            (resource-id font-id)            (resource-id font-id)
287            ((sequence :format char2b :start start :end end :appending t)            ((sequence :format char2b :start start :end end :appending t)
288             string))             sequence))
289        (values        (values
290          (integer-get 16)          (integer-get 16)
291          (int16-get 12)          (int16-get 12)
# Line 285  Line 296 
296          (int16-get 10)          (int16-get 10)
297          (member8-get 1 :left-to-right :right-to-left)))))          (member8-get 1 :left-to-right :right-to-left)))))
298    
299  (defun text-width-server (font string start end)  (defun text-width-server (font sequence start end)
300    (declare (type (or font gcontext) font)    (declare (type (or font gcontext) font)
301             (type sequence string)             (type sequence sequence)
302             (type array-index start end))             (type array-index start end))
303    (declare (clx-values integer))    (declare (clx-values integer))
304    (let ((display (font-display font))    (let ((display (font-display font))
# Line 296  Line 307 
307      (declare (type display display)      (declare (type display display)
308               (type array-index length)               (type array-index length)
309               (type resource-id font-id))               (type resource-id font-id))
310      (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32)      (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32)
311           (((data boolean) (oddp length))           (((data boolean) (oddp length))
312            (length (index+ (index-ceiling length 2) 2))            (length (index+ (index-ceiling length 2) 2))
313            (resource-id font-id)            (resource-id font-id)
314            ((sequence :format char2b :start start :end end :appending t)            ((sequence :format char2b :start start :end end :appending t)
315             string))             sequence))
316        (values (integer-get 16)))))        (values (integer-get 16)))))
317    
318  (defun text-extents-local (font sequence start end width-only-p)  (defun text-extents-local (font sequence start end width-only-p)
# Line 456  Line 467 
467             (type (or null int32) width)             (type (or null int32) width)
468             (type index-size size))             (type index-size size))
469    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
470             (dynamic-extent translate))             #+clx-ansi-common-lisp
471               (dynamic-extent translate)
472               #+(and lispm (not clx-ansi-common-lisp))
473               (sys:downward-funarg #+Genera * #-Genera translate))
474    (declare (clx-values generalized-boolean (or null int32)))    (declare (clx-values generalized-boolean (or null int32)))
475    (let* ((display (gcontext-display gcontext))    (let* ((display (gcontext-display gcontext))
476           (result t)           (result t)
477           (opcode *x-polytext8*))           (opcode +x-polytext8+))
478      (declare (type display display))      (declare (type display display))
479      (let ((vector (allocate-gcontext-state)))      (let ((vector (allocate-gcontext-state)))
480        (declare (type gcontext-state vector))        (declare (type gcontext-state vector))
# Line 480  Line 494 
494          (when translate-width (setq width translate-width))))          (when translate-width (setq width translate-width))))
495      (when result      (when result
496        (when (eql size 16)        (when (eql size 16)
497          (setq opcode *x-polytext16*)          (setq opcode +x-polytext16+)
498          (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))          (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
499        (with-buffer-request (display opcode :gc-force gcontext)        (with-buffer-request (display opcode :gc-force gcontext)
500          (drawable drawable)          (drawable drawable)
# Line 504  Line 518 
518             (type (or null int32) width)             (type (or null int32) width)
519             (type index-size size))             (type index-size size))
520    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
521             (dynamic-extent translate))             #+clx-ansi-common-lisp
522               (dynamic-extent translate)
523               #+(and lispm (not clx-ansi-common-lisp))
524               (sys:downward-funarg #+Genera * #-Genera translate))
525    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
526    (unless end (setq end (length sequence)))    (unless end (setq end (length sequence)))
527    (ecase size    (ecase size
# Line 525  Line 542 
542             (type (or null int32) width))             (type (or null int32) width))
543    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
544    (declare (type translation-function translate)    (declare (type translation-function translate)
545             (dynamic-extent translate))             #+clx-ansi-common-lisp
546               (dynamic-extent translate)
547               #+(and lispm (not clx-ansi-common-lisp))
548               (sys:downward-funarg translate))
549    (let* ((src-start start)    (let* ((src-start start)
550           (src-end (or end (length sequence)))           (src-end (or end (length sequence)))
551           (next-start nil)           (next-start nil)
# Line 537  Line 557 
557      (declare (type array-index src-start src-end length)      (declare (type array-index src-start src-end length)
558               (type (or null array-index) next-start)               (type (or null array-index) next-start)
559               (type display display))               (type display display))
560      (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length)      (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length)
561        (drawable drawable)        (drawable drawable)
562        (gcontext gcontext)        (gcontext gcontext)
563        (int16 x y)        (int16 x y)
# Line 625  Line 645 
645             (type (or null int32) width))             (type (or null int32) width))
646    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
647    (declare (type translation-function translate)    (declare (type translation-function translate)
648             (dynamic-extent translate))             #+clx-ansi-common-lisp
649               (dynamic-extent translate)
650               #+(and lispm (not clx-ansi-common-lisp))
651               (sys:downward-funarg translate))
652    (let* ((src-start start)    (let* ((src-start start)
653           (src-end (or end (length sequence)))           (src-end (or end (length sequence)))
654           (next-start nil)           (next-start nil)
# Line 639  Line 662 
662               (type (or null array-index) next-start)               (type (or null array-index) next-start)
663               (type display display)               (type display display)
664               (type buffer-text16 buffer))               (type buffer-text16 buffer))
665      (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length)      (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length)
666        (drawable drawable)        (drawable drawable)
667        (gcontext gcontext)        (gcontext gcontext)
668        (int16 x y)        (int16 x y)
# Line 725  Line 748 
748             (type (or null int32) width)             (type (or null int32) width)
749             (type index-size size))             (type index-size size))
750    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
751             (dynamic-extent translate))             #+clx-ansi-common-lisp
752               (dynamic-extent translate)
753               #+(and lispm (not clx-ansi-common-lisp))
754               (sys:downward-funarg #+Genera * #-Genera translate))
755    (declare (clx-values generalized-boolean (or null int32)))    (declare (clx-values generalized-boolean (or null int32)))
756    (let* ((display (gcontext-display gcontext))    (let* ((display (gcontext-display gcontext))
757           (result t)           (result t)
758           (opcode *x-imagetext8*))           (opcode +x-imagetext8+))
759      (declare (type display display))      (declare (type display display))
760      (let ((vector (allocate-gcontext-state)))      (let ((vector (allocate-gcontext-state)))
761        (declare (type gcontext-state vector))        (declare (type gcontext-state vector))
# Line 749  Line 775 
775          (when translate-width (setq width translate-width))))          (when translate-width (setq width translate-width))))
776      (when result      (when result
777        (when (eql size 16)        (when (eql size 16)
778          (setq opcode *x-imagetext16*)          (setq opcode +x-imagetext16+)
779          (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))          (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
780        (with-buffer-request (display opcode :gc-force gcontext)        (with-buffer-request (display opcode :gc-force gcontext)
781          (drawable drawable)          (drawable drawable)
# Line 778  Line 804 
804             (type (or null int32) width)             (type (or null int32) width)
805             (type index-size size))             (type index-size size))
806    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
807             (dynamic-extent translate))             #+clx-ansi-common-lisp
808               (dynamic-extent translate)
809               #+(and lispm (not clx-ansi-common-lisp))
810               (sys:downward-funarg #+Genera * #-Genera translate))
811    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
812    (setf end (index-min (index+ start 255) (or end (length sequence))))    (setf end (index-min (index+ start 255) (or end (length sequence))))
813    (ecase size    (ecase size
# Line 803  Line 832 
832             (type (or null array-index) end)             (type (or null array-index) end)
833             (type (or null int32) width))             (type (or null int32) width))
834    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
835             (dynamic-extent translate))             #+clx-ansi-common-lisp
836               (dynamic-extent translate)
837               #+(and lispm (not clx-ansi-common-lisp))
838               (sys:downward-funarg translate))
839    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
840    (do* ((display (gcontext-display gcontext))    (do* ((display (gcontext-display gcontext))
841          (length (index- end start))          (length (index- end start))
# Line 819  Line 851 
851      (when font-change      (when font-change
852        (setf (gcontext-font gcontext) font))        (setf (gcontext-font gcontext) font))
853      (block change-font      (block change-font
854        (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length)        (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length)
855          (drawable drawable)          (drawable drawable)
856          (gcontext gcontext)          (gcontext gcontext)
857          (int16 x y)          (int16 x y)
# Line 866  Line 898 
898             (type (or null array-index) end)             (type (or null array-index) end)
899             (type (or null int32) width))             (type (or null int32) width))
900    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
901             (dynamic-extent translate))             #+clx-ansi-common-lisp
902               (dynamic-extent translate)
903               #+(and lispm (not clx-ansi-common-lisp))
904               (sys:downward-funarg translate))
905    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
906    (do* ((display (gcontext-display gcontext))    (do* ((display (gcontext-display gcontext))
907          (length (index- end start))          (length (index- end start))
# Line 885  Line 920 
920        (setf (gcontext-font gcontext) font))        (setf (gcontext-font gcontext) font))
921    
922      (block change-font      (block change-font
923        (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length)        (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length)
924          (drawable drawable)          (drawable drawable)
925          (gcontext gcontext)          (gcontext gcontext)
926          (int16 x y)          (int16 x y)
# Line 955  Line 990 
990      (replace data mod3 :start1 (index* 5 keycodes-per-modifier))      (replace data mod3 :start1 (index* 5 keycodes-per-modifier))
991      (replace data mod4 :start1 (index* 6 keycodes-per-modifier))      (replace data mod4 :start1 (index* 6 keycodes-per-modifier))
992      (replace data mod5 :start1 (index* 7 keycodes-per-modifier))      (replace data mod5 :start1 (index* 7 keycodes-per-modifier))
993      (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8)      (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8)
994           ((data keycodes-per-modifier)           ((data keycodes-per-modifier)
995            ((sequence :format card8) data))            ((sequence :format card8) data))
996        (values (member8-get 1 :success :busy :failed)))))        (values (member8-get 1 :success :busy :failed)))))
# Line 965  Line 1000 
1000    (declare (type display display))    (declare (type display display))
1001    (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5))    (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5))
1002    (let ((lists nil))    (let ((lists nil))
1003      (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8)      (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8)
1004           ()           ()
1005        (do* ((keycodes-per-modifier (card8-get 1))        (do* ((keycodes-per-modifier (card8-get 1))
1006              (advance-by *replysize* keycodes-per-modifier)              (advance-by +replysize+ keycodes-per-modifier)
1007              (keys nil nil)              (keys nil nil)
1008              (i 0 (index+ i 1)))              (i 0 (index+ i 1)))
1009             ((index= i 8))             ((index= i 8))
# Line 998  Line 1033 
1033           (size (index* length keysyms-per-keycode))           (size (index* length keysyms-per-keycode))
1034           (request-length (index+ size 2)))           (request-length (index+ size 2)))
1035      (declare (type array-index keycode-end keysyms-per-keycode length request-length))      (declare (type array-index keycode-end keysyms-per-keycode length request-length))
1036      (with-buffer-request (display *x-setkeyboardmapping*      (with-buffer-request (display +x-setkeyboardmapping+
1037                                    :length (index-ash request-length 2)                                    :length (index-ash request-length 2)
1038                                    :sizes (32))                                    :sizes (32))
1039        (data length)        (data length)
# Line 1033  Line 1068 
1068    (unless first-keycode (setq first-keycode (display-min-keycode display)))    (unless first-keycode (setq first-keycode (display-min-keycode display)))
1069    (unless start (setq start first-keycode))    (unless start (setq start first-keycode))
1070    (unless end (setq end (1+ (display-max-keycode display))))    (unless end (setq end (1+ (display-max-keycode display))))
1071    (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32))    (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32))
1072         ((card8 first-keycode (index- end start)))         ((card8 first-keycode (index- end start)))
1073      (do* ((keysyms-per-keycode (card8-get 1))      (do* ((keysyms-per-keycode (card8-get 1))
1074            (bytes-per-keycode (* keysyms-per-keycode 4))            (bytes-per-keycode (* keysyms-per-keycode 4))
1075            (advance-by *replysize* bytes-per-keycode)            (advance-by +replysize+ bytes-per-keycode)
1076            (keycode-count (floor (card32-get 4) keysyms-per-keycode)            (keycode-count (floor (card32-get 4) keysyms-per-keycode)
1077                           (index- keycode-count 1))                           (index- keycode-count 1))
1078            (result (if (and (arrayp data)            (result (if (and (arrayp data)

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

  ViewVC Help
Powered by ViewVC 1.1.5