/[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.3 by ram, Tue Aug 11 15:17:34 1992 UTC revision 1.3.2.2 by pw, Tue May 23 16:36:08 2000 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    #+cmu
21    (ext:file-comment
22      "$Header$")
23    
24  (in-package :xlib)  (in-package :xlib)
25    
# Line 31  Line 34 
34  ;; returned.  ;; returned.
35    
36  (deftype translation-function ()  (deftype translation-function ()
   #+explorer t  
   #-explorer  
37    '(function (sequence array-index array-index (or null font) vector array-index)    '(function (sequence array-index array-index (or null font) vector array-index)
38               (values array-index (or null int16 font) (or null int32))))               (values array-index (or null int16 font) (or null int32))))
39    
# Line 110  Line 111 
111    (declare (type sequence sequence)    (declare (type sequence sequence)
112             (type (or font gcontext) font))             (type (or font gcontext) font))
113    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
114             #+clx-ansi-common-lisp             (dynamic-extent translate))
            (dynamic-extent translate)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg #+Genera * #-Genera translate))  
115    (declare (clx-values width ascent descent left right    (declare (clx-values width ascent descent left right
116                    font-ascent font-descent direction                    font-ascent font-descent direction
117                    (or null array-index)))                    (or null array-index)))
# Line 154  Line 152 
152          (declare (type buffer-text16 wbuf)          (declare (type buffer-text16 wbuf)
153                   (type array-index src-start src-end end buf-end)                   (type array-index src-start src-end end buf-end)
154                   (type int16 font-ascent font-descent)                   (type int16 font-ascent font-descent)
155                   (type boolean stop-p))                   (type generalized-boolean stop-p))
156          ;; Translate the text          ;; Translate the text
157          (multiple-value-setq (buf-end new-font)          (multiple-value-setq (buf-end new-font)
158            (funcall (or translate #'translate-default)            (funcall (or translate #'translate-default)
# Line 217  Line 215 
215             (type array-index start)             (type array-index start)
216             (type (or null array-index) end))             (type (or null array-index) end))
217    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
218             #+clx-ansi-common-lisp             (dynamic-extent translate))
            (dynamic-extent translate)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg #+Genera * #-Genera translate))  
219    (declare (clx-values integer (or null integer)))    (declare (clx-values integer (or null integer)))
220    (when (type? font 'gcontext)    (when (type? font 'gcontext)
221      (force-gcontext-changes font)      (force-gcontext-changes font)
# Line 246  Line 241 
241                (setq next-start src-start)))                (setq next-start src-start)))
242          (declare (type buffer-text16 wbuf)          (declare (type buffer-text16 wbuf)
243                   (type array-index src-start src-end end buf-end)                   (type array-index src-start src-end end buf-end)
244                   (type boolean stop-p))                   (type generalized-boolean stop-p))
245          ;; Translate the text          ;; Translate the text
246          (multiple-value-setq (buf-end new-font)          (multiple-value-setq (buf-end new-font)
247            (funcall (or translate #'translate-default)            (funcall (or translate #'translate-default)
# Line 313  Line 308 
308    (declare (type font font)    (declare (type font font)
309             (type sequence sequence)             (type sequence sequence)
310             (type integer start end)             (type integer start end)
311             (type boolean width-only-p))             (type generalized-boolean width-only-p))
312    (declare (clx-values width ascent descent overall-left overall-right))    (declare (clx-values width ascent descent overall-left overall-right))
313    (let* ((char-infos (font-char-infos font))    (let* ((char-infos (font-char-infos font))
314           (font-info (font-font-info font)))           (font-info (font-font-info font)))
# Line 461  Line 456 
456             (type (or null int32) width)             (type (or null int32) width)
457             (type index-size size))             (type index-size size))
458    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
459             #+clx-ansi-common-lisp             (dynamic-extent translate))
460             (dynamic-extent translate)    (declare (clx-values generalized-boolean (or null int32)))
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg #+Genera * #-Genera translate))  
   (declare (clx-values boolean (or null int32)))  
461    (let* ((display (gcontext-display gcontext))    (let* ((display (gcontext-display gcontext))
462           (result t)           (result t)
463           (opcode *x-polytext8*))           (opcode *x-polytext8*))
# Line 512  Line 504 
504             (type (or null int32) width)             (type (or null int32) width)
505             (type index-size size))             (type index-size size))
506    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
507             #+clx-ansi-common-lisp             (dynamic-extent translate))
            (dynamic-extent translate)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg #+Genera * #-Genera translate))  
508    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
509    (unless end (setq end (length sequence)))    (unless end (setq end (length sequence)))
510    (ecase size    (ecase size
# Line 536  Line 525 
525             (type (or null int32) width))             (type (or null int32) width))
526    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
527    (declare (type translation-function translate)    (declare (type translation-function translate)
528             #+clx-ansi-common-lisp             (dynamic-extent translate))
            (dynamic-extent translate)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg translate))  
529    (let* ((src-start start)    (let* ((src-start start)
530           (src-end (or end (length sequence)))           (src-end (or end (length sequence)))
531           (next-start nil)           (next-start nil)
# Line 578  Line 564 
564    
565              (declare (type array-index src-chunk dst-chunk offset)              (declare (type array-index src-chunk dst-chunk offset)
566                       (type (or null int32) overall-width)                       (type (or null int32) overall-width)
567                       (type boolean stop-p))                       (type generalized-boolean stop-p))
568              (setq src-chunk (index-min length *max-string-size*))              (setq src-chunk (index-min length *max-string-size*))
569              (multiple-value-bind (new-start new-font translated-width)              (multiple-value-bind (new-start new-font translated-width)
570                  (funcall translate                  (funcall translate
# Line 639  Line 625 
625             (type (or null int32) width))             (type (or null int32) width))
626    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
627    (declare (type translation-function translate)    (declare (type translation-function translate)
628             #+clx-ansi-common-lisp             (dynamic-extent translate))
            (dynamic-extent translate)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg translate))  
629    (let* ((src-start start)    (let* ((src-start start)
630           (src-end (or end (length sequence)))           (src-end (or end (length sequence)))
631           (next-start nil)           (next-start nil)
# Line 683  Line 666 
666    
667              (declare (type array-index boffset src-chunk dst-chunk offset)              (declare (type array-index boffset src-chunk dst-chunk offset)
668                       (type (or null int32) overall-width)                       (type (or null int32) overall-width)
669                       (type boolean stop-p))                       (type generalized-boolean stop-p))
670              (setq src-chunk (index-min length *max-string-size*))              (setq src-chunk (index-min length *max-string-size*))
671              (multiple-value-bind (new-start new-font translated-width)              (multiple-value-bind (new-start new-font translated-width)
672                  (funcall translate                  (funcall translate
# Line 742  Line 725 
725             (type (or null int32) width)             (type (or null int32) width)
726             (type index-size size))             (type index-size size))
727    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
728             #+clx-ansi-common-lisp             (dynamic-extent translate))
729             (dynamic-extent translate)    (declare (clx-values generalized-boolean (or null int32)))
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg #+Genera * #-Genera translate))  
   (declare (clx-values boolean (or null int32)))  
730    (let* ((display (gcontext-display gcontext))    (let* ((display (gcontext-display gcontext))
731           (result t)           (result t)
732           (opcode *x-imagetext8*))           (opcode *x-imagetext8*))
# Line 798  Line 778 
778             (type (or null int32) width)             (type (or null int32) width)
779             (type index-size size))             (type index-size size))
780    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
781             #+clx-ansi-common-lisp             (dynamic-extent translate))
            (dynamic-extent translate)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg #+Genera * #-Genera translate))  
782    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
783    (setf end (index-min (index+ start 255) (or end (length sequence))))    (setf end (index-min (index+ start 255) (or end (length sequence))))
784    (ecase size    (ecase size
# Line 826  Line 803 
803             (type (or null array-index) end)             (type (or null array-index) end)
804             (type (or null int32) width))             (type (or null int32) width))
805    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
806             #+clx-ansi-common-lisp             (dynamic-extent translate))
            (dynamic-extent translate)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg translate))  
807    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
808    (do* ((display (gcontext-display gcontext))    (do* ((display (gcontext-display gcontext))
809          (length (index- end start))          (length (index- end start))
# Line 892  Line 866 
866             (type (or null array-index) end)             (type (or null array-index) end)
867             (type (or null int32) width))             (type (or null int32) width))
868    (declare (type (or null translation-function) translate)    (declare (type (or null translation-function) translate)
869             #+clx-ansi-common-lisp             (dynamic-extent translate))
            (dynamic-extent translate)  
            #+(and lispm (not clx-ansi-common-lisp))  
            (sys:downward-funarg translate))  
870    (declare (clx-values (or null array-index) (or null int32)))    (declare (clx-values (or null array-index) (or null int32)))
871    (do* ((display (gcontext-display gcontext))    (do* ((display (gcontext-display gcontext))
872          (length (index- end start))          (length (index- end start))
# Line 956  Line 927 
927            (display-max-keycode display)))            (display-max-keycode display)))
928    
929  ;; Should this signal device-busy like the pointer-mapping setf, and return a  ;; Should this signal device-busy like the pointer-mapping setf, and return a
930  ;; boolean instead (true for success)?  Alternatively, should the  ;; generalized-boolean instead (true for success)?  Alternatively, should the
931  ;; pointer-mapping setf be changed to set-pointer-mapping with a (member  ;; pointer-mapping setf be changed to set-pointer-mapping with a (member
932  ;; :success :busy) result?  ;; :success :busy) result?
933    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.3.2.2

  ViewVC Help
Powered by ViewVC 1.1.5