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

Contents of /src/clx/exclcmac.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Thu Nov 7 16:57:44 1991 UTC (22 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a, RELEASE_18b
Branch point for: RELENG_18
Changes since 1.1: +62 -115 lines
CLX R5 changes.
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)
18
19 ;;
20 ;; Type predicates
21 ;;
22 (excl:defcmacro card8p (x)
23 (let ((xx (gensym)))
24 `(let ((,xx ,x))
25 (declare (optimize (speed 3) (safety 0))
26 (fixnum ,xx))
27 (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0)))))
28
29 (excl:defcmacro card16p (x)
30 (let ((xx (gensym)))
31 `(let ((,xx ,x))
32 (declare (optimize (speed 3) (safety 0))
33 (fixnum ,xx))
34 (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0)))))
35
36 (excl:defcmacro int8p (x)
37 (let ((xx (gensym)))
38 `(let ((,xx ,x))
39 (declare (optimize (speed 3) (safety 0))
40 (fixnum ,xx))
41 (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7))))))
42
43 (excl:defcmacro int16p (x)
44 (let ((xx (gensym)))
45 `(let ((,xx ,x))
46 (declare (optimize (speed 3) (safety 0))
47 (fixnum ,xx))
48 (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15))))))
49
50 ;; Card29p, card32p, int32p are too large to expand inline
51
52
53 ;;
54 ;; Type transformers
55 ;;
56 (excl:defcmacro card8->int8 (x)
57 (let ((xx (gensym)))
58 `(let ((,xx ,x))
59 ,(declare-bufmac)
60 (declare (type card8 ,xx))
61 (the int8 (if (logbitp 7 ,xx)
62 (the int8 (- ,xx #x100))
63 ,xx)))))
64 (excl:defcmacro int8->card8 (x)
65 `(locally ,(declare-bufmac)
66 (the card8 (ldb (byte 8 0) (the int8 ,x)))))
67
68 (excl:defcmacro card16->int16 (x)
69 (let ((xx (gensym)))
70 `(let ((,xx ,x))
71 ,(declare-bufmac)
72 (declare (type card16 ,xx))
73 (the int16 (if (logbitp 15 ,xx)
74 (the int16 (- ,xx #x10000))
75 ,xx)))))
76
77 (excl:defcmacro int16->card16 (x)
78 `(locally ,(declare-bufmac)
79 (the card16 (ldb (byte 16 0) (the int16 ,x)))))
80
81 (excl:defcmacro card32->int32 (x)
82 (let ((xx (gensym)))
83 `(let ((,xx ,x))
84 ,(declare-bufmac)
85 (declare (type card32 ,xx))
86 (the int32 (if (logbitp 31 ,xx)
87 (the int32 (- ,xx #x100000000))
88 ,xx)))))
89
90 (excl:defcmacro int32->card32 (x)
91 `(locally ,(declare-bufmac)
92 (the card32 (ldb (byte 32 0) (the int32 ,x)))))
93
94 (excl:defcmacro char->card8 (char)
95 `(locally ,(declare-bufmac)
96 (the card8 (char-code (the string-char ,char)))))
97
98 (excl:defcmacro card8->char (card8)
99 `(locally ,(declare-bufmac)
100 (the string-char (code-char (the card8 ,card8)))))
101
102
103 ;;
104 ;; Array accessors and setters
105 ;;
106 (excl:defcmacro aref-card8 (a i)
107 `(locally ,(declare-bufmac)
108 (the card8 (sys:memref (the buffer-bytes ,a)
109 #.(comp::mdparam 'comp::md-svector-data0-adj)
110 (the array-index ,i)
111 :unsigned-byte))))
112
113 (excl:defcmacro aset-card8 (v a i)
114 `(locally ,(declare-bufmac)
115 (setf (sys:memref (the buffer-bytes ,a)
116 #.(comp::mdparam 'comp::md-svector-data0-adj)
117 (the array-index ,i)
118 :unsigned-byte)
119 (the card8 ,v))))
120
121 (excl:defcmacro aref-int8 (a i)
122 `(locally ,(declare-bufmac)
123 (the int8 (sys:memref (the buffer-bytes ,a)
124 #.(comp::mdparam 'comp::md-svector-data0-adj)
125 (the array-index ,i)
126 :signed-byte))))
127
128 (excl:defcmacro aset-int8 (v a i)
129 `(locally ,(declare-bufmac)
130 (setf (sys:memref (the buffer-bytes ,a)
131 #.(comp::mdparam 'comp::md-svector-data0-adj)
132 (the array-index ,i)
133 :signed-byte)
134 (the int8 ,v))))
135
136 (excl:defcmacro aref-card16 (a i)
137 `(locally ,(declare-bufmac)
138 (the card16 (sys:memref (the buffer-bytes ,a)
139 #.(comp::mdparam 'comp::md-svector-data0-adj)
140 (the array-index ,i)
141 :unsigned-word))))
142
143 (excl:defcmacro aset-card16 (v a i)
144 `(locally ,(declare-bufmac)
145 (setf (sys:memref (the buffer-bytes ,a)
146 #.(comp::mdparam 'comp::md-svector-data0-adj)
147 (the array-index ,i)
148 :unsigned-word)
149 (the card16 ,v))))
150
151 (excl:defcmacro aref-int16 (a i)
152 `(locally ,(declare-bufmac)
153 (the int16 (sys:memref (the buffer-bytes ,a)
154 #.(comp::mdparam 'comp::md-svector-data0-adj)
155 (the array-index ,i)
156 :signed-word))))
157
158 (excl:defcmacro aset-int16 (v a i)
159 `(locally ,(declare-bufmac)
160 (setf (sys:memref (the buffer-bytes ,a)
161 #.(comp::mdparam 'comp::md-svector-data0-adj)
162 (the array-index ,i)
163 :signed-word)
164 (the int16 ,v))))
165
166 (excl:defcmacro aref-card32 (a i)
167 `(locally ,(declare-bufmac)
168 (the card32 (sys:memref (the buffer-bytes ,a)
169 #.(comp::mdparam 'comp::md-svector-data0-adj)
170 (the array-index ,i)
171 :unsigned-long))))
172
173 (excl:defcmacro aset-card32 (v a i)
174 `(locally ,(declare-bufmac)
175 (setf (sys:memref (the buffer-bytes ,a)
176 #.(comp::mdparam 'comp::md-svector-data0-adj)
177 (the array-index ,i)
178 :unsigned-long)
179 (the card32 ,v))))
180
181 (excl:defcmacro aref-int32 (a i)
182 `(locally ,(declare-bufmac)
183 (the int32 (sys:memref (the buffer-bytes ,a)
184 #.(comp::mdparam 'comp::md-svector-data0-adj)
185 (the array-index ,i)
186 :signed-long))))
187
188 (excl:defcmacro aset-int32 (v a i)
189 `(locally ,(declare-bufmac)
190 (setf (sys:memref (the buffer-bytes ,a)
191 #.(comp::mdparam 'comp::md-svector-data0-adj)
192 (the array-index ,i)
193 :signed-long)
194 (the int32 ,v))))
195
196 (excl:defcmacro aref-card29 (a i)
197 ;; Don't need to mask bits here since X protocol guarantees top bits zero
198 `(locally ,(declare-bufmac)
199 (the card29 (sys:memref (the buffer-bytes ,a)
200 #.(comp::mdparam 'comp::md-svector-data0-adj)
201 (the array-index ,i)
202 :unsigned-long))))
203
204 (excl:defcmacro aset-card29 (v a i)
205 ;; I also assume here Lisp is passing a number that fits in 29 bits.
206 `(locally ,(declare-bufmac)
207 (setf (sys:memref (the buffer-bytes ,a)
208 #.(comp::mdparam 'comp::md-svector-data0-adj)
209 (the array-index ,i)
210 :unsigned-long)
211 (the card29 ,v))))
212
213 ;;
214 ;; Font accessors
215 ;;
216 (excl:defcmacro font-id (font)
217 ;; Get font-id, opening font if needed
218 (let ((f (gensym)))
219 `(let ((,f ,font))
220 (or (font-id-internal ,f)
221 (open-font-internal ,f)))))
222
223 (excl:defcmacro font-font-info (font)
224 (let ((f (gensym)))
225 `(let ((,f ,font))
226 (or (font-font-info-internal ,f)
227 (query-font ,f)))))
228
229 (excl:defcmacro font-char-infos (font)
230 (let ((f (gensym)))
231 `(let ((,f ,font))
232 (or (font-char-infos-internal ,f)
233 (progn (query-font ,f)
234 (font-char-infos-internal ,f))))))
235
236
237 ;;
238 ;; Miscellaneous
239 ;;
240 (excl:defcmacro current-process ()
241 `(the (or mp::process null) (and mp::*scheduler-stack-group*
242 mp::*current-process*)))
243
244 (excl:defcmacro process-wakeup (process)
245 (let ((proc (gensym)))
246 `(let ((.pw-curproc. mp::*current-process*)
247 (,proc ,process))
248 (when (and .pw-curproc. ,proc)
249 (if (> (mp::process-priority ,proc)
250 (mp::process-priority .pw-curproc.))
251 (mp::process-allow-schedule ,proc))))))
252
253 (excl:defcmacro buffer-new-request-number (buffer)
254 (let ((buf (gensym)))
255 `(let ((,buf ,buffer))
256 (declare (type buffer ,buf))
257 (setf (buffer-request-number ,buf)
258 (ldb (byte 16 0) (1+ (buffer-request-number ,buf)))))))
259
260

  ViewVC Help
Powered by ViewVC 1.1.5