/[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 - (hide 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 ram 1.5 ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
2 ram 1.1
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 dtc 1.10 (ext:file-comment
21 rtoy 1.15.14.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/dependent.lisp,v 1.15.14.1 2005/06/17 14:58:06 rtoy Exp $")
22 ram 1.1
23     (in-package :xlib)
24    
25 ram 1.5 (proclaim '(declaration array-register))
26    
27     (setf (getf ext:*herald-items* :xlib)
28     `(" CLX X Library " ,*version*))
29    
30 ram 1.2 ;;; The size of the output buffer. Must be a multiple of 4.
31     (defparameter *output-buffer-size* 8192)
32 ram 1.1
33     ;;; Number of seconds to wait for a reply to a server request
34     (defparameter *reply-timeout* nil)
35    
36 pw 1.11 #-(or (not clx-little-endian))
37 ram 1.1 (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 pw 1.11 #-(or clx-little-endian)
47 ram 1.1 (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 emarsden 1.13 (eval-when (:compile-toplevel :load-toplevel :execute)
59 ram 1.1
60 ram 1.3 (defconstant *buffer-speed* #+clx-debugging 1 #-clx-debugging 3
61 ram 1.1 "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 emarsden 1.13 #+clx-debugging
75 ram 1.5 '(declare (optimize (speed 1) (safety 1)))
76 emarsden 1.13 #-clx-debugging
77 ram 1.1 `(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 pw 1.11
86 ram 1.1 (progn
87    
88     (defun card8->int8 (x)
89     (declare (type card8 x))
90 ram 1.3 (declare (clx-values int8))
91 ram 1.1 #.(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 ram 1.3 (declare (clx-values card8))
99 ram 1.1 #.(declare-buffun)
100     (the card8 (ldb (byte 8 0) x)))
101    
102     (defun card16->int16 (x)
103     (declare (type card16 x))
104 ram 1.3 (declare (clx-values int16))
105 ram 1.1 #.(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 ram 1.3 (declare (clx-values card16))
113 ram 1.1 #.(declare-buffun)
114     (the card16 (ldb (byte 16 0) x)))
115    
116     (defun card32->int32 (x)
117     (declare (type card32 x))
118 ram 1.3 (declare (clx-values int32))
119 ram 1.1 #.(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 ram 1.3 (declare (clx-values card32))
127 ram 1.1 #.(declare-buffun)
128     (the card32 (ldb (byte 32 0) x)))
129    
130     )
131    
132 pw 1.11 (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
133 ram 1.1
134    
135     (progn
136    
137     (defun aref-card8 (a i)
138     (declare (type buffer-bytes a)
139     (type array-index i))
140 ram 1.3 (declare (clx-values card8))
141 ram 1.1 #.(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 ram 1.3 (declare (clx-values int8))
155 ram 1.1 #.(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 ram 1.3 (declare (clx-values card16))
174 ram 1.1 #.(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 ram 1.3 (declare (clx-values int16))
194 ram 1.1 #.(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 ram 1.3 (declare (clx-values card32))
214 ram 1.1 #.(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 ram 1.3 (declare (clx-values int32))
240 ram 1.1 #.(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 ram 1.3 (declare (clx-values card29))
266 ram 1.1 #.(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 ram 1.3 (declare (clx-values card16))
317 ram 1.1 #.(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 ram 1.3 (declare (clx-values short-float))
325 ram 1.1 #.(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 ram 1.3 (declare (clx-values int16))
333 ram 1.1 #.(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 ram 1.3 (declare (clx-values short-float))
340 ram 1.1 #.(declare-buffun)
341     (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
342    
343 ram 1.5
344 pw 1.11 #+cmu
345     (progn
346 ram 1.5
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 ram 1.1
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 pw 1.11 `(;; The normal ascii codes for the control characters.
377 ram 1.1 ,@`((#\Return . 13)
378     (#\Linefeed . 10)
379     (#\Rubout . 127)
380     (#\Page . 12)
381     (#\Tab . 9)
382     (#\Backspace . 8)
383     (#\Newline . 10)
384     (#\Space . 32))
385 pw 1.11
386 ram 1.1 ;; 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 ram 1.3 ',(let ((array (make-array 256)))
433 ram 1.1 (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 ram 1.2 (declare (type base-char char))
441 ram 1.1 #.(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 ram 1.2 (the base-char
449 ram 1.3 (or (aref (the simple-vector *card8-to-char-translation-table*)
450     card8)
451     (error "Invalid CHAR code ~D." card8))))
452 ram 1.1 )
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 ram 1.2 (declare (type base-char char))
472 ram 1.1 #.(declare-buffun)
473     (the card8 (char-code char)))
474     (defun card8->char (card8)
475     (declare (type card8 card8))
476     #.(declare-buffun)
477 ram 1.2 (the base-char (code-char card8)))
478 ram 1.1 ))))))
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 emarsden 1.13 #-mp
493 ram 1.1 (defun make-process-lock (name)
494     (declare (ignore name))
495     nil)
496    
497 emarsden 1.13 #+mp
498 dtc 1.7 (defun make-process-lock (name)
499     (mp:make-lock name))
500    
501 ram 1.1 ;;; 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 emarsden 1.13 #-cmu
510 ram 1.1 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
511     (declare (ignore locator display whostate timeout))
512     `(progn ,@body))
513    
514 ram 1.3 ;;; 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 ram 1.5 ;;; display connection. We inhibit GC notifications since display of them
521     ;;; could cause recursive entry into CLX.
522 ram 1.3 ;;;
523 toy 1.14 #-mp
524 ram 1.3 (defmacro holding-lock ((locator display &optional whostate &key timeout)
525     &body body)
526 ram 1.5 `(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 ram 1.3
533 dtc 1.7 ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
534     ;;;
535 emarsden 1.13 #+mp
536 dtc 1.7 (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 ram 1.2
544 ram 1.1 ;;; 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 emarsden 1.13 #-mp
558 ram 1.1 (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 emarsden 1.13 #+mp
564 dtc 1.7 (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 ram 1.1 ;;; PROCESS-WAKEUP: Check some other process' wait function.
570    
571     (declaim (inline process-wakeup))
572    
573 emarsden 1.13 #-mp
574 ram 1.1 (defun process-wakeup (process)
575     (declare (ignore process))
576     nil)
577    
578 emarsden 1.13 #+mp
579 dtc 1.7 (defun process-wakeup (process)
580     (declare (ignore process))
581     (mp:process-yield))
582    
583 ram 1.1 ;;; 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 emarsden 1.13 #-mp
591 ram 1.1 (defun current-process ()
592     nil)
593    
594 emarsden 1.13 #+mp
595 dtc 1.7 (defun current-process ()
596     mp:*current-process*)
597    
598 ram 1.1 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
599 emarsden 1.13 ;;
600 dtc 1.7 (defmacro without-interrupts (&body body)
601     `(sys:without-interrupts ,@body))
602    
603 ram 1.1 ;;; 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 emarsden 1.13 ;;; OPEN-X-STREAM - create a stream for communicating to the
638     ;;; appropriate X server.
639 ram 1.3 (defun open-x-stream (host display protocol)
640 emarsden 1.13 (ecase protocol
641     ;; establish a TCP connection to the X11 server, which is
642     ;; listening on port 6000 + display-number
643 rtoy 1.15.14.1 ((:internet :tcp nil)
644 emarsden 1.13 (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 emarsden 1.15 :reason (format nil "Cannot connect to internet socket: ~S"
652     (unix:get-unix-error-msg))))
653 emarsden 1.13 (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 emarsden 1.15 :reason (format nil "Unix socket ~s does not exist" path)))
665 emarsden 1.13 (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 emarsden 1.15 :reason (format nil "Can't connect to unix socket: ~S"
673     (unix:get-unix-error-msg))))
674 emarsden 1.13 (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8)))))))
675 ram 1.3
676    
677 ram 1.1 ;;; BUFFER-READ-DEFAULT - read data from the X stream
678 ram 1.3 ;;;
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 ram 1.5 (type (or null fixnum) timeout))
689 ram 1.3 #.(declare-buffun)
690 ram 1.5 (cond ((and (eql timeout 0)
691 ram 1.3 (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 ram 1.5
699 ram 1.1 ;;; 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 pw 1.11 #-(or CMU)
705 ram 1.1 (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 ram 1.3 (type (or null (real 0 *)) timeout))
710 ram 1.1 #.(declare-buffun)
711 pw 1.11 (let ((stream (display-input-stream display)))
712 ram 1.1 (declare (type (or null stream) stream))
713 pw 1.11 (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 ram 1.1
726 pw 1.11 ;;; BUFFER-WRITE-DEFAULT - write data to the X stream
727 ram 1.2
728 ram 1.3 #+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 ram 1.1 ;;; 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 pw 1.11 #-(or CMU)
744 ram 1.1 (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 ram 1.5 #+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 ram 1.1 ;;; 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 pw 1.11 #-(or CMU)
798 ram 1.1 (defparameter *buffer-read-polling-time* 0.5)
799    
800 pw 1.11 #-(or CMU)
801 ram 1.1 (defun buffer-input-wait-default (display timeout)
802     (declare (type display display)
803 ram 1.3 (type (or null (real 0 *)) timeout))
804     (declare (clx-values timeout))
805 ram 1.1
806     (let ((stream (display-input-stream display)))
807     (declare (type (or null stream) stream))
808     (cond ((null stream))
809     ((listen stream) nil)
810 ram 1.3 ((and timeout (= timeout 0)) :timeout)
811 ram 1.1 ((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 ram 1.3 #+CMU
825     (defun buffer-input-wait-default (display timeout)
826     (declare (type display display)
827 ram 1.5 (type (or null number) timeout))
828 ram 1.3 (let ((stream (display-input-stream display)))
829     (declare (type (or null stream) stream))
830     (cond ((null stream))
831     ((listen stream) nil)
832 ram 1.5 ((eql timeout 0) :timeout)
833 ram 1.3 (t
834 dtc 1.7 (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 ram 1.3 nil
839     :timeout)))))
840    
841 ram 1.1
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 pw 1.11
847 ram 1.1 (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 ram 1.2 `(let ((,var (list ,@elements)))
872     (declare (type cons ,var)
873 pw 1.11 (dynamic-extent ,var))
874 ram 1.2 ,@body))
875 ram 1.1
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 ram 1.2 `(let ((,var (list* ,@elements)))
882     (declare (type cons ,var)
883 pw 1.11 (dynamic-extent ,var))
884 ram 1.2 ,@body))
885 ram 1.1
886     (declaim (inline buffer-replace))
887    
888 ram 1.3 #+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 pw 1.11 #-CMU
901 ram 1.1 (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 emarsden 1.13 ;;; How much error detection should CLX do?
926 ram 1.1 ;;; 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 emarsden 1.12 (defconstant *type-check?* #+clx-debugging t #-clx-debugging nil)
958 ram 1.1
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 ram 1.3 ;;
966     ;; ### This comment is a lie! TYPE? is really also used for run-time type
967     ;; dispatching, not just type checking. -- Ram.
968    
969 ram 1.1 (defmacro type? (object type)
970 pw 1.11 `(typep ,object ,type))
971 ram 1.1
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 ram 1.2 :type-string error-string))
981 ram 1.1
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 dtc 1.9 (declare (type generalized-boolean asynchronous)
992 ram 1.1 (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 ram 1.3 ;;; 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 dtc 1.7 #+(and CMU (not mp))
1017 ram 1.1 (defun x-error (condition &rest keyargs)
1018 ram 1.3 (let ((condx (apply #'make-condition condition keyargs)))
1019 ram 1.5 (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 ram 1.3 (error condx)))
1024    
1025 ram 1.1
1026 ram 1.2 (define-condition x-error (error) ())
1027 ram 1.1
1028    
1029    
1030     ;;-----------------------------------------------------------------------------
1031     ;; HOST hacking
1032     ;;-----------------------------------------------------------------------------
1033    
1034 ram 1.3 (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 dtc 1.8 (let ((addr (first (ext::host-entry-addr-list hostent))))
1052 ram 1.3 (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 ram 1.1
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 emarsden 1.13 t) ;; emarsden2003-06-04 was NIL
1071 ram 1.3
1072     (defun clx-macroexpand (form env)
1073     (macroexpand form env))
1074    
1075 ram 1.1
1076     ;;-----------------------------------------------------------------------------
1077     ;; Resource stuff
1078     ;;-----------------------------------------------------------------------------
1079    
1080    
1081 ram 1.3 ;;; Utilities
1082    
1083     (defun getenv (name)
1084 emarsden 1.13 (cdr (assoc name ext:*environment-list* :test #'string=)))
1085 ram 1.3
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 ram 1.1 ;;; 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 ram 1.3 (homedir-file-pathname ".Xdefaults"))
1095 ram 1.1
1096     ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
1097     ;;; defaults have been loaded.
1098    
1099     (defun resources-pathname ()
1100 ram 1.3 (or (let ((string (getenv "XENVIRONMENT")))
1101     (and string
1102     (pathname string)))
1103 pw 1.11 (homedir-file-pathname (concatenate 'string ".Xdefaults-" (machine-instance)))))
1104 ram 1.1
1105 ram 1.3 ;;; 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 ram 1.1
1114     ;;-----------------------------------------------------------------------------
1115     ;; GC stuff
1116     ;;-----------------------------------------------------------------------------
1117    
1118 ram 1.2 (defun gc-cleanup ()
1119 ram 1.1 (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 ram 1.2 (when (boundp '*reply-buffer-free-lists*)
1127     (fill *reply-buffer-free-lists* nil))
1128 ram 1.1 (setq *gcontext-local-state-cache* nil)
1129 ram 1.2 (setq *temp-gcontext-cache* nil)
1130     nil)
1131 ram 1.1
1132 ram 1.2
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 ram 1.3 (clx-values t))
1156 ram 1.2 object)
1157    
1158    
1159     ;;-----------------------------------------------------------------------------
1160 ram 1.1 ;; Image stuff
1161     ;;-----------------------------------------------------------------------------
1162    
1163 ram 1.2 ;;; Types
1164    
1165 ram 1.1 (deftype pixarray-1-element-type ()
1166     'bit)
1167    
1168     (deftype pixarray-4-element-type ()
1169 ram 1.2 '(unsigned-byte 4))
1170 ram 1.1
1171     (deftype pixarray-8-element-type ()
1172 ram 1.2 '(unsigned-byte 8))
1173 ram 1.1
1174     (deftype pixarray-16-element-type ()
1175 ram 1.2 '(unsigned-byte 16))
1176 ram 1.1
1177     (deftype pixarray-24-element-type ()
1178 ram 1.2 '(unsigned-byte 24))
1179 ram 1.1
1180     (deftype pixarray-32-element-type ()
1181 pw 1.11 '(unsigned-byte 32))
1182 ram 1.1
1183     (deftype pixarray-1 ()
1184 pw 1.11 '(simple-array pixarray-1-element-type (* *)))
1185 ram 1.1
1186     (deftype pixarray-4 ()
1187 ram 1.5 '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))
1188 ram 1.1
1189     (deftype pixarray-8 ()
1190 pw 1.11 '(simple-array pixarray-8-element-type (* *)))
1191 ram 1.1
1192     (deftype pixarray-16 ()
1193 pw 1.11 '(simple-array pixarray-16-element-type (* *)))
1194 ram 1.1
1195     (deftype pixarray-24 ()
1196 pw 1.11 '(simple-array pixarray-24-element-type (* *)))
1197 ram 1.1
1198     (deftype pixarray-32 ()
1199 pw 1.11 '(simple-array pixarray-32-element-type (* *)))
1200 ram 1.1
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 ram 1.2 ;;; WITH-UNDERLYING-SIMPLE-VECTOR
1208 ram 1.1
1209 ram 1.5 #+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 ram 1.1 ;;; 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 ram 1.2 (unless *image-bit-lsb-first-p* (setq position (- 7 position)))
1228 ram 1.1 `(the (unsigned-byte ,size)
1229 pw 1.11 (ldb (byte ,size ,position)(the card8 ,integer))))
1230 ram 1.1
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 ram 1.2 (unless *image-byte-lsb-first-p* (setq bytes (reverse bytes)))
1236     (let ((it (first bytes))
1237     (count 0))
1238 ram 1.1 (dolist (byte (rest bytes))
1239     (setq it
1240 pw 1.11 `(dpb
1241 ram 1.1 (the card8 ,byte)
1242     (byte 8 ,(incf count 8))
1243     (the (unsigned-byte ,count) ,it))))
1244 pw 1.11 `(the (unsigned-byte ,(* (length bytes) 8)) ,it)))
1245    
1246 ram 1.1
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 ram 1.2 (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position)))
1253 ram 1.1 `(the card8
1254 pw 1.11 (ldb
1255 ram 1.2 (byte 8 ,position)
1256 pw 1.11 (the (unsigned-byte ,integer-size) ,integer))))
1257 ram 1.1
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 ram 1.2 (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 ram 1.1 (dolist (byte (rest bytes))
1267 pw 1.11 (setq it `(dpb
1268 ram 1.1 (the (unsigned-byte ,size) ,byte)
1269     (byte ,size ,(incf count size))
1270     (the (unsigned-byte ,count) ,it))))
1271     `(the card8 ,it)))
1272    
1273 ram 1.2 ;;; 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 ram 1.1 ;;; 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 pw 1.11 #+(or CMU)
1313 ram 1.1 (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height
1314 ram 1.2 padded-bytes-per-line bits-per-pixel)
1315 ram 1.1 (declare (type buffer-bytes buffer-bbuf)
1316     (type pixarray-24 array)
1317     (type card16 width height)
1318 ram 1.2 (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 ram 1.1 #.(declare-buffun)
1322     (with-vector (buffer-bbuf buffer-bytes)
1323 ram 1.2 (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 ram 1.1 t)
1342    
1343 ram 1.5 #+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 ram 1.1 (defun fast-read-pixarray (bbuf boffset pixarray
1401     x y width height padded-bytes-per-line
1402 ram 1.2 bits-per-pixel
1403     unit byte-lsb-first-p bit-lsb-first-p)
1404 ram 1.1 (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 ram 1.2 (type (member 1 4 8 16 24 32) bits-per-pixel)
1410     (type (member 8 16 32) unit)
1411 dtc 1.9 (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1412 ram 1.1 (progn bbuf boffset pixarray x y width height padded-bytes-per-line
1413 ram 1.2 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1414 ram 1.1 (or
1415 ram 1.2 (let ((function
1416 pw 1.11 (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
1417 ram 1.2 #'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 ram 1.1
1427     ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
1428    
1429 pw 1.11 #+(or CMU)
1430 ram 1.1 (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
1431 ram 1.2 padded-bytes-per-line bits-per-pixel)
1432 ram 1.1 (declare (type buffer-bytes buffer-bbuf)
1433     (type pixarray-24 array)
1434     (type int16 x y)
1435     (type card16 width height)
1436 ram 1.2 (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 ram 1.1 #.(declare-buffun)
1440     (with-vector (buffer-bbuf buffer-bytes)
1441 ram 1.2 (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 ram 1.1 t)
1461    
1462 ram 1.5 #+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 ram 1.1 (defun fast-write-pixarray (bbuf boffset pixarray x y width height
1478 ram 1.2 padded-bytes-per-line bits-per-pixel
1479     unit byte-lsb-first-p bit-lsb-first-p)
1480 ram 1.1 (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 ram 1.2 (type (member 1 4 8 16 24 32) bits-per-pixel)
1485     (type (member 8 16 32) unit)
1486 dtc 1.9 (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
1487 ram 1.1 (progn bbuf boffset pixarray x y width height padded-bytes-per-line
1488 ram 1.2 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1489 ram 1.1 (or
1490 ram 1.2 (let ((function
1491 pw 1.11 (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
1492 ram 1.2 #'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 ram 1.1
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 ram 1.2 (progn pixarray copy x y width height bits-per-pixel nil)
1509 pw 1.11 (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 ram 1.1 t)))

  ViewVC Help
Powered by ViewVC 1.1.5