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

Contents of /src/clx/exclcmac.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Mon May 14 14:48:21 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ram 1.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