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

Contents of /src/clx/bufmac.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Wed Jun 17 18:22:45 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.5: +1 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;; This file contains macro definitions for the BUFFER object for Common-Lisp
4 ;;; X windows version 11
5
6 ;;;
7 ;;; TEXAS INSTRUMENTS INCORPORATED
8 ;;; P.O. BOX 2909
9 ;;; AUSTIN, TEXAS 78769
10 ;;;
11 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
12 ;;;
13 ;;; Permission is granted to any individual or institution to use, copy, modify,
14 ;;; and distribute this software, provided that this complete copyright and
15 ;;; permission notice is maintained, intact, in all copies and supporting
16 ;;; documentation.
17 ;;;
18 ;;; Texas Instruments Incorporated provides this software "as is" without
19 ;;; express or implied warranty.
20 ;;;
21
22 #+cmu
23 (ext:file-comment "$Id: bufmac.lisp,v 1.6 2009/06/17 18:22:45 rtoy Rel $")
24
25 (in-package :xlib)
26
27 ;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them.
28
29 (defmacro write-card8 (byte-index item)
30 `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
31
32 (defmacro write-int8 (byte-index item)
33 `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
34
35 (defmacro write-card16 (byte-index item)
36 #+clx-overlapping-arrays
37 `(aset-card16 (the card16 ,item) buffer-wbuf
38 (index+ buffer-woffset (index-ash ,byte-index -1)))
39 #-clx-overlapping-arrays
40 `(aset-card16 (the card16 ,item) buffer-bbuf
41 (index+ buffer-boffset ,byte-index)))
42
43 (defmacro write-int16 (byte-index item)
44 #+clx-overlapping-arrays
45 `(aset-int16 (the int16 ,item) buffer-wbuf
46 (index+ buffer-woffset (index-ash ,byte-index -1)))
47 #-clx-overlapping-arrays
48 `(aset-int16 (the int16 ,item) buffer-bbuf
49 (index+ buffer-boffset ,byte-index)))
50
51 (defmacro write-card32 (byte-index item)
52 #+clx-overlapping-arrays
53 `(aset-card32 (the card32 ,item) buffer-lbuf
54 (index+ buffer-loffset (index-ash ,byte-index -2)))
55 #-clx-overlapping-arrays
56 `(aset-card32 (the card32 ,item) buffer-bbuf
57 (index+ buffer-boffset ,byte-index)))
58
59 (defmacro write-int32 (byte-index item)
60 #+clx-overlapping-arrays
61 `(aset-int32 (the int32 ,item) buffer-lbuf
62 (index+ buffer-loffset (index-ash ,byte-index -2)))
63 #-clx-overlapping-arrays
64 `(aset-int32 (the int32 ,item) buffer-bbuf
65 (index+ buffer-boffset ,byte-index)))
66
67 (defmacro write-card29 (byte-index item)
68 #+clx-overlapping-arrays
69 `(aset-card29 (the card29 ,item) buffer-lbuf
70 (index+ buffer-loffset (index-ash ,byte-index -2)))
71 #-clx-overlapping-arrays
72 `(aset-card29 (the card29 ,item) buffer-bbuf
73 (index+ buffer-boffset ,byte-index)))
74
75 ;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries
76 ;; and always are written high-order byte first.
77 (defmacro write-char2b (byte-index item)
78 ;; It is impossible to do an overlapping write, so only nonoverlapping here.
79 `(let ((%item ,item)
80 (%byte-index (index+ buffer-boffset ,byte-index)))
81 (declare (type card16 %item)
82 (type array-index %byte-index))
83 (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index)
84 (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1))))
85
86 (defmacro set-buffer-offset (value &environment env)
87 env
88 `(let ((.boffset. ,value))
89 (declare (type array-index .boffset.))
90 (setq buffer-boffset .boffset.)
91 #+clx-overlapping-arrays
92 ,@(when (member 16 (macroexpand '(%buffer-sizes) env))
93 `((setq buffer-woffset (index-ash .boffset. -1))))
94 #+clx-overlapping-arrays
95 ,@(when (member 32 (macroexpand '(%buffer-sizes) env))
96 `((setq buffer-loffset (index-ash .boffset. -2))))
97 #+clx-overlapping-arrays
98 .boffset.))
99
100 (defmacro advance-buffer-offset (value)
101 `(set-buffer-offset (index+ buffer-boffset ,value)))
102
103 (defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body)
104 (unless (listp sizes) (setq sizes (list sizes)))
105 `(let ((%buffer ,buffer))
106 (declare (type display %buffer))
107 ,(declare-bufmac)
108 ,(when length
109 `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer))
110 (buffer-flush %buffer)))
111 (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer))))
112 #-clx-overlapping-arrays
113 (buffer-bbuf (buffer-obuf8 %buffer))
114 #+clx-overlapping-arrays
115 ,@(append
116 (when (member 8 sizes)
117 `((buffer-bbuf (buffer-obuf8 %buffer))))
118 (when (or (member 16 sizes) (member 160 sizes))
119 `((buffer-woffset (index-ash buffer-boffset -1))
120 (buffer-wbuf (buffer-obuf16 %buffer))))
121 (when (member 32 sizes)
122 `((buffer-loffset (index-ash buffer-boffset -2))
123 (buffer-lbuf (buffer-obuf32 %buffer))))))
124 (declare (type array-index buffer-boffset))
125 #-clx-overlapping-arrays
126 (declare (type buffer-bytes buffer-bbuf))
127 #+clx-overlapping-arrays
128 ,@(append
129 (when (member 8 sizes)
130 '((declare (type buffer-bytes buffer-bbuf))))
131 (when (member 16 sizes)
132 '((declare (type array-index buffer-woffset))
133 (declare (type buffer-words buffer-wbuf))))
134 (when (member 32 sizes)
135 '((declare (type array-index buffer-loffset))
136 (declare (type buffer-longs buffer-lbuf)))))
137 buffer-boffset
138 #-clx-overlapping-arrays
139 buffer-bbuf
140 #+clx-overlapping-arrays
141 ,@(append
142 (when (member 8 sizes) '(buffer-bbuf))
143 (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
144 (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
145 #+clx-overlapping-arrays
146 (macrolet ((%buffer-sizes () ',sizes))
147 ,@body)
148 #-clx-overlapping-arrays
149 ,@body)))
150
151 ;;; This macro is just used internally in buffer
152
153 (defmacro writing-buffer-chunks (type args decls &body body)
154 (when (> (length body) 2)
155 (error "writing-buffer-chunks called with too many forms"))
156 (let* ((size (* 8 (index-increment type)))
157 (form #-clx-overlapping-arrays
158 (first body)
159 #+clx-overlapping-arrays ; XXX type dependencies
160 (or (second body)
161 (first body))))
162 `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8))))
163 ;; Loop filling the buffer
164 (do* (,@args
165 ;; Number of bytes needed to output
166 (len ,(if (= size 8)
167 `(index- end start)
168 `(index-ash (index- end start) ,(truncate size 16)))
169 (index- len chunk))
170 ;; Number of bytes available in buffer
171 (chunk (index-min len (index- (buffer-size buffer) buffer-boffset))
172 (index-min len (index- (buffer-size buffer) buffer-boffset))))
173 ((not (index-plusp len)))
174 (declare ,@decls
175 (type array-index len chunk))
176 ,form
177 (index-incf buffer-boffset chunk)
178 ;; Flush the buffer
179 (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer)))
180 (setf (buffer-boffset buffer) buffer-boffset)
181 (buffer-flush buffer)
182 (setq buffer-boffset (buffer-boffset buffer))
183 #+clx-overlapping-arrays
184 ,(case size
185 (16 '(setq buffer-woffset (index-ash buffer-boffset -1)))
186 (32 '(setq buffer-loffset (index-ash buffer-boffset -2))))))
187 (setf (buffer-boffset buffer) (lround buffer-boffset)))))

  ViewVC Help
Powered by ViewVC 1.1.5