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

Diff of /src/clx/exclcmac.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5