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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Mon Feb 17 13:17:53 2003 UTC (11 years, 2 months ago) by emarsden
Branch: MAIN
CVS Tags: release-18e-base, remove_negative_zero_not_zero, release-18e-pre2, cold-pcl-base, release-18e, release-18e-pre1
Branch point for: release-18e-branch, cold-pcl
Changes since 1.11: +2 -2 lines
Enable type checking code in CLX when the clx-debugging *feature* is
present.
1 ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
2
3 ;; This file contains some of the system dependent code for CLX
4
5 ;;;
6 ;;; TEXAS INSTRUMENTS INCORPORATED
7 ;;; P.O. BOX 2909
8 ;;; AUSTIN, TEXAS 78769
9 ;;;
10 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11 ;;;
12 ;;; Permission is granted to any individual or institution to use, copy, modify,
13 ;;; and distribute this software, provided that this complete copyright and
14 ;;; permission notice is maintained, intact, in all copies and supporting
15 ;;; documentation.
16 ;;;
17 ;;; Texas Instruments Incorporated provides this software "as is" without
18 ;;; express or implied warranty.
19 ;;;
20 #+cmu
21 (ext:file-comment
22 "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/dependent.lisp,v 1.12 2003/02/17 13:17:53 emarsden Exp $")
23
24 (in-package :xlib)
25
26 (proclaim '(declaration array-register))
27
28 #+cmu
29 (setf (getf ext:*herald-items* :xlib)
30 `(" CLX X Library " ,*version*))
31
32 ;;; The size of the output buffer. Must be a multiple of 4.
33 (defparameter *output-buffer-size* 8192)
34
35 ;;; Number of seconds to wait for a reply to a server request
36 (defparameter *reply-timeout* nil)
37
38 #-(or (not clx-little-endian))
39 (progn
40 (defconstant *word-0* 0)
41 (defconstant *word-1* 1)
42
43 (defconstant *long-0* 0)
44 (defconstant *long-1* 1)
45 (defconstant *long-2* 2)
46 (defconstant *long-3* 3))
47
48 #-(or clx-little-endian)
49 (progn
50 (defconstant *word-0* 1)
51 (defconstant *word-1* 0)
52
53 (defconstant *long-0* 3)
54 (defconstant *long-1* 2)
55 (defconstant *long-2* 1)
56 (defconstant *long-3* 0))
57
58 ;;; Set some compiler-options for often used code
59
60 (eval-when (eval compile load)
61
62 (defconstant *buffer-speed* #+clx-debugging 1 #-clx-debugging 3
63 "Speed compiler option for buffer code.")
64 (defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0
65 "Safety compiler option for buffer code.")
66
67 (defun declare-bufmac ()
68 `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
69
70 ;;; It's my impression that in lucid there's some way to make a declaration
71 ;;; called fast-entry or something that causes a function to not do some
72 ;;; checking on args. Sadly, we have no lucid manuals here. If such a
73 ;;; declaration is available, it would be a good idea to make it here when
74 ;;; *buffer-speed* is 3 and *buffer-safety* is 0.
75 (defun declare-buffun ()
76 #+(and cmu clx-debugging)
77 '(declare (optimize (speed 1) (safety 1)))
78 #-(and cmu clx-debugging)
79 `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
80
81 )
82
83 (declaim (inline card8->int8 int8->card8
84 card16->int16 int16->card16
85 card32->int32 int32->card32))
86
87
88 (progn
89
90 (defun card8->int8 (x)
91 (declare (type card8 x))
92 (declare (clx-values int8))
93 #.(declare-buffun)
94 (the int8 (if (logbitp 7 x)
95 (the int8 (- x #x100))
96 x)))
97
98 (defun int8->card8 (x)
99 (declare (type int8 x))
100 (declare (clx-values card8))
101 #.(declare-buffun)
102 (the card8 (ldb (byte 8 0) x)))
103
104 (defun card16->int16 (x)
105 (declare (type card16 x))
106 (declare (clx-values int16))
107 #.(declare-buffun)
108 (the int16 (if (logbitp 15 x)
109 (the int16 (- x #x10000))
110 x)))
111
112 (defun int16->card16 (x)
113 (declare (type int16 x))
114 (declare (clx-values card16))
115 #.(declare-buffun)
116 (the card16 (ldb (byte 16 0) x)))
117
118 (defun card32->int32 (x)
119 (declare (type card32 x))
120 (declare (clx-values int32))
121 #.(declare-buffun)
122 (the int32 (if (logbitp 31 x)
123 (the int32 (- x #x100000000))
124 x)))
125
126 (defun int32->card32 (x)
127 (declare (type int32 x))
128 (declare (clx-values card32))
129 #.(declare-buffun)
130 (the card32 (ldb (byte 32 0) x)))
131
132 )
133
134 (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
135
136
137 (progn
138
139 (defun aref-card8 (a i)
140 (declare (type buffer-bytes a)
141 (type array-index i))
142 (declare (clx-values card8))
143 #.(declare-buffun)
144 (the card8 (aref a i)))
145
146 (defun aset-card8 (v a i)
147 (declare (type card8 v)
148 (type buffer-bytes a)
149 (type array-index i))
150 #.(declare-buffun)
151 (setf (aref a i) v))
152
153 (defun aref-int8 (a i)
154 (declare (type buffer-bytes a)
155 (type array-index i))
156 (declare (clx-values int8))
157 #.(declare-buffun)
158 (card8->int8 (aref a i)))
159
160 (defun aset-int8 (v a i)
161 (declare (type int8 v)
162 (type buffer-bytes a)
163 (type array-index i))
164 #.(declare-buffun)
165 (setf (aref a i) (int8->card8 v)))
166
167 )
168
169
170 (progn
171
172 (defun aref-card16 (a i)
173 (declare (type buffer-bytes a)
174 (type array-index i))
175 (declare (clx-values card16))
176 #.(declare-buffun)
177 (the card16
178 (logior (the card16
179 (ash (the card8 (aref a (index+ i *word-1*))) 8))
180 (the card8
181 (aref a (index+ i *word-0*))))))
182
183 (defun aset-card16 (v a i)
184 (declare (type card16 v)
185 (type buffer-bytes a)
186 (type array-index i))
187 #.(declare-buffun)
188 (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
189 (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
190 v)
191
192 (defun aref-int16 (a i)
193 (declare (type buffer-bytes a)
194 (type array-index i))
195 (declare (clx-values int16))
196 #.(declare-buffun)
197 (the int16
198 (logior (the int16
199 (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))
200 (the card8
201 (aref a (index+ i *word-0*))))))
202
203 (defun aset-int16 (v a i)
204 (declare (type int16 v)
205 (type buffer-bytes a)
206 (type array-index i))
207 #.(declare-buffun)
208 (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
209 (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
210 v)
211
212 (defun aref-card32 (a i)
213 (declare (type buffer-bytes a)
214 (type array-index i))
215 (declare (clx-values card32))
216 #.(declare-buffun)
217 (the card32
218 (logior (the card32
219 (ash (the card8 (aref a (index+ i *long-3*))) 24))
220 (the card29
221 (ash (the card8 (aref a (index+ i *long-2*))) 16))
222 (the card16
223 (ash (the card8 (aref a (index+ i *long-1*))) 8))
224 (the card8
225 (aref a (index+ i *long-0*))))))
226
227 (defun aset-card32 (v a i)
228 (declare (type card32 v)
229 (type buffer-bytes a)
230 (type array-index i))
231 #.(declare-buffun)
232 (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
233 (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
234 (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
235 (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
236 v)
237
238 (defun aref-int32 (a i)
239 (declare (type buffer-bytes a)
240 (type array-index i))
241 (declare (clx-values int32))
242 #.(declare-buffun)
243 (the int32
244 (logior (the int32
245 (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))
246 (the card29
247 (ash (the card8 (aref a (index+ i *long-2*))) 16))
248 (the card16
249 (ash (the card8 (aref a (index+ i *long-1*))) 8))
250 (the card8
251 (aref a (index+ i *long-0*))))))
252
253 (defun aset-int32 (v a i)
254 (declare (type int32 v)
255 (type buffer-bytes a)
256 (type array-index i))
257 #.(declare-buffun)
258 (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
259 (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
260 (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
261 (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
262 v)
263
264 (defun aref-card29 (a i)
265 (declare (type buffer-bytes a)
266 (type array-index i))
267 (declare (clx-values card29))
268 #.(declare-buffun)
269 (the card29
270 (logior (the card29
271 (ash (the card8 (aref a (index+ i *long-3*))) 24))
272 (the card29
273 (ash (the card8 (aref a (index+ i *long-2*))) 16))
274 (the card16
275 (ash (the card8 (aref a (index+ i *long-1*))) 8))
276 (the card8
277 (aref a (index+ i *long-0*))))))
278
279 (defun aset-card29 (v a i)
280 (declare (type card29 v)
281 (type buffer-bytes a)
282 (type array-index i))
283 #.(declare-buffun)
284 (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
285 (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
286 (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
287 (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
288 v)
289
290 )
291
292 (defsetf aref-card8 (a i) (v)
293 `(aset-card8 ,v ,a ,i))
294
295 (defsetf aref-int8 (a i) (v)
296 `(aset-int8 ,v ,a ,i))
297
298 (defsetf aref-card16 (a i) (v)
299 `(aset-card16 ,v ,a ,i))
300
301 (defsetf aref-int16 (a i) (v)
302 `(aset-int16 ,v ,a ,i))
303
304 (defsetf aref-card32 (a i) (v)
305 `(aset-card32 ,v ,a ,i))
306
307 (defsetf aref-int32 (a i) (v)
308 `(aset-int32 ,v ,a ,i))
309
310 (defsetf aref-card29 (a i) (v)
311 `(aset-card29 ,v ,a ,i))
312
313 ;;; Other random conversions
314
315 (defun rgb-val->card16 (value)
316 ;; Short floats are good enough
317 (declare (type rgb-val value))
318 (declare (clx-values card16))
319 #.(declare-buffun)
320 ;; Convert VALUE from float to card16
321 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
322
323 (defun card16->rgb-val (value)
324 ;; Short floats are good enough
325 (declare (type card16 value))
326 (declare (clx-values short-float))
327 #.(declare-buffun)
328 ;; Convert VALUE from card16 to float
329 (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
330
331 (defun radians->int16 (value)
332 ;; Short floats are good enough
333 (declare (type angle value))
334 (declare (clx-values int16))
335 #.(declare-buffun)
336 (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
337
338 (defun int16->radians (value)
339 ;; Short floats are good enough
340 (declare (type int16 value))
341 (declare (clx-values short-float))
342 #.(declare-buffun)
343 (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
344
345
346 #+cmu
347 (progn
348
349 ;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI
350 ;;; is irrational, there can't be a precise rational representation. In
351 ;;; particular, the different float approximations will always be /=. This
352 ;;; causes problems with type checking, because people might compute an
353 ;;; argument in any precision. What we do is discard all the excess precision
354 ;;; in the value, and see if the protocal encoding falls in the desired range
355 ;;; (64'ths of a degree.)
356 ;;;
357 (deftype angle () '(satisfies anglep))
358
359 (defun anglep (x)
360 (and (typep x 'real)
361 (<= (* -360 64) (radians->int16 x) (* 360 64))))
362
363 )
364
365
366 ;;-----------------------------------------------------------------------------
367 ;; Character transformation
368 ;;-----------------------------------------------------------------------------
369
370
371 ;;; This stuff transforms chars to ascii codes in card8's and back.
372 ;;; You might have to hack it a little to get it to work for your machine.
373
374 (declaim (inline char->card8 card8->char))
375
376 (macrolet ((char-translators ()
377 (let ((alist
378 `(;; The normal ascii codes for the control characters.
379 ,@`((#\Return . 13)
380 (#\Linefeed . 10)
381 (#\Rubout . 127)
382 (#\Page . 12)
383 (#\Tab . 9)
384 (#\Backspace . 8)
385 (#\Newline . 10)
386 (#\Space . 32))
387
388 ;; The rest of the common lisp charater set with the normal
389 ;; ascii codes for them.
390 (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
391 (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
392 (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
393 (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
394 (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
395 (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
396 (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
397 (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
398 (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
399 (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
400 (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
401 (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
402 (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
403 (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
404 (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
405 (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
406 (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
407 (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
408 (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
409 (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
410 (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
411 (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
412 (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
413 (#\} . 125) (#\~ . 126))))
414 (cond ((dolist (pair alist nil)
415 (when (not (= (char-code (car pair)) (cdr pair)))
416 (return t)))
417 `(progn
418 (defconstant *char-to-card8-translation-table*
419 ',(let ((array (make-array
420 (let ((max-char-code 255))
421 (dolist (pair alist)
422 (setq max-char-code
423 (max max-char-code
424 (char-code (car pair)))))
425 (1+ max-char-code))
426 :element-type 'card8)))
427 (dotimes (i (length array))
428 (setf (aref array i) (mod i 256)))
429 (dolist (pair alist)
430 (setf (aref array (char-code (car pair)))
431 (cdr pair)))
432 array))
433 (defconstant *card8-to-char-translation-table*
434 ',(let ((array (make-array 256)))
435 (dotimes (i (length array))
436 (setf (aref array i) (code-char i)))
437 (dolist (pair alist)
438 (setf (aref array (cdr pair)) (car pair)))
439 array))
440 (progn
441 (defun char->card8 (char)
442 (declare (type base-char char))
443 #.(declare-buffun)
444 (the card8 (aref (the (simple-array card8 (*))
445 *char-to-card8-translation-table*)
446 (the array-index (char-code char)))))
447 (defun card8->char (card8)
448 (declare (type card8 card8))
449 #.(declare-buffun)
450 (the base-char
451 (or (aref (the simple-vector *card8-to-char-translation-table*)
452 card8)
453 (error "Invalid CHAR code ~D." card8))))
454 )
455 (dotimes (i 256)
456 (unless (= i (char->card8 (card8->char i)))
457 (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S"
458 (list i
459 (card8->char i)
460 (char->card8 (card8->char i))))
461 (return nil)))
462 (dotimes (i (length *char-to-card8-translation-table*))
463 (let ((char (code-char i)))
464 (unless (eql char (card8->char (char->card8 char)))
465 (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S"
466 (list char
467 (char->card8 char)
468 (card8->char (char->card8 char))))
469 (return nil))))))
470 (t
471 `(progn
472 (defun char->card8 (char)
473 (declare (type base-char char))
474 #.(declare-buffun)
475 (the card8 (char-code char)))
476 (defun card8->char (card8)
477 (declare (type card8 card8))
478 #.(declare-buffun)
479 (the base-char (code-char card8)))
480 ))))))
481 (char-translators))
482
483 ;;-----------------------------------------------------------------------------
484 ;; Process Locking
485 ;;
486 ;; Common-Lisp doesn't provide process locking primitives, so we define
487 ;; our own here, based on Zetalisp primitives. Holding-Lock is very
488 ;; similar to with-lock on The TI Explorer, and a little more efficient
489 ;; than with-process-lock on a Symbolics.
490 ;;-----------------------------------------------------------------------------
491
492 ;;; MAKE-PROCESS-LOCK: Creating a process lock.
493
494 #-(or (and cmu mp))
495 (defun make-process-lock (name)
496 (declare (ignore name))
497 nil)
498
499
500 #+(and cmu mp)
501 (defun make-process-lock (name)
502 (mp:make-lock name))
503
504 ;;; HOLDING-LOCK: Execute a body of code with a lock held.
505
506 ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN
507 ;;; passes its timeout to the holding-lock macro, so any timeout you want to
508 ;;; work for event-listen you should do for holding-lock.
509
510 ;; If you're not sharing DISPLAY objects within a multi-processing
511 ;; shared-memory environment, this is sufficient
512 #-(or (and CMU mp))
513 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
514 (declare (ignore locator display whostate timeout))
515 `(progn ,@body))
516
517 ;;; HOLDING-LOCK for CMU Common Lisp.
518 ;;;
519 ;;; We are not multi-processing, but we use this macro to try to protect
520 ;;; against re-entering request functions. This can happen if an interrupt
521 ;;; occurs and the handler attempts to use X over the same display connection.
522 ;;; This can happen if the GC hooks are used to notify the user over the same
523 ;;; display connection. We inhibit GC notifications since display of them
524 ;;; could cause recursive entry into CLX.
525 ;;;
526 #+(and CMU (not mp))
527 (defmacro holding-lock ((locator display &optional whostate &key timeout)
528 &body body)
529 `(let ((ext:*gc-verbose* nil)
530 (ext:*gc-inhibit-hook* nil)
531 (ext:*before-gc-hooks* nil)
532 (ext:*after-gc-hooks* nil))
533 ,locator ,display ,whostate ,timeout
534 (system:without-interrupts (progn ,@body))))
535
536 ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
537 ;;;
538 #+(and cmu mp)
539 (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
540 &key timeout)
541 &body body)
542 (declare (ignore display))
543 `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
544 ,@body))
545
546
547 ;;; WITHOUT-ABORTS
548
549 ;;; If you can inhibit asynchronous keyboard aborts inside the body of this
550 ;;; macro, then it is a good idea to do this. This macro is wrapped around
551 ;;; request writing and reply reading to ensure that requests are atomically
552 ;;; written and replies are atomically read from the stream.
553
554 #-(or Genera excl lcl3.0)
555 (defmacro without-aborts (&body body)
556 `(progn ,@body))
557
558 ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
559 ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
560 ;;; value changes.
561
562 #-(or (and cmu mp))
563 (defun process-block (whostate predicate &rest predicate-args)
564 (declare (ignore whostate))
565 (or (apply predicate predicate-args)
566 (error "Program tried to wait with no scheduler.")))
567
568 #+(and cmu mp)
569 (defun process-block (whostate predicate &rest predicate-args)
570 (declare (type function predicate))
571 (mp:process-wait whostate #'(lambda ()
572 (apply predicate predicate-args))))
573
574 ;;; PROCESS-WAKEUP: Check some other process' wait function.
575
576 (declaim (inline process-wakeup))
577
578 #-(or (and cmu mp))
579 (defun process-wakeup (process)
580 (declare (ignore process))
581 nil)
582
583 #+(and cmu mp)
584 (defun process-wakeup (process)
585 (declare (ignore process))
586 (mp:process-yield))
587
588 ;;; CURRENT-PROCESS: Return the current process object for input locking and
589 ;;; for calling PROCESS-WAKEUP.
590
591 (declaim (inline current-process))
592
593 ;;; Default return NIL, which is acceptable even if there is a scheduler.
594
595 #-(or (and cmu mp))
596 (defun current-process ()
597 nil)
598
599 #+(and cmu mp)
600 (defun current-process ()
601 mp:*current-process*)
602
603 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
604
605 #-(or cmu)
606 (defmacro without-interrupts (&body body)
607 `(progn ,@body))
608
609 #+cmu
610 (defmacro without-interrupts (&body body)
611 `(sys:without-interrupts ,@body))
612
613 ;;; CONDITIONAL-STORE:
614
615 ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
616 ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
617 (defmacro conditional-store (place old-value new-value)
618 `(without-interrupts
619 (cond ((eq ,place ,old-value)
620 (setf ,place ,new-value)
621 t))))
622
623 ;;;----------------------------------------------------------------------------
624 ;;; IO Error Recovery
625 ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro.
626 ;;; It prevents multiple mindless errors when the network craters.
627 ;;;
628 ;;;----------------------------------------------------------------------------
629
630 (defmacro wrap-buf-output ((buffer) &body body)
631 ;; Error recovery wrapper
632 `(unless (buffer-dead ,buffer)
633 ,@body))
634
635 (defmacro wrap-buf-input ((buffer) &body body)
636 (declare (ignore buffer))
637 ;; Error recovery wrapper
638 `(progn ,@body))
639
640
641 ;;;----------------------------------------------------------------------------
642 ;;; System dependent IO primitives
643 ;;; Functions for opening, reading writing forcing-output and closing
644 ;;; the stream to the server.
645 ;;;----------------------------------------------------------------------------
646
647 ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
648 ;;; server
649
650 #-(or CMU)
651 (defun open-x-stream (host display protocol)
652 host display protocol ;; unused
653 (error "OPEN-X-STREAM not implemented yet."))
654
655 ;;; OPEN-X-STREAM -- for CMU Common Lisp.
656 ;;;
657 ;;; The file descriptor here just gets tossed into the stream slot of the
658 ;;; display object instead of a stream.
659 ;;;
660 #+cmu
661 (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
662 c-call:int
663 (host c-call:c-string)
664 (port c-call:int))
665 #+cmu
666 (defun open-x-stream (host display protocol)
667 (declare (ignore protocol))
668 (let ((server-fd (connect-to-server host display)))
669 (unless (plusp server-fd)
670 (error "Failed to connect to X11 server: ~A (display ~D)" host display))
671 (system:make-fd-stream server-fd :input t :output t
672 :element-type '(unsigned-byte 8))))
673
674
675 ;;; BUFFER-READ-DEFAULT - read data from the X stream
676
677 ;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
678 ;;;
679 ;;; If timeout is 0, then we call LISTEN to see if there is any input.
680 ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without
681 ;;; first calling BUFFER-INPUT-WAIT-DEFAULT.
682 ;;;
683 #+CMU
684 (defun buffer-read-default (display vector start end timeout)
685 (declare (type display display)
686 (type buffer-bytes vector)
687 (type array-index start end)
688 (type (or null fixnum) timeout))
689 #.(declare-buffun)
690 (cond ((and (eql timeout 0)
691 (not (listen (display-input-stream display))))
692 :timeout)
693 (t
694 (system:read-n-bytes (display-input-stream display)
695 vector start (- end start))
696 nil)))
697
698
699 ;;; WARNING:
700 ;;; CLX performance will suffer if your lisp uses read-byte for
701 ;;; receiving all data from the X Window System server.
702 ;;; You are encouraged to write a specialized version of
703 ;;; buffer-read-default that does block transfers.
704 #-(or CMU)
705 (defun buffer-read-default (display vector start end timeout)
706 (declare (type display display)
707 (type buffer-bytes vector)
708 (type array-index start end)
709 (type (or null (real 0 *)) timeout))
710 #.(declare-buffun)
711 (let ((stream (display-input-stream display)))
712 (declare (type (or null stream) stream))
713 (or (cond ((null stream))
714 ((listen stream) nil)
715 ((and timeout (= timeout 0)) :timeout)
716 ((buffer-input-wait-default display timeout)))
717 (do* ((index start (index1+ index)))
718 ((index>= index end) nil)
719 (declare (type array-index index))
720 (let ((c (read-byte stream nil nil)))
721 (declare (type (or null card8) c))
722 (if (null c)
723 (return t)
724 (setf (aref vector index) (the card8 c))))))))
725
726 ;;; BUFFER-WRITE-DEFAULT - write data to the X stream
727
728 #+CMU
729 (defun buffer-write-default (vector display start end)
730 (declare (type buffer-bytes vector)
731 (type display display)
732 (type array-index start end))
733 #.(declare-buffun)
734 (system:output-raw-bytes (display-output-stream display) vector start end)
735 nil)
736
737 ;;; WARNING:
738 ;;; CLX performance will be severely degraded if your lisp uses
739 ;;; write-byte to send all data to the X Window System server.
740 ;;; You are STRONGLY encouraged to write a specialized version
741 ;;; of buffer-write-default that does block transfers.
742
743 #-(or CMU)
744 (defun buffer-write-default (vector display start end)
745 ;; The default buffer write function for use with common-lisp streams
746 (declare (type buffer-bytes vector)
747 (type display display)
748 (type array-index start end))
749 #.(declare-buffun)
750 (let ((stream (display-output-stream display)))
751 (declare (type (or null stream) stream))
752 (unless (null stream)
753 (with-vector (vector buffer-bytes)
754 (do ((index start (index1+ index)))
755 ((index>= index end))
756 (declare (type array-index index))
757 (write-byte (aref vector index) stream))))))
758
759 #+CMU
760 (defun buffer-write-default (vector display start end)
761 (declare (type buffer-bytes vector)
762 (type display display)
763 (type array-index start end))
764 #.(declare-buffun)
765 (system:output-raw-bytes (display-output-stream display) vector start end)
766 nil)
767
768 ;;; buffer-force-output-default - force output to the X stream
769
770 (defun buffer-force-output-default (display)
771 ;; The default buffer force-output function for use with common-lisp streams
772 (declare (type display display))
773 (let ((stream (display-output-stream display)))
774 (declare (type (or null stream) stream))
775 (unless (null stream)
776 (force-output stream))))
777
778 ;;; BUFFER-CLOSE-DEFAULT - close the X stream
779
780 (defun buffer-close-default (display &key abort)
781 ;; The default buffer close function for use with common-lisp streams
782 (declare (type display display))
783 #.(declare-buffun)
784 (let ((stream (display-output-stream display)))
785 (declare (type (or null stream) stream))
786 (unless (null stream)
787 (close stream :abort abort))))
788
789 ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
790 ;;; buffer. This is called in read-input between requests, so that a process
791 ;;; waiting for input is abortable when between requests. Should return
792 ;;; :TIMEOUT if it times out, NIL otherwise.
793
794 ;;; The default implementation
795
796 ;; Poll for input every *buffer-read-polling-time* SECONDS.
797 #-(or CMU)
798 (defparameter *buffer-read-polling-time* 0.5)
799
800 #-(or CMU)
801 (defun buffer-input-wait-default (display timeout)
802 (declare (type display display)
803 (type (or null (real 0 *)) timeout))
804 (declare (clx-values timeout))
805
806 (let ((stream (display-input-stream display)))
807 (declare (type (or null stream) stream))
808 (cond ((null stream))
809 ((listen stream) nil)
810 ((and timeout (= timeout 0)) :timeout)
811 ((not (null timeout))
812 (multiple-value-bind (npoll fraction)
813 (truncate timeout *buffer-read-polling-time*)
814 (dotimes (i npoll) ; Sleep for a time, then listen again
815 (sleep *buffer-read-polling-time*)
816 (when (listen stream)
817 (return-from buffer-input-wait-default nil)))
818 (when (plusp fraction)
819 (sleep fraction) ; Sleep a fraction of a second
820 (when (listen stream) ; and listen one last time
821 (return-from buffer-input-wait-default nil)))
822 :timeout)))))
823
824 #+CMU
825 (defun buffer-input-wait-default (display timeout)
826 (declare (type display display)
827 (type (or null number) timeout))
828 (let ((stream (display-input-stream display)))
829 (declare (type (or null stream) stream))
830 (cond ((null stream))
831 ((listen stream) nil)
832 ((eql timeout 0) :timeout)
833 (t
834 (if #-mp (system:wait-until-fd-usable (system:fd-stream-fd stream)
835 :input timeout)
836 #+mp (mp:process-wait-until-fd-usable
837 (system:fd-stream-fd stream) :input timeout)
838 nil
839 :timeout)))))
840
841
842 ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
843 ;;; buffer. This should never block, so it can be called from the scheduler.
844
845 ;;; The default implementation is to just use listen.
846
847 (defun buffer-listen-default (display)
848 (declare (type display display))
849 (let ((stream (display-input-stream display)))
850 (declare (type (or null stream) stream))
851 (if (null stream)
852 t
853 (listen stream))))
854
855
856 ;;;----------------------------------------------------------------------------
857 ;;; System dependent speed hacks
858 ;;;----------------------------------------------------------------------------
859
860 ;;
861 ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
862 ;; If your lisp doesn't have stack-lists, and you're worried about
863 ;; consing garbage, you may want to re-write this to allocate and
864 ;; initialize lists from a resource.
865 ;;
866 (defmacro with-stack-list ((var &rest elements) &body body)
867 ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
868 ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
869 ;; except that the list produced by MAPCAR resides on the stack and
870 ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
871 `(let ((,var (list ,@elements)))
872 (declare (type cons ,var)
873 (dynamic-extent ,var))
874 ,@body))
875
876 (defmacro with-stack-list* ((var &rest elements) &body body)
877 ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
878 ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
879 ;; except that the list produced by MAPCAR resides on the stack and
880 ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
881 `(let ((,var (list* ,@elements)))
882 (declare (type cons ,var)
883 (dynamic-extent ,var))
884 ,@body))
885
886 (declaim (inline buffer-replace))
887
888 #+cmu
889 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
890 (declare (type buffer-bytes buf1 buf2)
891 (type array-index start1 end1 start2))
892 #.(declare-buffun)
893 (kernel:bit-bash-copy
894 buf2 (+ (* start2 vm:byte-bits)
895 (* vm:vector-data-offset vm:word-bits))
896 buf1 (+ (* start1 vm:byte-bits)
897 (* vm:vector-data-offset vm:word-bits))
898 (* (- end1 start1) vm:byte-bits)))
899
900 #-CMU
901 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
902 (declare (type buffer-bytes buf1 buf2)
903 (type array-index start1 end1 start2))
904 (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
905
906 (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
907 &body body)
908 (let ((local-state (gensym))
909 (resets nil))
910 (dolist (index indexes)
911 (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
912 resets))
913 `(unwind-protect
914 (progn
915 ,@body)
916 (let ((,local-state (gcontext-local-state ,gc)))
917 (declare (type gcontext-state ,local-state))
918 ,@resets
919 (setf (svref ,local-state ,ts-index) 0))
920 (when ,temp-gc
921 (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
922 (deallocate-gcontext-state ,saved-state))))
923
924 ;;;----------------------------------------------------------------------------
925 ;;; How error detection should CLX do?
926 ;;; Several levels are possible:
927 ;;;
928 ;;; 1. Do the equivalent of check-type on every argument.
929 ;;;
930 ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format
931 ;;; strings generated by check-type.
932 ;;;
933 ;;; 3. Do error checking only on arguments that are likely to have errors
934 ;;; (like keyword names)
935 ;;;
936 ;;; 4. Do error checking only where not doing so may dammage the envirnment
937 ;;; on a non-tagged machine (i.e. when storing into a structure that has
938 ;;; been passed in)
939 ;;;
940 ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to
941 ;;; store a non-integer into a number array.
942 ;;;
943 ;;; How extensive should the error checking be? For example, if the server
944 ;;; expects a CARD16, is is sufficient for CLX to check for integer, or
945 ;;; should it also check for non-negative and less than 65536?
946 ;;;----------------------------------------------------------------------------
947
948 ;; The *TYPE-CHECK?* constant controls how much error checking is done.
949 ;; Possible values are:
950 ;; NIL - Don't do any error checking
951 ;; t - Do the equivalent of checktype on every argument
952 ;; :minimal - Do error checking only where errors are likely
953
954 ;;; This controls macro expansion, and isn't changable at run-time You will
955 ;;; probably want to set this to nil if you want good performance at
956 ;;; production time.
957 (defconstant *type-check?* #+clx-debugging t #-clx-debugging nil)
958
959 ;; TYPE? is used to allow the code to do error checking at a different level from
960 ;; the declarations. It also does some optimizations for systems that don't have
961 ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc.
962 ;; include range checks. You can modify TYPE? to do less extensive checking
963 ;; for these types if you desire.
964
965 ;;
966 ;; ### This comment is a lie! TYPE? is really also used for run-time type
967 ;; dispatching, not just type checking. -- Ram.
968
969 (defmacro type? (object type)
970 `(typep ,object ,type))
971
972 ;; X-TYPE-ERROR is the function called for type errors.
973 ;; If you want lots of checking, but are concerned about code size,
974 ;; this can be made into a macro that ignores some parameters.
975
976 (defun x-type-error (object type &optional error-string)
977 (x-error 'x-type-error
978 :datum object
979 :expected-type type
980 :type-string error-string))
981
982
983 ;;-----------------------------------------------------------------------------
984 ;; Error handlers
985 ;; Hack up KMP error signaling using zetalisp until the real thing comes
986 ;; along
987 ;;-----------------------------------------------------------------------------
988
989 (defun default-error-handler (display error-key &rest key-vals
990 &key asynchronous &allow-other-keys)
991 (declare (type generalized-boolean asynchronous)
992 (dynamic-extent key-vals))
993 ;; The default display-error-handler.
994 ;; It signals the conditions listed in the DISPLAY file.
995 (if asynchronous
996 (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)
997 (apply #'x-error error-key :display display :error-key error-key key-vals)))
998
999 (defun x-error (condition &rest keyargs)
1000 (declare (dynamic-extent keyargs))
1001 (apply #'error condition keyargs))
1002
1003 (defun x-cerror (proceed-format-string condition &rest keyargs)
1004 (declare (dynamic-extent keyargs))
1005 (apply #'cerror proceed-format-string condition keyargs))
1006
1007 ;;; X-ERROR for CMU Common Lisp
1008 ;;;
1009 ;;; We detect a couple condition types for which we disable event handling in
1010 ;;; our system. This prevents going into the debugger or returning to a
1011 ;;; command prompt with CLX repeatedly seeing the same condition. This occurs
1012 ;;; because CMU Common Lisp provides for all events (that is, X, input on file
1013 ;;; descriptors, Mach messages, etc.) to come through one routine anyone can
1014 ;;; use to wait for input.
1015 ;;;
1016 #+(and CMU (not mp))
1017 (defun x-error (condition &rest keyargs)
1018 (let ((condx (apply #'make-condition condition keyargs)))
1019 (when (eq condition 'closed-display)
1020 (let ((disp (closed-display-display condx)))
1021 (warn "Disabled event handling on ~S." disp)
1022 (ext::disable-clx-event-handling disp)))
1023 (error condx)))
1024
1025
1026 (define-condition x-error (error) ())
1027
1028
1029
1030 ;;-----------------------------------------------------------------------------
1031 ;; HOST hacking
1032 ;;-----------------------------------------------------------------------------
1033
1034 #-(or CMU)
1035 (defun host-address (host &optional (family :internet))
1036 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
1037 ;; and cdr is a list of network address bytes.
1038 (declare (type stringable host)
1039 (type (or null (member :internet :decnet :chaos) card8) family))
1040 (declare (clx-values list))
1041 host family
1042 (error "HOST-ADDRESS not implemented yet."))
1043
1044 #+CMU
1045 (defun host-address (host &optional (family :internet))
1046 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
1047 ;; and cdr is a list of network address bytes.
1048 (declare (type stringable host)
1049 (type (or null (member :internet :decnet :chaos) card8) family))
1050 (declare (clx-values list))
1051 (labels ((no-host-error ()
1052 (error "Unknown host ~S" host))
1053 (no-address-error ()
1054 (error "Host ~S has no ~S address" host family)))
1055 (let ((hostent (ext:lookup-host-entry (string host))))
1056 (when (not hostent)
1057 (no-host-error))
1058 (ecase family
1059 ((:internet nil 0)
1060 (unless (= (ext::host-entry-addr-type hostent) 2)
1061 (no-address-error))
1062 (let ((addr (first (ext::host-entry-addr-list hostent))))
1063 (list :internet
1064 (ldb (byte 8 24) addr)
1065 (ldb (byte 8 16) addr)
1066 (ldb (byte 8 8) addr)
1067 (ldb (byte 8 0) addr))))))))
1068
1069
1070 ;;-----------------------------------------------------------------------------
1071 ;; Whether to use closures for requests or not.
1072 ;;-----------------------------------------------------------------------------
1073
1074 ;;; If this macro expands to non-NIL, then request and locking code is
1075 ;;; compiled in a much more compact format, as the common code is shared, and
1076 ;;; the specific code is built into a closure that is funcalled by the shared
1077 ;;; code. If your compiler makes efficient use of closures then you probably
1078 ;;; want to make this expand to T, as it makes the code more compact.
1079
1080 (defmacro use-closures ()
1081 nil)
1082
1083 (defun clx-macroexpand (form env)
1084 (macroexpand form env))
1085
1086
1087 ;;-----------------------------------------------------------------------------
1088 ;; Resource stuff
1089 ;;-----------------------------------------------------------------------------
1090
1091
1092 ;;; Utilities
1093
1094 (defun getenv (name)
1095 #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
1096 #-(or CMU) (progn name nil))
1097
1098 (defun homedir-file-pathname (name)
1099 (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
1100 (merge-pathnames (user-homedir-pathname) (pathname name))))
1101
1102 ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
1103 ;;; a resource manager isn't running.
1104
1105 (defun default-resources-pathname ()
1106 (homedir-file-pathname ".Xdefaults"))
1107
1108 ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
1109 ;;; defaults have been loaded.
1110
1111 (defun resources-pathname ()
1112 (or (let ((string (getenv "XENVIRONMENT")))
1113 (and string
1114 (pathname string)))
1115 (homedir-file-pathname (concatenate 'string ".Xdefaults-" (machine-instance)))))
1116
1117 ;;; AUTHORITY-PATHNAME - The pathname of the authority file.
1118
1119 (defun authority-pathname ()
1120 (or (let ((xauthority (getenv "XAUTHORITY")))
1121 (and xauthority
1122 (pathname xauthority)))
1123 (homedir-file-pathname ".Xauthority")))
1124
1125
1126 ;;-----------------------------------------------------------------------------
1127 ;; GC stuff
1128 ;;-----------------------------------------------------------------------------
1129
1130 (defun gc-cleanup ()
1131 (declare (special *event-free-list*
1132 *pending-command-free-list*
1133 *reply-buffer-free-lists*
1134 *gcontext-local-state-cache*
1135 *temp-gcontext-cache*))
1136 (setq *event-free-list* nil)
1137 (setq *pending-command-free-list* nil)
1138 (when (boundp '*reply-buffer-free-lists*)
1139 (fill *reply-buffer-free-lists* nil))
1140 (setq *gcontext-local-state-cache* nil)
1141 (setq *temp-gcontext-cache* nil)
1142 nil)
1143
1144
1145
1146 ;;-----------------------------------------------------------------------------
1147 ;; DEFAULT-KEYSYM-TRANSLATE
1148 ;;-----------------------------------------------------------------------------
1149
1150 ;;; If object is a character, char-bits are set from state.
1151 ;;;
1152 ;;; [the following isn't implemented (should it be?)]
1153 ;;; If object is a list, it is an alist with entries:
1154 ;;; (base-char [modifiers] [mask-modifiers])
1155 ;;; When MODIFIERS are specified, this character translation
1156 ;;; will only take effect when the specified modifiers are pressed.
1157 ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
1158 ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
1159 ;;; In ambiguous cases, the most specific translation is used.
1160
1161
1162 (defun default-keysym-translate (display state object)
1163 (declare (type display display)
1164 (type card16 state)
1165 (type t object)
1166 (ignore display state)
1167 (clx-values t))
1168 object)
1169
1170
1171 ;;-----------------------------------------------------------------------------
1172 ;; Image stuff
1173 ;;-----------------------------------------------------------------------------
1174
1175 ;;; Types
1176
1177 (deftype pixarray-1-element-type ()
1178 'bit)
1179
1180 (deftype pixarray-4-element-type ()
1181 '(unsigned-byte 4))
1182
1183 (deftype pixarray-8-element-type ()
1184 '(unsigned-byte 8))
1185
1186 (deftype pixarray-16-element-type ()
1187 '(unsigned-byte 16))
1188
1189 (deftype pixarray-24-element-type ()
1190 '(unsigned-byte 24))
1191
1192 (deftype pixarray-32-element-type ()
1193 '(unsigned-byte 32))
1194
1195 (deftype pixarray-1 ()
1196 '(simple-array pixarray-1-element-type (* *)))
1197
1198 (deftype pixarray-4 ()
1199 '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))
1200
1201 (deftype pixarray-8 ()
1202 '(simple-array pixarray-8-element-type (* *)))
1203
1204 (deftype pixarray-16 ()
1205 '(simple-array pixarray-16-element-type (* *)))
1206
1207 (deftype pixarray-24 ()
1208 '(simple-array pixarray-24-element-type (* *)))
1209
1210 (deftype pixarray-32 ()
1211 '(simple-array pixarray-32-element-type (* *)))
1212
1213 (deftype pixarray ()
1214 '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
1215
1216 (deftype bitmap ()
1217 'pixarray-1)
1218
1219 ;;; WITH-UNDERLYING-SIMPLE-VECTOR
1220
1221 #+CMU
1222 ;;; We do *NOT* support viewing an array as having a different element type.
1223 ;;; Element-type is ignored.
1224 ;;;
1225 (defmacro with-underlying-simple-vector
1226 ((variable element-type pixarray) &body body)
1227 (declare (ignore element-type))
1228 `(lisp::with-array-data ((,variable ,pixarray)
1229 (start)
1230 (end))
1231 (declare (ignore start end))
1232 ,@body))
1233
1234 ;;; These are used to read and write pixels from and to CARD8s.
1235
1236 ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
1237
1238 (defmacro read-image-load-byte (size position integer)
1239 (unless *image-bit-lsb-first-p* (setq position (- 7 position)))
1240 `(the (unsigned-byte ,size)
1241 (ldb (byte ,size ,position)(the card8 ,integer))))
1242
1243 ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from
1244 ;;; the appropriate number of CARD8s.
1245
1246 (defmacro read-image-assemble-bytes (&rest bytes)
1247 (unless *image-byte-lsb-first-p* (setq bytes (reverse bytes)))
1248 (let ((it (first bytes))
1249 (count 0))
1250 (dolist (byte (rest bytes))
1251 (setq it
1252 `(dpb
1253 (the card8 ,byte)
1254 (byte 8 ,(incf count 8))
1255 (the (unsigned-byte ,count) ,it))))
1256 `(the (unsigned-byte ,(* (length bytes) 8)) ,it)))
1257
1258
1259 ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
1260 ;;; pixel.
1261
1262 (defmacro write-image-load-byte (position integer integer-size)
1263 integer-size
1264 (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position)))
1265 `(the card8
1266 (ldb
1267 (byte 8 ,position)
1268 (the (unsigned-byte ,integer-size) ,integer))))
1269
1270 ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
1271 ;;; pixels.
1272
1273 (defmacro write-image-assemble-bytes (&rest bytes)
1274 (unless *image-bit-lsb-first-p* (setq bytes (reverse bytes)))
1275 (let ((size (floor 8 (length bytes)))
1276 (it (first bytes))
1277 (count 0))
1278 (dolist (byte (rest bytes))
1279 (setq it `(dpb
1280 (the (unsigned-byte ,size) ,byte)
1281 (byte ,size ,(incf count size))
1282 (the (unsigned-byte ,count) ,it))))
1283 `(the card8 ,it)))
1284
1285 ;;; The following table gives the bit ordering within bytes (when accessed
1286 ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
1287 ;;; 31, where bit 0 should be leftmost on the display. For a given byte
1288 ;;; labelled A-B, A is for the most significant bit of the byte, and B is
1289 ;;; for the least significant bit.
1290 ;;;
1291 ;;; legend:
1292 ;;; 1 scanline-unit = 8
1293 ;;; 2 scanline-unit = 16
1294 ;;; 4 scanline-unit = 32
1295 ;;; M byte-order = MostSignificant
1296 ;;; L byte-order = LeastSignificant
1297 ;;; m bit-order = MostSignificant
1298 ;;; l bit-order = LeastSignificant
1299 ;;;
1300 ;;;
1301 ;;; format ordering
1302 ;;;
1303 ;;; 1Mm 00-07 08-15 16-23 24-31
1304 ;;; 2Mm 00-07 08-15 16-23 24-31
1305 ;;; 4Mm 00-07 08-15 16-23 24-31
1306 ;;; 1Ml 07-00 15-08 23-16 31-24
1307 ;;; 2Ml 15-08 07-00 31-24 23-16
1308 ;;; 4Ml 31-24 23-16 15-08 07-00
1309 ;;; 1Lm 00-07 08-15 16-23 24-31
1310 ;;; 2Lm 08-15 00-07 24-31 16-23
1311 ;;; 4Lm 24-31 16-23 08-15 00-07
1312 ;;; 1Ll 07-00 15-08 23-16 31-24
1313 ;;; 2Ll 07-00 15-08 23-16 31-24
1314 ;;; 4Ll 07-00 15-08 23-16 31-24
1315
1316
1317 ;;; If you can write fast routines that can read and write pixarrays out of a
1318 ;;; buffer-bytes, do it! It makes the image code a lot faster. The
1319 ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines
1320 ;;; return T if they can do it, NIL if they can't.
1321
1322 ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
1323
1324 #+(or CMU)
1325 (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height
1326 padded-bytes-per-line bits-per-pixel)
1327 (declare (type buffer-bytes buffer-bbuf)
1328 (type pixarray-24 array)
1329 (type card16 width height)
1330 (type array-index index padded-bytes-per-line)
1331 (type (member 1 4 8 16 24 32) bits-per-pixel)
1332 (ignore bits-per-pixel))
1333 #.(declare-buffun)
1334 (with-vector (buffer-bbuf buffer-bytes)
1335 (with-underlying-simple-vector (vector pixarray-24-element-type array)
1336 (do* ((start (index+ index
1337 (index* y padded-bytes-per-line)
1338 (index* x 3))
1339 (index+ start padded-bytes-per-line))
1340 (y 0 (index1+ y)))
1341 ((index>= y height))
1342 (declare (type array-index start y))
1343 (do* ((end (index+ start (index* width 3)))
1344 (i start (index+ i 3))
1345 (x (array-row-major-index array y 0) (index1+ x)))
1346 ((index>= i end))
1347 (declare (type array-index end i x))
1348 (setf (aref vector x)
1349 (read-image-assemble-bytes
1350 (aref buffer-bbuf (index+ i 0))
1351 (aref buffer-bbuf (index+ i 1))
1352 (aref buffer-bbuf (index+ i 2))))))))
1353 t)
1354
1355 #+CMU
1356 (defun pixarray-element-size (pixarray)
1357 (let ((eltype (array-element-type pixarray)))
1358 (cond ((eq eltype 'bit) 1)
1359 ((and (consp eltype) (eq (first eltype) 'unsigned-byte))
1360 (second eltype))
1361 (t
1362 (error "Invalid pixarray: ~S." pixarray)))))
1363
1364 #+CMU
1365 ;;; COPY-BIT-RECT -- Internal
1366 ;;;
1367 ;;; This is the classic BITBLT operation, copying a rectangular subarray
1368 ;;; from one array to another (but source and destination must not overlap.)
1369 ;;; Widths are specified in bits. Neither array can have a non-zero
1370 ;;; displacement. We allow extra random bit-offset to be thrown into the X.
1371 ;;;
1372 (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
1373 height width)
1374 (declare (type array-index source-width sx sy dest-width dx dy height width))
1375 #.(declare-buffun)
1376 (lisp::with-array-data ((sdata source)
1377 (sstart)
1378 (send))
1379 (declare (ignore send))
1380 (lisp::with-array-data ((ddata dest)
1381 (dstart)
1382 (dend))
1383 (declare (ignore dend))
1384 (assert (and (zerop sstart) (zerop dstart)))
1385 (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits)
1386 sx (index* sy source-width))
1387 (index+ src-idx source-width))
1388 (dest-idx (index+ (* vm:vector-data-offset vm:word-bits)
1389 dx (index* dy dest-width))
1390 (index+ dest-idx dest-width))
1391 (count height (1- count)))
1392 ((zerop count))
1393 (declare (type array-index src-idx dest-idx count))
1394 (kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
1395
1396 #+CMU
1397 (defun fast-read-pixarray-using-bitblt
1398 (bbuf boffset pixarray x y width height padded-bytes-per-line
1399 bits-per-pixel)
1400 (declare (type (array * 2) pixarray))
1401 #.(declare-buffun)
1402 (copy-bit-rect bbuf
1403 (index* padded-bytes-per-line vm:byte-bits)
1404 (index* boffset vm:byte-bits) 0
1405 pixarray
1406 (index* (array-dimension pixarray 1) bits-per-pixel)
1407 x y
1408 height
1409 (index* width bits-per-pixel))
1410 t)
1411
1412 (defun fast-read-pixarray (bbuf boffset pixarray
1413 x y width height padded-bytes-per-line
1414 bits-per-pixel
1415 unit byte-lsb-first-p bit-lsb-first-p)
1416 (declare (type buffer-bytes bbuf)
1417 (type array-index boffset
1418 padded-bytes-per-line)
1419 (type pixarray pixarray)
1420 (type card16 x y width height)
1421 (type (member 1 4 8 16 24 32) bits-per-pixel)
1422 (type (member 8 16 32) unit)
1423 (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1424 (progn bbuf boffset pixarray x y width height padded-bytes-per-line
1425 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1426 (or
1427 (let ((function
1428 (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
1429 #'fast-read-pixarray-using-bitblt)
1430 (and (index= bits-per-pixel 24)
1431 #'fast-read-pixarray-24))))
1432 (when function
1433 (read-pixarray-internal
1434 bbuf boffset pixarray x y width height padded-bytes-per-line
1435 bits-per-pixel function
1436 unit byte-lsb-first-p bit-lsb-first-p
1437 *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)))))
1438
1439 ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
1440
1441 #+(or CMU)
1442 (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
1443 padded-bytes-per-line bits-per-pixel)
1444 (declare (type buffer-bytes buffer-bbuf)
1445 (type pixarray-24 array)
1446 (type int16 x y)
1447 (type card16 width height)
1448 (type array-index index padded-bytes-per-line)
1449 (type (member 1 4 8 16 24 32) bits-per-pixel)
1450 (ignore bits-per-pixel))
1451 #.(declare-buffun)
1452 (with-vector (buffer-bbuf buffer-bytes)
1453 (with-underlying-simple-vector (vector pixarray-24-element-type array)
1454 (do* ((h 0 (index1+ h))
1455 (y y (index1+ y))
1456 (start index (index+ start padded-bytes-per-line)))
1457 ((index>= h height))
1458 (declare (type array-index y start))
1459 (do* ((end (index+ start (index* width 3)))
1460 (i start (index+ i 3))
1461 (x (array-row-major-index array y x) (index1+ x)))
1462 ((index>= i end))
1463 (declare (type array-index end i x))
1464 (let ((pixel (aref vector x)))
1465 (declare (type pixarray-24-element-type pixel))
1466 (setf (aref buffer-bbuf (index+ i 0))
1467 (write-image-load-byte 0 pixel 24))
1468 (setf (aref buffer-bbuf (index+ i 1))
1469 (write-image-load-byte 8 pixel 24))
1470 (setf (aref buffer-bbuf (index+ i 2))
1471 (write-image-load-byte 16 pixel 24)))))))
1472 t)
1473
1474 #+CMU
1475 (defun fast-write-pixarray-using-bitblt
1476 (bbuf boffset pixarray x y width height padded-bytes-per-line
1477 bits-per-pixel)
1478 #.(declare-buffun)
1479 (copy-bit-rect pixarray
1480 (index* (array-dimension pixarray 1) bits-per-pixel)
1481 x y
1482 bbuf
1483 (index* padded-bytes-per-line vm:byte-bits)
1484 (index* boffset vm:byte-bits) 0
1485 height
1486 (index* width bits-per-pixel))
1487 t)
1488
1489 (defun fast-write-pixarray (bbuf boffset pixarray x y width height
1490 padded-bytes-per-line bits-per-pixel
1491 unit byte-lsb-first-p bit-lsb-first-p)
1492 (declare (type buffer-bytes bbuf)
1493 (type pixarray pixarray)
1494 (type card16 x y width height)
1495 (type array-index boffset padded-bytes-per-line)
1496 (type (member 1 4 8 16 24 32) bits-per-pixel)
1497 (type (member 8 16 32) unit)
1498 (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1499 (progn bbuf boffset pixarray x y width height padded-bytes-per-line
1500 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1501 (or
1502 (let ((function
1503 (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
1504 #'fast-write-pixarray-using-bitblt)
1505 (and (index= bits-per-pixel 24)
1506 #'fast-write-pixarray-24))))
1507 (when function
1508 (write-pixarray-internal
1509 bbuf boffset pixarray x y width height padded-bytes-per-line
1510 bits-per-pixel function
1511 *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*
1512 unit byte-lsb-first-p bit-lsb-first-p)))))
1513
1514 ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
1515
1516 (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel)
1517 (declare (type pixarray pixarray copy)
1518 (type card16 x y width height)
1519 (type (member 1 4 8 16 24 32) bits-per-pixel))
1520 (progn pixarray copy x y width height bits-per-pixel nil)
1521 (let* ((pixarray-padded-pixels-per-line
1522 (array-dimension pixarray 1))
1523 (pixarray-padded-bits-per-line
1524 (* pixarray-padded-pixels-per-line bits-per-pixel))
1525 (copy-padded-pixels-per-line
1526 (array-dimension copy 1))
1527 (copy-padded-bits-per-line
1528 (* copy-padded-pixels-per-line bits-per-pixel)))
1529 (when (index= (pixarray-element-size pixarray)
1530 (pixarray-element-size copy)
1531 bits-per-pixel)
1532 (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
1533 copy copy-padded-bits-per-line 0 0
1534 height
1535 (index* width bits-per-pixel))
1536 t)))

  ViewVC Help
Powered by ViewVC 1.1.5