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

Contents of /src/clx/exclcmac.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Mon May 14 14:48:21 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
2 ;;;
3 ;;; CLX -- exclcmac.cl
4 ;;; This file provides for inline expansion of some functions.
5 ;;;
6 ;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca.
7 ;;;
8 ;;; Permission is granted to any individual or institution to use, copy,
9 ;;; modify, and distribute this software, provided that this complete
10 ;;; copyright and permission notice is maintained, intact, in all copies and
11 ;;; supporting documentation.
12 ;;;
13 ;;; Franz Incorporated provides this software "as is" without
14 ;;; express or implied warranty.
15 ;;;
16
17 (in-package :xlib :use '(:foreign-functions :lisp :excl))
18
19 (import '(excl::defcmacro))
20
21 ;;
22 ;; Type predicates
23 ;;
24 (defcmacro card8p (x)
25 (let ((xx (gensym)))
26 `(let ((,xx ,x))
27 (declare (optimize (speed 3) (safety 0))
28 (fixnum ,xx))
29 (and (fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0)))))
30
31 (defcmacro card16p (x)
32 (let ((xx (gensym)))
33 `(let ((,xx ,x))
34 (declare (optimize (speed 3) (safety 0))
35 (fixnum ,xx))
36 (and (fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0)))))
37
38 (defcmacro int8p (x)
39 (let ((xx (gensym)))
40 `(let ((,xx ,x))
41 (declare (optimize (speed 3) (safety 0))
42 (fixnum ,xx))
43 (and (fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7))))))
44
45 (defcmacro int16p (x)
46 (let ((xx (gensym)))
47 `(let ((,xx ,x))
48 (declare (optimize (speed 3) (safety 0))
49 (fixnum ,xx))
50 (and (fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15))))))
51
52 ;; Card29p, card32p, int32p are too large to expand inline
53
54
55 ;;
56 ;; Type transformers
57 ;;
58 (defcmacro card8->int8 (x)
59 (let ((xx (gensym)))
60 `(let ((,xx ,x))
61 ,(declare-bufmac)
62 (declare (type card8 ,xx))
63 (the int8 (if (logbitp 7 ,xx)
64 (the int8 (- ,xx #x100))
65 ,xx)))))
66 (defcmacro int8->card8 (x)
67 `(locally ,(declare-bufmac)
68 (the card8 (ldb (byte 8 0) (the int8 ,x)))))
69
70 (defcmacro card16->int16 (x)
71 (let ((xx (gensym)))
72 `(let ((,xx ,x))
73 ,(declare-bufmac)
74 (declare (type card16 ,xx))
75 (the int16 (if (logbitp 15 ,xx)
76 (the int16 (- ,xx #x10000))
77 ,xx)))))
78
79 (defcmacro int16->card16 (x)
80 `(locally ,(declare-bufmac)
81 (the card16 (ldb (byte 16 0) (the int16 ,x)))))
82
83 (defcmacro card32->int32 (x)
84 (let ((xx (gensym)))
85 `(let ((,xx ,x))
86 ,(declare-bufmac)
87 (declare (type card32 ,xx))
88 (the int32 (if (logbitp 31 ,xx)
89 (the int32 (- ,xx #x100000000))
90 ,xx)))))
91
92 (defcmacro int32->card32 (x)
93 `(locally ,(declare-bufmac)
94 (the card32 (ldb (byte 32 0) (the int32 ,x)))))
95
96 (defcmacro char->card8 (char)
97 `(locally ,(declare-bufmac)
98 (the card8 (char-code (the string-char ,char)))))
99
100 (defcmacro card8->char (card8)
101 `(locally ,(declare-bufmac)
102 (the string-char (code-char (the card8 ,card8)))))
103
104
105 ;;
106 ;; Array accessors and setters
107 ;;
108 (defcmacro aref-card8 (a i)
109 `(locally ,(declare-bufmac)
110 (the card8 (aref (the buffer-bytes ,a) (the array-index ,i)))))
111
112 (defcmacro aset-card8 (v a i)
113 `(locally ,(declare-bufmac)
114 (setf (aref (the buffer-bytes ,a) (the array-index ,i))
115 (the card8 ,v))))
116
117 (defcmacro aref-int8 (a i)
118 `(locally ,(declare-bufmac)
119 (card8->int8 (aref (the buffer-bytes ,a) (the array-index ,i)))))
120
121 (defcmacro aset-int8 (v a i)
122 `(locally ,(declare-bufmac)
123 (setf (aref (the buffer-bytes ,a) (the array-index ,i))
124 (int8->card8 ,v))))
125
126 (defcmacro aref-card16 (a i)
127 `(locally ,(declare-bufmac)
128 (the card16 (sys:memref (the buffer-bytes ,a)
129 #.(comp::mdparam 'comp::md-svector-data0-adj)
130 (the array-index ,i)
131 :unsigned-word))))
132
133 (defcmacro aset-card16 (v a i)
134 `(locally ,(declare-bufmac)
135 (setf (sys:memref (the buffer-bytes ,a)
136 #.(comp::mdparam 'comp::md-svector-data0-adj)
137 (the array-index ,i)
138 :unsigned-word)
139 (the card16 ,v))))
140
141 (defcmacro aref-int16 (a i)
142 `(locally ,(declare-bufmac)
143 (the int16 (sys:memref (the buffer-bytes ,a)
144 #.(comp::mdparam 'comp::md-svector-data0-adj)
145 (the array-index ,i)
146 :signed-word))))
147
148 (defcmacro aset-int16 (v a i)
149 `(locally ,(declare-bufmac)
150 (setf (sys:memref (the buffer-bytes ,a)
151 #.(comp::mdparam 'comp::md-svector-data0-adj)
152 (the array-index ,i)
153 :signed-word)
154 (the int16 ,v))))
155
156 (defcmacro aref-card32 (a i)
157 `(locally ,(declare-bufmac)
158 (the card32 (sys:memref (the buffer-bytes ,a)
159 #.(comp::mdparam 'comp::md-svector-data0-adj)
160 (the array-index ,i)
161 :unsigned-long))))
162
163 (defcmacro aset-card32 (v a i)
164 `(locally ,(declare-bufmac)
165 (setf (sys:memref (the buffer-bytes ,a)
166 #.(comp::mdparam 'comp::md-svector-data0-adj)
167 (the array-index ,i)
168 :unsigned-long)
169 (the card32 ,v))))
170
171 (defcmacro aref-int32 (a i)
172 `(locally ,(declare-bufmac)
173 (the int32 (sys:memref (the buffer-bytes ,a)
174 #.(comp::mdparam 'comp::md-svector-data0-adj)
175 (the array-index ,i)
176 :signed-long))))
177
178 (defcmacro aset-int32 (v a i)
179 `(locally ,(declare-bufmac)
180 (setf (sys:memref (the buffer-bytes ,a)
181 #.(comp::mdparam 'comp::md-svector-data0-adj)
182 (the array-index ,i)
183 :signed-long)
184 (the int32 ,v))))
185
186 (defcmacro aref-card29 (a i)
187 ;; Don't need to mask bits here since X protocol guarantees top bits zero
188 `(locally ,(declare-bufmac)
189 (the card29 (sys:memref (the buffer-bytes ,a)
190 #.(comp::mdparam 'comp::md-svector-data0-adj)
191 (the array-index ,i)
192 :unsigned-long))))
193
194 (defcmacro aset-card29 (v a i)
195 ;; I also assume here Lisp is passing a number that fits in 29 bits.
196 `(locally ,(declare-bufmac)
197 (setf (sys:memref (the buffer-bytes ,a)
198 #.(comp::mdparam 'comp::md-svector-data0-adj)
199 (the array-index ,i)
200 :unsigned-long)
201 (the card29 ,v))))
202
203 ;;
204 ;; Font accessors
205 ;;
206 (defcmacro font-id (font)
207 ;; Get font-id, opening font if needed
208 (let ((f (gensym)))
209 `(let ((,f ,font))
210 (or (font-id-internal ,f)
211 (open-font-internal ,f)))))
212
213 (defcmacro font-font-info (font)
214 (let ((f (gensym)))
215 `(let ((,f ,font))
216 (or (font-font-info-internal ,f)
217 (query-font ,f)))))
218
219 (defcmacro font-char-infos (font)
220 (let ((f (gensym)))
221 `(let ((,f ,font))
222 (or (font-char-infos-internal ,f)
223 (progn (query-font ,f)
224 (font-char-infos-internal ,f))))))
225
226
227 ;;
228 ;; Miscellaneous
229 ;;
230 (defcmacro current-process ()
231 `(the (or mp::process null) (and mp::*scheduler-stack-group*
232 mp::*current-process*)))
233
234 (defcmacro process-wakeup (process)
235 (let ((proc (gensym)))
236 `(let ((.pw-curproc. mp::*current-process*)
237 (,proc ,process))
238 (when (and .pw-curproc. ,proc)
239 (if (> (mp::process-priority ,proc)
240 (mp::process-priority .pw-curproc.))
241 (mp::process-allow-schedule ,proc))))))
242
243 #+notyet
244 (defcmacro buffer-replace (target-sequence source-sequence target-start
245 target-end &optional (source-start 0))
246 (let ((tv (gensym)) (sv (gensym)) (ts (gensym)) (te (gensym)) (ss (gensym)))
247 `(let ((,tv ,target-sequence) (,sv ,source-sequence)
248 (,ts ,target-start) (,te ,target-end) (,ss ,source-start))
249 (declare (type buffer-bytes ,tv ,sv)
250 (type array-index ,ts ,te ,ss)
251 (optimize (speed 3) (safety 0)))
252
253 (let ((source-end (length ,sv)))
254 (declare (type array-index source-end))
255
256 (if* (and (eq ,tv ,sv)
257 (> ,ts ,ss))
258 then (let ((nelts (min (- ,te ,ts)
259 (- source-end ,ss))))
260 (do ((target-index (+ ,ts nelts -1) (1- target-index))
261 (source-index (+ ,ss nelts -1) (1- source-index)))
262 ((= target-index (1- ,ts)) ,tv)
263 (declare (type array-index target-index source-index))
264
265 (setf (aref ,tv target-index)
266 (aref ,sv source-index))))
267 else (do ((target-index ,ts (1+ target-index))
268 (source-index ,ss (1+ source-index)))
269 ((or (= target-index ,te) (= source-index source-end))
270 ,tv)
271 (declare (type array-index target-index source-index))
272
273 (setf (aref ,tv target-index)
274 (aref ,sv source-index))))))))
275
276 (defcmacro buffer-new-request-number (buffer)
277 (let ((buf (gensym)))
278 `(let ((,buf ,buffer))
279 (declare (type buffer ,buf))
280 (setf (buffer-request-number ,buf)
281 (ldb (byte 16 0) (1+ (buffer-request-number ,buf)))))))
282
283 (defcmacro byte-reverse (byte)
284 `(aref ,'#.(coerce
285 '#(0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240
286 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248
287 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244
288 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252
289 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242
290 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250
291 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246
292 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254
293 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241
294 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249
295 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245
296 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253
297 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243
298 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251
299 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247
300 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255)
301 '(vector card8))
302 ,byte))
303
304 #|
305 #+(or allegro-v3.0 allegro-v3.1)
306 (defcmacro graphic-char-p (char)
307 `(let* ((cint (char-int ,char)))
308 (if (and (<= #.(char-code #\space) cint)
309 (<= cint #.(char-code #\~)))
310 t
311 nil)))
312 |#
313

  ViewVC Help
Powered by ViewVC 1.1.5