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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15.14.1 - (show annotations)
Fri Jun 17 14:58:06 2005 UTC (8 years, 10 months ago) by rtoy
Branch: release-19b-branch
CVS Tags: release-19b-pre2
Changes since 1.15: +2 -2 lines
Merge from HEAD:

Allow :internet as a valid protocol for open-x-stream.  Fixes a typo
too.
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 (ext:file-comment
21 "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/dependent.lisp,v 1.15.14.1 2005/06/17 14:58:06 rtoy Exp $")
22
23 (in-package :xlib)
24
25 (proclaim '(declaration array-register))
26
27 (setf (getf ext:*herald-items* :xlib)
28 `(" CLX X Library " ,*version*))
29
30 ;;; The size of the output buffer. Must be a multiple of 4.
31 (defparameter *output-buffer-size* 8192)
32
33 ;;; Number of seconds to wait for a reply to a server request
34 (defparameter *reply-timeout* nil)
35
36 #-(or (not clx-little-endian))
37 (progn
38 (defconstant *word-0* 0)
39 (defconstant *word-1* 1)
40
41 (defconstant *long-0* 0)
42 (defconstant *long-1* 1)
43 (defconstant *long-2* 2)
44 (defconstant *long-3* 3))
45
46 #-(or clx-little-endian)
47 (progn
48 (defconstant *word-0* 1)
49 (defconstant *word-1* 0)
50
51 (defconstant *long-0* 3)
52 (defconstant *long-1* 2)
53 (defconstant *long-2* 1)
54 (defconstant *long-3* 0))
55
56 ;;; Set some compiler-options for often used code
57
58 (eval-when (:compile-toplevel :load-toplevel :execute)
59
60 (defconstant *buffer-speed* #+clx-debugging 1 #-clx-debugging 3
61 "Speed compiler option for buffer code.")
62 (defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0
63 "Safety compiler option for buffer code.")
64
65 (defun declare-bufmac ()
66 `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
67
68 ;;; It's my impression that in lucid there's some way to make a declaration
69 ;;; called fast-entry or something that causes a function to not do some
70 ;;; checking on args. Sadly, we have no lucid manuals here. If such a
71 ;;; declaration is available, it would be a good idea to make it here when
72 ;;; *buffer-speed* is 3 and *buffer-safety* is 0.
73 (defun declare-buffun ()
74 #+clx-debugging
75 '(declare (optimize (speed 1) (safety 1)))
76 #-clx-debugging
77 `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
78
79 )
80
81 (declaim (inline card8->int8 int8->card8
82 card16->int16 int16->card16
83 card32->int32 int32->card32))
84
85
86 (progn
87
88 (defun card8->int8 (x)
89 (declare (type card8 x))
90 (declare (clx-values int8))
91 #.(declare-buffun)
92 (the int8 (if (logbitp 7 x)
93 (the int8 (- x #x100))
94 x)))
95
96 (defun int8->card8 (x)
97 (declare (type int8 x))
98 (declare (clx-values card8))
99 #.(declare-buffun)
100 (the card8 (ldb (byte 8 0) x)))
101
102 (defun card16->int16 (x)
103 (declare (type card16 x))
104 (declare (clx-values int16))
105 #.(declare-buffun)
106 (the int16 (if (logbitp 15 x)
107 (the int16 (- x #x10000))
108 x)))
109
110 (defun int16->card16 (x)
111 (declare (type int16 x))
112 (declare (clx-values card16))
113 #.(declare-buffun)
114 (the card16 (ldb (byte 16 0) x)))
115
116 (defun card32->int32 (x)
117 (declare (type card32 x))
118 (declare (clx-values int32))
119 #.(declare-buffun)
120 (the int32 (if (logbitp 31 x)
121 (the int32 (- x #x100000000))
122 x)))
123
124 (defun int32->card32 (x)
125 (declare (type int32 x))
126 (declare (clx-values card32))
127 #.(declare-buffun)
128 (the card32 (ldb (byte 32 0) x)))
129
130 )
131
132 (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
133
134
135 (progn
136
137 (defun aref-card8 (a i)
138 (declare (type buffer-bytes a)
139 (type array-index i))
140 (declare (clx-values card8))
141 #.(declare-buffun)
142 (the card8 (aref a i)))
143
144 (defun aset-card8 (v a i)
145 (declare (type card8 v)
146 (type buffer-bytes a)
147 (type array-index i))
148 #.(declare-buffun)
149 (setf (aref a i) v))
150
151 (defun aref-int8 (a i)
152 (declare (type buffer-bytes a)
153 (type array-index i))
154 (declare (clx-values int8))
155 #.(declare-buffun)
156 (card8->int8 (aref a i)))
157
158 (defun aset-int8 (v a i)
159 (declare (type int8 v)
160 (type buffer-bytes a)
161 (type array-index i))
162 #.(declare-buffun)
163 (setf (aref a i) (int8->card8 v)))
164
165 )
166
167
168 (progn
169
170 (defun aref-card16 (a i)
171 (declare (type buffer-bytes a)
172 (type array-index i))
173 (declare (clx-values card16))
174 #.(declare-buffun)
175 (the card16
176 (logior (the card16
177 (ash (the card8 (aref a (index+ i *word-1*))) 8))
178 (the card8
179 (aref a (index+ i *word-0*))))))
180
181 (defun aset-card16 (v a i)
182 (declare (type card16 v)
183 (type buffer-bytes a)
184 (type array-index i))
185 #.(declare-buffun)
186 (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
187 (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
188 v)
189
190 (defun aref-int16 (a i)
191 (declare (type buffer-bytes a)
192 (type array-index i))
193 (declare (clx-values int16))
194 #.(declare-buffun)
195 (the int16
196 (logior (the int16
197 (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))
198 (the card8
199 (aref a (index+ i *word-0*))))))
200
201 (defun aset-int16 (v a i)
202 (declare (type int16 v)
203 (type buffer-bytes a)
204 (type array-index i))
205 #.(declare-buffun)
206 (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
207 (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
208 v)
209
210 (defun aref-card32 (a i)
211 (declare (type buffer-bytes a)
212 (type array-index i))
213 (declare (clx-values card32))
214 #.(declare-buffun)
215 (the card32
216 (logior (the card32
217 (ash (the card8 (aref a (index+ i *long-3*))) 24))
218 (the card29
219 (ash (the card8 (aref a (index+ i *long-2*))) 16))
220 (the card16
221 (ash (the card8 (aref a (index+ i *long-1*))) 8))
222 (the card8
223 (aref a (index+ i *long-0*))))))
224
225 (defun aset-card32 (v a i)
226 (declare (type card32 v)
227 (type buffer-bytes a)
228 (type array-index i))
229 #.(declare-buffun)
230 (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
231 (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
232 (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
233 (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
234 v)
235
236 (defun aref-int32 (a i)
237 (declare (type buffer-bytes a)
238 (type array-index i))
239 (declare (clx-values int32))
240 #.(declare-buffun)
241 (the int32
242 (logior (the int32
243 (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))
244 (the card29
245 (ash (the card8 (aref a (index+ i *long-2*))) 16))
246 (the card16
247 (ash (the card8 (aref a (index+ i *long-1*))) 8))
248 (the card8
249 (aref a (index+ i *long-0*))))))
250
251 (defun aset-int32 (v a i)
252 (declare (type int32 v)
253 (type buffer-bytes a)
254 (type array-index i))
255 #.(declare-buffun)
256 (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
257 (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
258 (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
259 (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
260 v)
261
262 (defun aref-card29 (a i)
263 (declare (type buffer-bytes a)
264 (type array-index i))
265 (declare (clx-values card29))
266 #.(declare-buffun)
267 (the card29
268 (logior (the card29
269 (ash (the card8 (aref a (index+ i *long-3*))) 24))
270 (the card29
271 (ash (the card8 (aref a (index+ i *long-2*))) 16))
272 (the card16
273 (ash (the card8 (aref a (index+ i *long-1*))) 8))
274 (the card8
275 (aref a (index+ i *long-0*))))))
276
277 (defun aset-card29 (v a i)
278 (declare (type card29 v)
279 (type buffer-bytes a)
280 (type array-index i))
281 #.(declare-buffun)
282 (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
283 (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
284 (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
285 (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
286 v)
287
288 )
289
290 (defsetf aref-card8 (a i) (v)
291 `(aset-card8 ,v ,a ,i))
292
293 (defsetf aref-int8 (a i) (v)
294 `(aset-int8 ,v ,a ,i))
295
296 (defsetf aref-card16 (a i) (v)
297 `(aset-card16 ,v ,a ,i))
298
299 (defsetf aref-int16 (a i) (v)
300 `(aset-int16 ,v ,a ,i))
301
302 (defsetf aref-card32 (a i) (v)
303 `(aset-card32 ,v ,a ,i))
304
305 (defsetf aref-int32 (a i) (v)
306 `(aset-int32 ,v ,a ,i))
307
308 (defsetf aref-card29 (a i) (v)
309 `(aset-card29 ,v ,a ,i))
310
311 ;;; Other random conversions
312
313 (defun rgb-val->card16 (value)
314 ;; Short floats are good enough
315 (declare (type rgb-val value))
316 (declare (clx-values card16))
317 #.(declare-buffun)
318 ;; Convert VALUE from float to card16
319 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
320
321 (defun card16->rgb-val (value)
322 ;; Short floats are good enough
323 (declare (type card16 value))
324 (declare (clx-values short-float))
325 #.(declare-buffun)
326 ;; Convert VALUE from card16 to float
327 (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
328
329 (defun radians->int16 (value)
330 ;; Short floats are good enough
331 (declare (type angle value))
332 (declare (clx-values int16))
333 #.(declare-buffun)
334 (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
335
336 (defun int16->radians (value)
337 ;; Short floats are good enough
338 (declare (type int16 value))
339 (declare (clx-values short-float))
340 #.(declare-buffun)
341 (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
342
343
344 #+cmu
345 (progn
346
347 ;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI
348 ;;; is irrational, there can't be a precise rational representation. In
349 ;;; particular, the different float approximations will always be /=. This
350 ;;; causes problems with type checking, because people might compute an
351 ;;; argument in any precision. What we do is discard all the excess precision
352 ;;; in the value, and see if the protocal encoding falls in the desired range
353 ;;; (64'ths of a degree.)
354 ;;;
355 (deftype angle () '(satisfies anglep))
356
357 (defun anglep (x)
358 (and (typep x 'real)
359 (<= (* -360 64) (radians->int16 x) (* 360 64))))
360
361 )
362
363
364 ;;-----------------------------------------------------------------------------
365 ;; Character transformation
366 ;;-----------------------------------------------------------------------------
367
368
369 ;;; This stuff transforms chars to ascii codes in card8's and back.
370 ;;; You might have to hack it a little to get it to work for your machine.
371
372 (declaim (inline char->card8 card8->char))
373
374 (macrolet ((char-translators ()
375 (let ((alist
376 `(;; The normal ascii codes for the control characters.
377 ,@`((#\Return . 13)
378 (#\Linefeed . 10)
379 (#\Rubout . 127)
380 (#\Page . 12)
381 (#\Tab . 9)
382 (#\Backspace . 8)
383 (#\Newline . 10)
384 (#\Space . 32))
385
386 ;; The rest of the common lisp charater set with the normal
387 ;; ascii codes for them.
388 (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
389 (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
390 (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
391 (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
392 (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
393 (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
394 (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
395 (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
396 (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
397 (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
398 (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
399 (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
400 (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
401 (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
402 (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
403 (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
404 (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
405 (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
406 (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
407 (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
408 (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
409 (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
410 (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
411 (#\} . 125) (#\~ . 126))))
412 (cond ((dolist (pair alist nil)
413 (when (not (= (char-code (car pair)) (cdr pair)))
414 (return t)))
415 `(progn
416 (defconstant *char-to-card8-translation-table*
417 ',(let ((array (make-array
418 (let ((max-char-code 255))
419 (dolist (pair alist)
420 (setq max-char-code
421 (max max-char-code
422 (char-code (car pair)))))
423 (1+ max-char-code))
424 :element-type 'card8)))
425 (dotimes (i (length array))
426 (setf (aref array i) (mod i 256)))
427 (dolist (pair alist)
428 (setf (aref array (char-code (car pair)))
429 (cdr pair)))
430 array))
431 (defconstant *card8-to-char-translation-table*
432 ',(let ((array (make-array 256)))
433 (dotimes (i (length array))
434 (setf (aref array i) (code-char i)))
435 (dolist (pair alist)
436 (setf (aref array (cdr pair)) (car pair)))
437 array))
438 (progn
439 (defun char->card8 (char)
440 (declare (type base-char char))
441 #.(declare-buffun)
442 (the card8 (aref (the (simple-array card8 (*))
443 *char-to-card8-translation-table*)
444 (the array-index (char-code char)))))
445 (defun card8->char (card8)
446 (declare (type card8 card8))
447 #.(declare-buffun)
448 (the base-char
449 (or (aref (the simple-vector *card8-to-char-translation-table*)
450 card8)
451 (error "Invalid CHAR code ~D." card8))))
452 )
453 (dotimes (i 256)
454 (unless (= i (char->card8 (card8->char i)))
455 (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S"
456 (list i
457 (card8->char i)
458 (char->card8 (card8->char i))))
459 (return nil)))
460 (dotimes (i (length *char-to-card8-translation-table*))
461 (let ((char (code-char i)))
462 (unless (eql char (card8->char (char->card8 char)))
463 (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S"
464 (list char
465 (char->card8 char)
466 (card8->char (char->card8 char))))
467 (return nil))))))
468 (t
469 `(progn
470 (defun char->card8 (char)
471 (declare (type base-char char))
472 #.(declare-buffun)
473 (the card8 (char-code char)))
474 (defun card8->char (card8)
475 (declare (type card8 card8))
476 #.(declare-buffun)
477 (the base-char (code-char card8)))
478 ))))))
479 (char-translators))
480
481 ;;-----------------------------------------------------------------------------
482 ;; Process Locking
483 ;;
484 ;; Common-Lisp doesn't provide process locking primitives, so we define
485 ;; our own here, based on Zetalisp primitives. Holding-Lock is very
486 ;; similar to with-lock on The TI Explorer, and a little more efficient
487 ;; than with-process-lock on a Symbolics.
488 ;;-----------------------------------------------------------------------------
489
490 ;;; MAKE-PROCESS-LOCK: Creating a process lock.
491
492 #-mp
493 (defun make-process-lock (name)
494 (declare (ignore name))
495 nil)
496
497 #+mp
498 (defun make-process-lock (name)
499 (mp:make-lock name))
500
501 ;;; HOLDING-LOCK: Execute a body of code with a lock held.
502
503 ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN
504 ;;; passes its timeout to the holding-lock macro, so any timeout you want to
505 ;;; work for event-listen you should do for holding-lock.
506
507 ;; If you're not sharing DISPLAY objects within a multi-processing
508 ;; shared-memory environment, this is sufficient
509 #-cmu
510 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
511 (declare (ignore locator display whostate timeout))
512 `(progn ,@body))
513
514 ;;; HOLDING-LOCK for CMU Common Lisp.
515 ;;;
516 ;;; We are not multi-processing, but we use this macro to try to protect
517 ;;; against re-entering request functions. This can happen if an interrupt
518 ;;; occurs and the handler attempts to use X over the same display connection.
519 ;;; This can happen if the GC hooks are used to notify the user over the same
520 ;;; display connection. We inhibit GC notifications since display of them
521 ;;; could cause recursive entry into CLX.
522 ;;;
523 #-mp
524 (defmacro holding-lock ((locator display &optional whostate &key timeout)
525 &body body)
526 `(let ((ext:*gc-verbose* nil)
527 (ext:*gc-inhibit-hook* nil)
528 (ext:*before-gc-hooks* nil)
529 (ext:*after-gc-hooks* nil))
530 ,locator ,display ,whostate ,timeout
531 (system:without-interrupts (progn ,@body))))
532
533 ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
534 ;;;
535 #+mp
536 (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
537 &key timeout)
538 &body body)
539 (declare (ignore display))
540 `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
541 ,@body))
542
543
544 ;;; WITHOUT-ABORTS
545
546 ;;; If you can inhibit asynchronous keyboard aborts inside the body of this
547 ;;; macro, then it is a good idea to do this. This macro is wrapped around
548 ;;; request writing and reply reading to ensure that requests are atomically
549 ;;; written and replies are atomically read from the stream.
550
551 (defmacro without-aborts (&body body)
552 `(progn ,@body))
553
554 ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
555 ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
556 ;;; value changes.
557 #-mp
558 (defun process-block (whostate predicate &rest predicate-args)
559 (declare (ignore whostate))
560 (or (apply predicate predicate-args)
561 (error "Program tried to wait with no scheduler.")))
562
563 #+mp
564 (defun process-block (whostate predicate &rest predicate-args)
565 (declare (type function predicate))
566 (mp:process-wait whostate #'(lambda ()
567 (apply predicate predicate-args))))
568
569 ;;; PROCESS-WAKEUP: Check some other process' wait function.
570
571 (declaim (inline process-wakeup))
572
573 #-mp
574 (defun process-wakeup (process)
575 (declare (ignore process))
576 nil)
577
578 #+mp
579 (defun process-wakeup (process)
580 (declare (ignore process))
581 (mp:process-yield))
582
583 ;;; CURRENT-PROCESS: Return the current process object for input locking and
584 ;;; for calling PROCESS-WAKEUP.
585
586 (declaim (inline current-process))
587
588 ;;; Default return NIL, which is acceptable even if there is a scheduler.
589
590 #-mp
591 (defun current-process ()
592 nil)
593
594 #+mp
595 (defun current-process ()
596 mp:*current-process*)
597
598 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
599 ;;
600 (defmacro without-interrupts (&body body)
601 `(sys:without-interrupts ,@body))
602
603 ;;; CONDITIONAL-STORE:
604
605 ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
606 ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
607 (defmacro conditional-store (place old-value new-value)
608 `(without-interrupts
609 (cond ((eq ,place ,old-value)
610 (setf ,place ,new-value)
611 t))))
612
613 ;;;----------------------------------------------------------------------------
614 ;;; IO Error Recovery
615 ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro.
616 ;;; It prevents multiple mindless errors when the network craters.
617 ;;;
618 ;;;----------------------------------------------------------------------------
619
620 (defmacro wrap-buf-output ((buffer) &body body)
621 ;; Error recovery wrapper
622 `(unless (buffer-dead ,buffer)
623 ,@body))
624
625 (defmacro wrap-buf-input ((buffer) &body body)
626 (declare (ignore buffer))
627 ;; Error recovery wrapper
628 `(progn ,@body))
629
630
631 ;;;----------------------------------------------------------------------------
632 ;;; System dependent IO primitives
633 ;;; Functions for opening, reading writing forcing-output and closing
634 ;;; the stream to the server.
635 ;;;----------------------------------------------------------------------------
636
637 ;;; OPEN-X-STREAM - create a stream for communicating to the
638 ;;; appropriate X server.
639 (defun open-x-stream (host display protocol)
640 (ecase protocol
641 ;; establish a TCP connection to the X11 server, which is
642 ;; listening on port 6000 + display-number
643 ((:internet :tcp nil)
644 (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display))))
645 (unless (plusp fd)
646 (error 'connection-failure
647 :major-version *protocol-major-version*
648 :minor-version *protocol-minor-version*
649 :host host
650 :display display
651 :reason (format nil "Cannot connect to internet socket: ~S"
652 (unix:get-unix-error-msg))))
653 (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8))))
654 ;; establish a connection to the X11 server over a Unix socket
655 (:unix
656 (let ((path (make-pathname :directory '(:absolute "tmp" ".X11-unix")
657 :name (format nil "X~D" display))))
658 (unless (probe-file path)
659 (error 'connection-failure
660 :major-version *protocol-major-version*
661 :minor-version *protocol-minor-version*
662 :host host
663 :display display
664 :reason (format nil "Unix socket ~s does not exist" path)))
665 (let ((fd (ext:connect-to-unix-socket (namestring path))))
666 (unless (plusp fd)
667 (error 'connection-failure
668 :major-version *protocol-major-version*
669 :minor-version *protocol-minor-version*
670 :host host
671 :display display
672 :reason (format nil "Can't connect to unix socket: ~S"
673 (unix:get-unix-error-msg))))
674 (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8)))))))
675
676
677 ;;; BUFFER-READ-DEFAULT - read data from the X stream
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 much 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 (defun host-address (host &optional (family :internet))
1035 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
1036 ;; and cdr is a list of network address bytes.
1037 (declare (type stringable host)
1038 (type (or null (member :internet :decnet :chaos) card8) family))
1039 (declare (clx-values list))
1040 (labels ((no-host-error ()
1041 (error "Unknown host ~S" host))
1042 (no-address-error ()
1043 (error "Host ~S has no ~S address" host family)))
1044 (let ((hostent (ext:lookup-host-entry (string host))))
1045 (when (not hostent)
1046 (no-host-error))
1047 (ecase family
1048 ((:internet nil 0)
1049 (unless (= (ext::host-entry-addr-type hostent) 2)
1050 (no-address-error))
1051 (let ((addr (first (ext::host-entry-addr-list hostent))))
1052 (list :internet
1053 (ldb (byte 8 24) addr)
1054 (ldb (byte 8 16) addr)
1055 (ldb (byte 8 8) addr)
1056 (ldb (byte 8 0) addr))))))))
1057
1058
1059 ;;-----------------------------------------------------------------------------
1060 ;; Whether to use closures for requests or not.
1061 ;;-----------------------------------------------------------------------------
1062
1063 ;;; If this macro expands to non-NIL, then request and locking code is
1064 ;;; compiled in a much more compact format, as the common code is shared, and
1065 ;;; the specific code is built into a closure that is funcalled by the shared
1066 ;;; code. If your compiler makes efficient use of closures then you probably
1067 ;;; want to make this expand to T, as it makes the code more compact.
1068
1069 (defmacro use-closures ()
1070 t) ;; emarsden2003-06-04 was NIL
1071
1072 (defun clx-macroexpand (form env)
1073 (macroexpand form env))
1074
1075
1076 ;;-----------------------------------------------------------------------------
1077 ;; Resource stuff
1078 ;;-----------------------------------------------------------------------------
1079
1080
1081 ;;; Utilities
1082
1083 (defun getenv (name)
1084 (cdr (assoc name ext:*environment-list* :test #'string=)))
1085
1086 (defun homedir-file-pathname (name)
1087 (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
1088 (merge-pathnames (user-homedir-pathname) (pathname name))))
1089
1090 ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
1091 ;;; a resource manager isn't running.
1092
1093 (defun default-resources-pathname ()
1094 (homedir-file-pathname ".Xdefaults"))
1095
1096 ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
1097 ;;; defaults have been loaded.
1098
1099 (defun resources-pathname ()
1100 (or (let ((string (getenv "XENVIRONMENT")))
1101 (and string
1102 (pathname string)))
1103 (homedir-file-pathname (concatenate 'string ".Xdefaults-" (machine-instance)))))
1104
1105 ;;; AUTHORITY-PATHNAME - The pathname of the authority file.
1106
1107 (defun authority-pathname ()
1108 (or (let ((xauthority (getenv "XAUTHORITY")))
1109 (and xauthority
1110 (pathname xauthority)))
1111 (homedir-file-pathname ".Xauthority")))
1112
1113
1114 ;;-----------------------------------------------------------------------------
1115 ;; GC stuff
1116 ;;-----------------------------------------------------------------------------
1117
1118 (defun gc-cleanup ()
1119 (declare (special *event-free-list*
1120 *pending-command-free-list*
1121 *reply-buffer-free-lists*
1122 *gcontext-local-state-cache*
1123 *temp-gcontext-cache*))
1124 (setq *event-free-list* nil)
1125 (setq *pending-command-free-list* nil)
1126 (when (boundp '*reply-buffer-free-lists*)
1127 (fill *reply-buffer-free-lists* nil))
1128 (setq *gcontext-local-state-cache* nil)
1129 (setq *temp-gcontext-cache* nil)
1130 nil)
1131
1132
1133
1134 ;;-----------------------------------------------------------------------------
1135 ;; DEFAULT-KEYSYM-TRANSLATE
1136 ;;-----------------------------------------------------------------------------
1137
1138 ;;; If object is a character, char-bits are set from state.
1139 ;;;
1140 ;;; [the following isn't implemented (should it be?)]
1141 ;;; If object is a list, it is an alist with entries:
1142 ;;; (base-char [modifiers] [mask-modifiers])
1143 ;;; When MODIFIERS are specified, this character translation
1144 ;;; will only take effect when the specified modifiers are pressed.
1145 ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
1146 ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
1147 ;;; In ambiguous cases, the most specific translation is used.
1148
1149
1150 (defun default-keysym-translate (display state object)
1151 (declare (type display display)
1152 (type card16 state)
1153 (type t object)
1154 (ignore display state)
1155 (clx-values t))
1156 object)
1157
1158
1159 ;;-----------------------------------------------------------------------------
1160 ;; Image stuff
1161 ;;-----------------------------------------------------------------------------
1162
1163 ;;; Types
1164
1165 (deftype pixarray-1-element-type ()
1166 'bit)
1167
1168 (deftype pixarray-4-element-type ()
1169 '(unsigned-byte 4))
1170
1171 (deftype pixarray-8-element-type ()
1172 '(unsigned-byte 8))
1173
1174 (deftype pixarray-16-element-type ()
1175 '(unsigned-byte 16))
1176
1177 (deftype pixarray-24-element-type ()
1178 '(unsigned-byte 24))
1179
1180 (deftype pixarray-32-element-type ()
1181 '(unsigned-byte 32))
1182
1183 (deftype pixarray-1 ()
1184 '(simple-array pixarray-1-element-type (* *)))
1185
1186 (deftype pixarray-4 ()
1187 '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))
1188
1189 (deftype pixarray-8 ()
1190 '(simple-array pixarray-8-element-type (* *)))
1191
1192 (deftype pixarray-16 ()
1193 '(simple-array pixarray-16-element-type (* *)))
1194
1195 (deftype pixarray-24 ()
1196 '(simple-array pixarray-24-element-type (* *)))
1197
1198 (deftype pixarray-32 ()
1199 '(simple-array pixarray-32-element-type (* *)))
1200
1201 (deftype pixarray ()
1202 '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
1203
1204 (deftype bitmap ()
1205 'pixarray-1)
1206
1207 ;;; WITH-UNDERLYING-SIMPLE-VECTOR
1208
1209 #+CMU
1210 ;;; We do *NOT* support viewing an array as having a different element type.
1211 ;;; Element-type is ignored.
1212 ;;;
1213 (defmacro with-underlying-simple-vector
1214 ((variable element-type pixarray) &body body)
1215 (declare (ignore element-type))
1216 `(lisp::with-array-data ((,variable ,pixarray)
1217 (start)
1218 (end))
1219 (declare (ignore start end))
1220 ,@body))
1221
1222 ;;; These are used to read and write pixels from and to CARD8s.
1223
1224 ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
1225
1226 (defmacro read-image-load-byte (size position integer)
1227 (unless *image-bit-lsb-first-p* (setq position (- 7 position)))
1228 `(the (unsigned-byte ,size)
1229 (ldb (byte ,size ,position)(the card8 ,integer))))
1230
1231 ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from
1232 ;;; the appropriate number of CARD8s.
1233
1234 (defmacro read-image-assemble-bytes (&rest bytes)
1235 (unless *image-byte-lsb-first-p* (setq bytes (reverse bytes)))
1236 (let ((it (first bytes))
1237 (count 0))
1238 (dolist (byte (rest bytes))
1239 (setq it
1240 `(dpb
1241 (the card8 ,byte)
1242 (byte 8 ,(incf count 8))
1243 (the (unsigned-byte ,count) ,it))))
1244 `(the (unsigned-byte ,(* (length bytes) 8)) ,it)))
1245
1246
1247 ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
1248 ;;; pixel.
1249
1250 (defmacro write-image-load-byte (position integer integer-size)
1251 integer-size
1252 (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position)))
1253 `(the card8
1254 (ldb
1255 (byte 8 ,position)
1256 (the (unsigned-byte ,integer-size) ,integer))))
1257
1258 ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
1259 ;;; pixels.
1260
1261 (defmacro write-image-assemble-bytes (&rest bytes)
1262 (unless *image-bit-lsb-first-p* (setq bytes (reverse bytes)))
1263 (let ((size (floor 8 (length bytes)))
1264 (it (first bytes))
1265 (count 0))
1266 (dolist (byte (rest bytes))
1267 (setq it `(dpb
1268 (the (unsigned-byte ,size) ,byte)
1269 (byte ,size ,(incf count size))
1270 (the (unsigned-byte ,count) ,it))))
1271 `(the card8 ,it)))
1272
1273 ;;; The following table gives the bit ordering within bytes (when accessed
1274 ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
1275 ;;; 31, where bit 0 should be leftmost on the display. For a given byte
1276 ;;; labelled A-B, A is for the most significant bit of the byte, and B is
1277 ;;; for the least significant bit.
1278 ;;;
1279 ;;; legend:
1280 ;;; 1 scanline-unit = 8
1281 ;;; 2 scanline-unit = 16
1282 ;;; 4 scanline-unit = 32
1283 ;;; M byte-order = MostSignificant
1284 ;;; L byte-order = LeastSignificant
1285 ;;; m bit-order = MostSignificant
1286 ;;; l bit-order = LeastSignificant
1287 ;;;
1288 ;;;
1289 ;;; format ordering
1290 ;;;
1291 ;;; 1Mm 00-07 08-15 16-23 24-31
1292 ;;; 2Mm 00-07 08-15 16-23 24-31
1293 ;;; 4Mm 00-07 08-15 16-23 24-31
1294 ;;; 1Ml 07-00 15-08 23-16 31-24
1295 ;;; 2Ml 15-08 07-00 31-24 23-16
1296 ;;; 4Ml 31-24 23-16 15-08 07-00
1297 ;;; 1Lm 00-07 08-15 16-23 24-31
1298 ;;; 2Lm 08-15 00-07 24-31 16-23
1299 ;;; 4Lm 24-31 16-23 08-15 00-07
1300 ;;; 1Ll 07-00 15-08 23-16 31-24
1301 ;;; 2Ll 07-00 15-08 23-16 31-24
1302 ;;; 4Ll 07-00 15-08 23-16 31-24
1303
1304
1305 ;;; If you can write fast routines that can read and write pixarrays out of a
1306 ;;; buffer-bytes, do it! It makes the image code a lot faster. The
1307 ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines
1308 ;;; return T if they can do it, NIL if they can't.
1309
1310 ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
1311
1312 #+(or CMU)
1313 (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height
1314 padded-bytes-per-line bits-per-pixel)
1315 (declare (type buffer-bytes buffer-bbuf)
1316 (type pixarray-24 array)
1317 (type card16 width height)
1318 (type array-index index padded-bytes-per-line)
1319 (type (member 1 4 8 16 24 32) bits-per-pixel)
1320 (ignore bits-per-pixel))
1321 #.(declare-buffun)
1322 (with-vector (buffer-bbuf buffer-bytes)
1323 (with-underlying-simple-vector (vector pixarray-24-element-type array)
1324 (do* ((start (index+ index
1325 (index* y padded-bytes-per-line)
1326 (index* x 3))
1327 (index+ start padded-bytes-per-line))
1328 (y 0 (index1+ y)))
1329 ((index>= y height))
1330 (declare (type array-index start y))
1331 (do* ((end (index+ start (index* width 3)))
1332 (i start (index+ i 3))
1333 (x (array-row-major-index array y 0) (index1+ x)))
1334 ((index>= i end))
1335 (declare (type array-index end i x))
1336 (setf (aref vector x)
1337 (read-image-assemble-bytes
1338 (aref buffer-bbuf (index+ i 0))
1339 (aref buffer-bbuf (index+ i 1))
1340 (aref buffer-bbuf (index+ i 2))))))))
1341 t)
1342
1343 #+CMU
1344 (defun pixarray-element-size (pixarray)
1345 (let ((eltype (array-element-type pixarray)))
1346 (cond ((eq eltype 'bit) 1)
1347 ((and (consp eltype) (eq (first eltype) 'unsigned-byte))
1348 (second eltype))
1349 (t
1350 (error "Invalid pixarray: ~S." pixarray)))))
1351
1352 #+CMU
1353 ;;; COPY-BIT-RECT -- Internal
1354 ;;;
1355 ;;; This is the classic BITBLT operation, copying a rectangular subarray
1356 ;;; from one array to another (but source and destination must not overlap.)
1357 ;;; Widths are specified in bits. Neither array can have a non-zero
1358 ;;; displacement. We allow extra random bit-offset to be thrown into the X.
1359 ;;;
1360 (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
1361 height width)
1362 (declare (type array-index source-width sx sy dest-width dx dy height width))
1363 #.(declare-buffun)
1364 (lisp::with-array-data ((sdata source)
1365 (sstart)
1366 (send))
1367 (declare (ignore send))
1368 (lisp::with-array-data ((ddata dest)
1369 (dstart)
1370 (dend))
1371 (declare (ignore dend))
1372 (assert (and (zerop sstart) (zerop dstart)))
1373 (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits)
1374 sx (index* sy source-width))
1375 (index+ src-idx source-width))
1376 (dest-idx (index+ (* vm:vector-data-offset vm:word-bits)
1377 dx (index* dy dest-width))
1378 (index+ dest-idx dest-width))
1379 (count height (1- count)))
1380 ((zerop count))
1381 (declare (type array-index src-idx dest-idx count))
1382 (kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
1383
1384 #+CMU
1385 (defun fast-read-pixarray-using-bitblt
1386 (bbuf boffset pixarray x y width height padded-bytes-per-line
1387 bits-per-pixel)
1388 (declare (type (array * 2) pixarray))
1389 #.(declare-buffun)
1390 (copy-bit-rect bbuf
1391 (index* padded-bytes-per-line vm:byte-bits)
1392 (index* boffset vm:byte-bits) 0
1393 pixarray
1394 (index* (array-dimension pixarray 1) bits-per-pixel)
1395 x y
1396 height
1397 (index* width bits-per-pixel))
1398 t)
1399
1400 (defun fast-read-pixarray (bbuf boffset pixarray
1401 x y width height padded-bytes-per-line
1402 bits-per-pixel
1403 unit byte-lsb-first-p bit-lsb-first-p)
1404 (declare (type buffer-bytes bbuf)
1405 (type array-index boffset
1406 padded-bytes-per-line)
1407 (type pixarray pixarray)
1408 (type card16 x y width height)
1409 (type (member 1 4 8 16 24 32) bits-per-pixel)
1410 (type (member 8 16 32) unit)
1411 (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1412 (progn bbuf boffset pixarray x y width height padded-bytes-per-line
1413 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1414 (or
1415 (let ((function
1416 (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
1417 #'fast-read-pixarray-using-bitblt)
1418 (and (index= bits-per-pixel 24)
1419 #'fast-read-pixarray-24))))
1420 (when function
1421 (read-pixarray-internal
1422 bbuf boffset pixarray x y width height padded-bytes-per-line
1423 bits-per-pixel function
1424 unit byte-lsb-first-p bit-lsb-first-p
1425 *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)))))
1426
1427 ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
1428
1429 #+(or CMU)
1430 (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
1431 padded-bytes-per-line bits-per-pixel)
1432 (declare (type buffer-bytes buffer-bbuf)
1433 (type pixarray-24 array)
1434 (type int16 x y)
1435 (type card16 width height)
1436 (type array-index index padded-bytes-per-line)
1437 (type (member 1 4 8 16 24 32) bits-per-pixel)
1438 (ignore bits-per-pixel))
1439 #.(declare-buffun)
1440 (with-vector (buffer-bbuf buffer-bytes)
1441 (with-underlying-simple-vector (vector pixarray-24-element-type array)
1442 (do* ((h 0 (index1+ h))
1443 (y y (index1+ y))
1444 (start index (index+ start padded-bytes-per-line)))
1445 ((index>= h height))
1446 (declare (type array-index y start))
1447 (do* ((end (index+ start (index* width 3)))
1448 (i start (index+ i 3))
1449 (x (array-row-major-index array y x) (index1+ x)))
1450 ((index>= i end))
1451 (declare (type array-index end i x))
1452 (let ((pixel (aref vector x)))
1453 (declare (type pixarray-24-element-type pixel))
1454 (setf (aref buffer-bbuf (index+ i 0))
1455 (write-image-load-byte 0 pixel 24))
1456 (setf (aref buffer-bbuf (index+ i 1))
1457 (write-image-load-byte 8 pixel 24))
1458 (setf (aref buffer-bbuf (index+ i 2))
1459 (write-image-load-byte 16 pixel 24)))))))
1460 t)
1461
1462 #+CMU
1463 (defun fast-write-pixarray-using-bitblt
1464 (bbuf boffset pixarray x y width height padded-bytes-per-line
1465 bits-per-pixel)
1466 #.(declare-buffun)
1467 (copy-bit-rect pixarray
1468 (index* (array-dimension pixarray 1) bits-per-pixel)
1469 x y
1470 bbuf
1471 (index* padded-bytes-per-line vm:byte-bits)
1472 (index* boffset vm:byte-bits) 0
1473 height
1474 (index* width bits-per-pixel))
1475 t)
1476
1477 (defun fast-write-pixarray (bbuf boffset pixarray x y width height
1478 padded-bytes-per-line bits-per-pixel
1479 unit byte-lsb-first-p bit-lsb-first-p)
1480 (declare (type buffer-bytes bbuf)
1481 (type pixarray pixarray)
1482 (type card16 x y width height)
1483 (type array-index boffset padded-bytes-per-line)
1484 (type (member 1 4 8 16 24 32) bits-per-pixel)
1485 (type (member 8 16 32) unit)
1486 (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1487 (progn bbuf boffset pixarray x y width height padded-bytes-per-line
1488 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1489 (or
1490 (let ((function
1491 (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
1492 #'fast-write-pixarray-using-bitblt)
1493 (and (index= bits-per-pixel 24)
1494 #'fast-write-pixarray-24))))
1495 (when function
1496 (write-pixarray-internal
1497 bbuf boffset pixarray x y width height padded-bytes-per-line
1498 bits-per-pixel function
1499 *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*
1500 unit byte-lsb-first-p bit-lsb-first-p)))))
1501
1502 ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
1503
1504 (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel)
1505 (declare (type pixarray pixarray copy)
1506 (type card16 x y width height)
1507 (type (member 1 4 8 16 24 32) bits-per-pixel))
1508 (progn pixarray copy x y width height bits-per-pixel nil)
1509 (let* ((pixarray-padded-pixels-per-line
1510 (array-dimension pixarray 1))
1511 (pixarray-padded-bits-per-line
1512 (* pixarray-padded-pixels-per-line bits-per-pixel))
1513 (copy-padded-pixels-per-line
1514 (array-dimension copy 1))
1515 (copy-padded-bits-per-line
1516 (* copy-padded-pixels-per-line bits-per-pixel)))
1517 (when (index= (pixarray-element-size pixarray)
1518 (pixarray-element-size copy)
1519 bits-per-pixel)
1520 (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
1521 copy copy-padded-bits-per-line 0 0
1522 height
1523 (index* width bits-per-pixel))
1524 t)))

  ViewVC Help
Powered by ViewVC 1.1.5