/[cmucl]/src/clx/dep-openmcl.lisp
ViewVC logotype

Contents of /src/clx/dep-openmcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Wed Jun 17 18:22:45 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.1: +5 -6 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
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
21 #+cmu
22 (ext:file-comment "$Id: dep-openmcl.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $")
23
24 (in-package :xlib)
25
26 (proclaim '(declaration array-register))
27
28
29 ;;; The size of the output buffer. Must be a multiple of 4.
30 (defparameter *output-buffer-size* 8192)
31
32 ;;; Number of seconds to wait for a reply to a server request
33 (defparameter *reply-timeout* nil)
34
35 (progn
36 (defconstant +word-0+ 1)
37 (defconstant +word-1+ 0)
38
39 (defconstant +long-0+ 3)
40 (defconstant +long-1+ 2)
41 (defconstant +long-2+ 1)
42 (defconstant +long-3+ 0))
43
44 ;;; Set some compiler-options for often used code
45
46 (eval-when (:compile-toplevel :load-toplevel :execute)
47 (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3
48 "Speed compiler option for buffer code.")
49 (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0
50 "Safety compiler option for buffer code.")
51 (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1
52 "Debug compiler option for buffer code>")
53 (defun declare-bufmac ()
54 `(declare (optimize
55 (speed ,+buffer-speed+)
56 (safety ,+buffer-safety+)
57 (debug ,+buffer-debug+))))
58 ;; It's my impression that in lucid there's some way to make a
59 ;; declaration called fast-entry or something that causes a function
60 ;; to not do some checking on args. Sadly, we have no lucid manuals
61 ;; here. If such a declaration is available, it would be a good
62 ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+
63 ;; is 0.
64 (defun declare-buffun ()
65 `(declare (optimize
66 (speed ,+buffer-speed+)
67 (safety ,+buffer-safety+)
68 (debug ,+buffer-debug+)))))
69
70 (declaim (inline card8->int8 int8->card8
71 card16->int16 int16->card16
72 card32->int32 int32->card32))
73
74 (progn
75
76 (defun card8->int8 (x)
77 (declare (type card8 x))
78 (declare (clx-values int8))
79 #.(declare-buffun)
80 (the int8 (if (logbitp 7 x)
81 (the int8 (- x #x100))
82 x)))
83
84 (defun int8->card8 (x)
85 (declare (type int8 x))
86 (declare (clx-values card8))
87 #.(declare-buffun)
88 (the card8 (ldb (byte 8 0) x)))
89
90 (defun card16->int16 (x)
91 (declare (type card16 x))
92 (declare (clx-values int16))
93 #.(declare-buffun)
94 (the int16 (if (logbitp 15 x)
95 (the int16 (- x #x10000))
96 x)))
97
98 (defun int16->card16 (x)
99 (declare (type int16 x))
100 (declare (clx-values card16))
101 #.(declare-buffun)
102 (the card16 (ldb (byte 16 0) x)))
103
104 (defun card32->int32 (x)
105 (declare (type card32 x))
106 (declare (clx-values int32))
107 #.(declare-buffun)
108 (the int32 (if (logbitp 31 x)
109 (the int32 (- x #x100000000))
110 x)))
111
112 (defun int32->card32 (x)
113 (declare (type int32 x))
114 (declare (clx-values card32))
115 #.(declare-buffun)
116 (the card32 (ldb (byte 32 0) x)))
117
118 )
119
120 (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
121
122 (progn
123
124 (defun aref-card8 (a i)
125 (declare (type buffer-bytes a)
126 (type array-index i))
127 (declare (clx-values card8))
128 #.(declare-buffun)
129 (the card8 (aref a i)))
130
131 (defun aset-card8 (v a i)
132 (declare (type card8 v)
133 (type buffer-bytes a)
134 (type array-index i))
135 #.(declare-buffun)
136 (setf (aref a i) v))
137
138 (defun aref-int8 (a i)
139 (declare (type buffer-bytes a)
140 (type array-index i))
141 (declare (clx-values int8))
142 #.(declare-buffun)
143 (card8->int8 (aref a i)))
144
145 (defun aset-int8 (v a i)
146 (declare (type int8 v)
147 (type buffer-bytes a)
148 (type array-index i))
149 #.(declare-buffun)
150 (setf (aref a i) (int8->card8 v)))
151
152 )
153
154 (progn
155
156 (defun aref-card16 (a i)
157 (declare (type buffer-bytes a)
158 (type array-index i))
159 (declare (clx-values card16))
160 #.(declare-buffun)
161 (the card16
162 (logior (the card16
163 (ash (the card8 (aref a (index+ i +word-1+))) 8))
164 (the card8
165 (aref a (index+ i +word-0+))))))
166
167 (defun aset-card16 (v a i)
168 (declare (type card16 v)
169 (type buffer-bytes a)
170 (type array-index i))
171 #.(declare-buffun)
172 (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v))
173 (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v)))
174 v)
175
176 (defun aref-int16 (a i)
177 (declare (type buffer-bytes a)
178 (type array-index i))
179 (declare (clx-values int16))
180 #.(declare-buffun)
181 (the int16
182 (logior (the int16
183 (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8))
184 (the card8
185 (aref a (index+ i +word-0+))))))
186
187 (defun aset-int16 (v a i)
188 (declare (type int16 v)
189 (type buffer-bytes a)
190 (type array-index i))
191 #.(declare-buffun)
192 (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v))
193 (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v)))
194 v)
195
196 (defun aref-card32 (a i)
197 (declare (type buffer-bytes a)
198 (type array-index i))
199 (declare (clx-values card32))
200 #.(declare-buffun)
201 (the card32
202 (logior (the card32
203 (ash (the card8 (aref a (index+ i +long-3+))) 24))
204 (the card29
205 (ash (the card8 (aref a (index+ i +long-2+))) 16))
206 (the card16
207 (ash (the card8 (aref a (index+ i +long-1+))) 8))
208 (the card8
209 (aref a (index+ i +long-0+))))))
210
211 (defun aset-card32 (v a i)
212 (declare (type card32 v)
213 (type buffer-bytes a)
214 (type array-index i))
215 #.(declare-buffun)
216 (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v))
217 (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v))
218 (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v))
219 (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v)))
220 v)
221
222 (defun aref-int32 (a i)
223 (declare (type buffer-bytes a)
224 (type array-index i))
225 (declare (clx-values int32))
226 #.(declare-buffun)
227 (the int32
228 (logior (the int32
229 (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24))
230 (the card29
231 (ash (the card8 (aref a (index+ i +long-2+))) 16))
232 (the card16
233 (ash (the card8 (aref a (index+ i +long-1+))) 8))
234 (the card8
235 (aref a (index+ i +long-0+))))))
236
237 (defun aset-int32 (v a i)
238 (declare (type int32 v)
239 (type buffer-bytes a)
240 (type array-index i))
241 #.(declare-buffun)
242 (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v))
243 (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v))
244 (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v))
245 (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v)))
246 v)
247
248 (defun aref-card29 (a i)
249 (declare (type buffer-bytes a)
250 (type array-index i))
251 (declare (clx-values card29))
252 #.(declare-buffun)
253 (the card29
254 (logior (the card29
255 (ash (the card8 (aref a (index+ i +long-3+))) 24))
256 (the card29
257 (ash (the card8 (aref a (index+ i +long-2+))) 16))
258 (the card16
259 (ash (the card8 (aref a (index+ i +long-1+))) 8))
260 (the card8
261 (aref a (index+ i +long-0+))))))
262
263 (defun aset-card29 (v a i)
264 (declare (type card29 v)
265 (type buffer-bytes a)
266 (type array-index i))
267 #.(declare-buffun)
268 (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v))
269 (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v))
270 (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v))
271 (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v)))
272 v)
273
274 )
275
276 (defsetf aref-card8 (a i) (v)
277 `(aset-card8 ,v ,a ,i))
278
279 (defsetf aref-int8 (a i) (v)
280 `(aset-int8 ,v ,a ,i))
281
282 (defsetf aref-card16 (a i) (v)
283 `(aset-card16 ,v ,a ,i))
284
285 (defsetf aref-int16 (a i) (v)
286 `(aset-int16 ,v ,a ,i))
287
288 (defsetf aref-card32 (a i) (v)
289 `(aset-card32 ,v ,a ,i))
290
291 (defsetf aref-int32 (a i) (v)
292 `(aset-int32 ,v ,a ,i))
293
294 (defsetf aref-card29 (a i) (v)
295 `(aset-card29 ,v ,a ,i))
296
297 ;;; Other random conversions
298
299 (defun rgb-val->card16 (value)
300 ;; Short floats are good enough
301 (declare (type rgb-val value))
302 (declare (clx-values card16))
303 #.(declare-buffun)
304 ;; Convert VALUE from float to card16
305 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
306
307 (defun card16->rgb-val (value)
308 ;; Short floats are good enough
309 (declare (type card16 value))
310 (declare (clx-values short-float))
311 #.(declare-buffun)
312 ;; Convert VALUE from card16 to float
313 (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
314
315 (defun radians->int16 (value)
316 ;; Short floats are good enough
317 (declare (type angle value))
318 (declare (clx-values int16))
319 #.(declare-buffun)
320 (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
321
322 (defun int16->radians (value)
323 ;; Short floats are good enough
324 (declare (type int16 value))
325 (declare (clx-values short-float))
326 #.(declare-buffun)
327 (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
328
329
330 ;;-----------------------------------------------------------------------------
331 ;; Character transformation
332 ;;-----------------------------------------------------------------------------
333
334
335 ;;; This stuff transforms chars to ascii codes in card8's and back.
336 ;;; You might have to hack it a little to get it to work for your machine.
337
338 (declaim (inline char->card8 card8->char))
339
340 (macrolet ((char-translators ()
341 (let ((alist
342 `(
343 ;; The normal ascii codes for the control characters.
344 ,@`((#\Return . 13)
345 (#\Linefeed . 10)
346 (#\Rubout . 127)
347 (#\Page . 12)
348 (#\Tab . 9)
349 (#\Backspace . 8)
350 (#\Newline . 10)
351 (#\Space . 32))
352
353 ;; The rest of the common lisp charater set with
354 ;; the normal ascii codes for them.
355 (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
356 (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
357 (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
358 (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
359 (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
360 (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
361 (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
362 (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
363 (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
364 (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
365 (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
366 (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
367 (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
368 (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
369 (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
370 (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
371 (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
372 (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
373 (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
374 (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
375 (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
376 (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
377 (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
378 (#\} . 125) (#\~ . 126))))
379 (cond ((dolist (pair alist nil)
380 (when (not (= (char-code (car pair)) (cdr pair)))
381 (return t)))
382 `(progn
383 (defconstant *char-to-card8-translation-table*
384 ',(let ((array (make-array
385 (let ((max-char-code 255))
386 (dolist (pair alist)
387 (setq max-char-code
388 (max max-char-code
389 (char-code (car pair)))))
390 (1+ max-char-code))
391 :element-type 'card8)))
392 (dotimes (i (length array))
393 (setf (aref array i) (mod i 256)))
394 (dolist (pair alist)
395 (setf (aref array (char-code (car pair)))
396 (cdr pair)))
397 array))
398 (defconstant *card8-to-char-translation-table*
399 ',(let ((array (make-array 256)))
400 (dotimes (i (length array))
401 (setf (aref array i) (code-char i)))
402 (dolist (pair alist)
403 (setf (aref array (cdr pair)) (car pair)))
404 array))
405 (progn
406 (defun char->card8 (char)
407 (declare (type base-char char))
408 #.(declare-buffun)
409 (the card8 (aref (the (simple-array card8 (*))
410 *char-to-card8-translation-table*)
411 (the array-index (char-code char)))))
412 (defun card8->char (card8)
413 (declare (type card8 card8))
414 #.(declare-buffun)
415 (the base-char
416 (or (aref (the simple-vector *card8-to-char-translation-table*)
417 card8)
418 (error "Invalid CHAR code ~D." card8))))
419 )
420 #+Genera
421 (progn
422 (defun char->card8 (char)
423 (declare lt:(side-effects reader reducible))
424 (aref *char-to-card8-translation-table* (char-code char)))
425 (defun card8->char (card8)
426 (declare lt:(side-effects reader reducible))
427 (aref *card8-to-char-translation-table* card8))
428 )
429 (dotimes (i 256)
430 (unless (= i (char->card8 (card8->char i)))
431 (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S"
432 (list i
433 (card8->char i)
434 (char->card8 (card8->char i))))
435 (return nil)))
436 (dotimes (i (length *char-to-card8-translation-table*))
437 (let ((char (code-char i)))
438 (unless (eql char (card8->char (char->card8 char)))
439 (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S"
440 (list char
441 (char->card8 char)
442 (card8->char (char->card8 char))))
443 (return nil))))))
444 (t
445 `(progn
446 (defun char->card8 (char)
447 (declare (type base-char char))
448 #.(declare-buffun)
449 (the card8 (char-code char)))
450 (defun card8->char (card8)
451 (declare (type card8 card8))
452 #.(declare-buffun)
453 (the base-char (code-char card8)))
454 ))))))
455 (char-translators))
456
457 ;;-----------------------------------------------------------------------------
458 ;; Process Locking
459 ;;
460 ;; Common-Lisp doesn't provide process locking primitives, so we define
461 ;; our own here, based on Zetalisp primitives. Holding-Lock is very
462 ;; similar to with-lock on The TI Explorer, and a little more efficient
463 ;; than with-process-lock on a Symbolics.
464 ;;-----------------------------------------------------------------------------
465
466 ;;; MAKE-PROCESS-LOCK: Creating a process lock.
467
468 (defun make-process-lock (name)
469 (ccl:make-lock name))
470
471 ;;; HOLDING-LOCK: Execute a body of code with a lock held.
472
473 ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN
474 ;;; passes its timeout to the holding-lock macro, so any timeout you want to
475 ;;; work for event-listen you should do for holding-lock.
476
477 (defmacro holding-lock ((locator display &optional whostate &key timeout)
478 &body body)
479 (declare (ignore timeout display))
480 `(ccl:with-lock-grabbed (,locator ,whostate)
481 ,@body))
482
483 ;;; WITHOUT-ABORTS
484
485 ;;; If you can inhibit asynchronous keyboard aborts inside the body of this
486 ;;; macro, then it is a good idea to do this. This macro is wrapped around
487 ;;; request writing and reply reading to ensure that requests are atomically
488 ;;; written and replies are atomically read from the stream.
489
490 (defmacro without-aborts (&body body)
491 `(ccl:without-interrupts ,@body))
492
493 ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
494 ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
495 ;;; value changes.
496
497 (defun process-block (whostate predicate &rest predicate-args)
498 (declare (dynamic-extern predicate-args))
499 (apply #'ccl:process-wait whostate predicate predicate-args))
500
501 ;;; PROCESS-WAKEUP: Check some other process' wait function.
502
503 (declaim (inline process-wakeup))
504
505 (defun process-wakeup (process)
506 (declare (ignore process))
507 nil)
508
509 ;;; CURRENT-PROCESS: Return the current process object for input locking and
510 ;;; for calling PROCESS-WAKEUP.
511
512 (declaim (inline current-process))
513
514 ;;; Default return NIL, which is acceptable even if there is a scheduler.
515
516 (defun current-process ()
517 ccl::*current-process*)
518
519 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
520
521 (defmacro without-interrupts (&body body)
522 `(ccl:without-interrupts ,@body))
523
524 ;;; CONDITIONAL-STORE:
525
526 ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
527 ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
528
529 (defmacro conditional-store (place old-value new-value)
530 `(ccl::conditional-store ,place ,old-value ,new-value))
531
532 ;;;----------------------------------------------------------------------------
533 ;;; IO Error Recovery
534 ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro.
535 ;;; It prevents multiple mindless errors when the network craters.
536 ;;;
537 ;;;----------------------------------------------------------------------------
538
539 (defmacro wrap-buf-output ((buffer) &body body)
540 ;; Error recovery wrapper
541 `(unless (buffer-dead ,buffer)
542 ,@body))
543
544 (defmacro wrap-buf-input ((buffer) &body body)
545 (declare (ignore buffer))
546 ;; Error recovery wrapper
547 `(progn ,@body))
548
549
550 ;;;----------------------------------------------------------------------------
551 ;;; System dependent IO primitives
552 ;;; Functions for opening, reading writing forcing-output and closing
553 ;;; the stream to the server.
554 ;;;----------------------------------------------------------------------------
555
556 ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
557 ;;; server
558
559 (defun open-x-stream (host display protocol)
560 (declare (ignore protocol))
561 (let ((local-socket-path (unix-socket-path-from-host host display)))
562 (if local-socket-path
563 (ccl::make-socket :connect :active
564 :address-family :file
565 :remote-filename local-socket-path)
566 (ccl::make-socket :connect :active
567 :remote-host host
568 :remote-port (+ 6000 display)))))
569
570 ;;; BUFFER-READ-DEFAULT - read data from the X stream
571
572 (defun buffer-read-default (display vector start end timeout)
573 (declare (type display display)
574 (type buffer-bytes vector)
575 (type array-index start end)
576 (type (or null (real 0 *)) timeout))
577 #.(declare-buffun)
578 (let ((stream (display-input-stream display)))
579 (declare (type (or null stream) stream))
580 (or (cond ((null stream))
581 ((listen stream) nil)
582 ((and timeout (= timeout 0)) :timeout)
583 ((buffer-input-wait-default display timeout)))
584 (progn
585 (ccl:stream-read-ivector stream vector start (- end start))
586 nil))))
587
588 ;;; BUFFER-WRITE-DEFAULT - write data to the X stream
589
590 (defun buffer-write-default (vector display start end)
591 (declare (type buffer-bytes vector)
592 (type display display)
593 (type array-index start end))
594 #.(declare-buffun)
595 (let ((stream (display-output-stream display)))
596 (declare (type (or null stream) stream))
597 (unless (null stream)
598 (ccl:stream-write-ivector stream vector start (- end start)))
599 nil))
600
601 ;;; buffer-force-output-default - force output to the X stream
602
603 (defun buffer-force-output-default (display)
604 ;; The default buffer force-output function for use with common-lisp streams
605 (declare (type display display))
606 (let ((stream (display-output-stream display)))
607 (declare (type (or null stream) stream))
608 (unless (null stream)
609 (force-output stream))))
610
611 ;;; BUFFER-CLOSE-DEFAULT - close the X stream
612
613 (defun buffer-close-default (display &key abort)
614 ;; The default buffer close function for use with common-lisp streams
615 (declare (type display display))
616 #.(declare-buffun)
617 (let ((stream (display-output-stream display)))
618 (declare (type (or null stream) stream))
619 (unless (null stream)
620 (close stream :abort abort))))
621
622 ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
623 ;;; buffer. This is called in read-input between requests, so that a process
624 ;;; waiting for input is abortable when between requests. Should return
625 ;;; :TIMEOUT if it times out, NIL otherwise.
626
627 (defun buffer-input-wait-default (display timeout)
628 (declare (type display display)
629 (type (or null number) timeout))
630 (let ((stream (display-input-stream display)))
631 (declare (type (or null stream) stream))
632 (cond ((null stream))
633 ((listen stream) nil)
634 ((eql timeout 0) :timeout)
635 (t
636 (let* ((fd (ccl::stream-device stream :input))
637 (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*)))))
638 (if (ccl::process-input-wait fd ticks)
639 nil
640 :timeout))))))
641
642
643 ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
644 ;;; buffer. This should never block, so it can be called from the scheduler.
645
646 ;;; The default implementation is to just use listen.
647
648 (defun buffer-listen-default (display)
649 (declare (type display display))
650 (let ((stream (display-input-stream display)))
651 (declare (type (or null stream) stream))
652 (if (null stream)
653 t
654 (listen stream))))
655
656
657 ;;;----------------------------------------------------------------------------
658 ;;; System dependent speed hacks
659 ;;;----------------------------------------------------------------------------
660
661 ;;
662 ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
663 ;; If your lisp doesn't have stack-lists, and you're worried about
664 ;; consing garbage, you may want to re-write this to allocate and
665 ;; initialize lists from a resource.
666 ;;
667
668 (defmacro with-stack-list ((var &rest elements) &body body)
669 ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
670 ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
671 ;; except that the list produced by MAPCAR resides on the stack and
672 ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
673 `(let ((,var (list ,@elements)))
674 (declare (type cons ,var)
675 #+clx-ansi-common-lisp (dynamic-extent ,var))
676 ,@body))
677
678 (defmacro with-stack-list* ((var &rest elements) &body body)
679 ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
680 ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
681 ;; except that the list produced by MAPCAR resides on the stack and
682 ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
683 `(let ((,var (list* ,@elements)))
684 (declare (type cons ,var)
685 (dynamic-extent ,var))
686 ,@body))
687
688 (declaim (inline buffer-replace))
689
690 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
691 (declare (type buffer-bytes buf1 buf2)
692 (type array-index start1 end1 start2))
693 (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
694
695 (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
696 &body body)
697 (let ((local-state (gensym))
698 (resets nil))
699 (dolist (index indexes)
700 (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
701 resets))
702 `(unwind-protect
703 (progn
704 ,@body)
705 (let ((,local-state (gcontext-local-state ,gc)))
706 (declare (type gcontext-state ,local-state))
707 ,@resets
708 (setf (svref ,local-state ,ts-index) 0))
709 (when ,temp-gc
710 (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
711 (deallocate-gcontext-state ,saved-state))))
712
713 ;;;----------------------------------------------------------------------------
714 ;;; How much error detection should CLX do?
715 ;;; Several levels are possible:
716 ;;;
717 ;;; 1. Do the equivalent of check-type on every argument.
718 ;;;
719 ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format
720 ;;; strings generated by check-type.
721 ;;;
722 ;;; 3. Do error checking only on arguments that are likely to have errors
723 ;;; (like keyword names)
724 ;;;
725 ;;; 4. Do error checking only where not doing so may dammage the envirnment
726 ;;; on a non-tagged machine (i.e. when storing into a structure that has
727 ;;; been passed in)
728 ;;;
729 ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to
730 ;;; store a non-integer into a number array.
731 ;;;
732 ;;; How extensive should the error checking be? For example, if the server
733 ;;; expects a CARD16, is is sufficient for CLX to check for integer, or
734 ;;; should it also check for non-negative and less than 65536?
735 ;;;----------------------------------------------------------------------------
736
737 ;; The +TYPE-CHECK?+ constant controls how much error checking is done.
738 ;; Possible values are:
739 ;; NIL - Don't do any error checking
740 ;; t - Do the equivalent of checktype on every argument
741 ;; :minimal - Do error checking only where errors are likely
742
743 ;;; This controls macro expansion, and isn't changable at run-time You will
744 ;;; probably want to set this to nil if you want good performance at
745 ;;; production time.
746 (defconstant +type-check?+ nil)
747
748 ;; TYPE? is used to allow the code to do error checking at a different level from
749 ;; the declarations. It also does some optimizations for systems that don't have
750 ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc.
751 ;; include range checks. You can modify TYPE? to do less extensive checking
752 ;; for these types if you desire.
753
754 ;;
755 ;; ### This comment is a lie! TYPE? is really also used for run-time type
756 ;; dispatching, not just type checking. -- Ram.
757
758 (defmacro type? (object type)
759 (if (not (constantp type))
760 `(typep ,object ,type)
761 (progn
762 (setq type (eval type))
763 (let ((predicate (assoc type
764 '((drawable drawable-p) (window window-p)
765 (pixmap pixmap-p) (cursor cursor-p)
766 (font font-p) (gcontext gcontext-p)
767 (colormap colormap-p) (null null)
768 (integer integerp)))))
769 (cond (predicate
770 `(,(second predicate) ,object))
771 ((eq type 'generalized-boolean)
772 't) ; Everything is a generalized-boolean.
773 (+type-check?+
774 `(locally (declare (optimize safety)) (typep ,object ',type)))
775 (t
776 `(typep ,object ',type)))))))
777
778 ;; X-TYPE-ERROR is the function called for type errors.
779 ;; If you want lots of checking, but are concerned about code size,
780 ;; this can be made into a macro that ignores some parameters.
781
782 (defun x-type-error (object type &optional error-string)
783 (x-error 'x-type-error
784 :datum object
785 :expected-type type
786 :type-string error-string))
787
788
789 ;;-----------------------------------------------------------------------------
790 ;; Error handlers
791 ;; Hack up KMP error signaling using zetalisp until the real thing comes
792 ;; along
793 ;;-----------------------------------------------------------------------------
794
795 (defun default-error-handler (display error-key &rest key-vals
796 &key asynchronous &allow-other-keys)
797 (declare (type generalized-boolean asynchronous)
798 (dynamic-extent key-vals))
799 ;; The default display-error-handler.
800 ;; It signals the conditions listed in the DISPLAY file.
801 (if asynchronous
802 (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)
803 (apply #'x-error error-key :display display :error-key error-key key-vals)))
804
805 (defun x-error (condition &rest keyargs)
806 (declare (dynamic-extent keyargs))
807 (apply #'error condition keyargs))
808
809 (defun x-cerror (proceed-format-string condition &rest keyargs)
810 (declare (dynamic-extent keyargs))
811 (apply #'cerror proceed-format-string condition keyargs))
812
813
814 ;; version 15 of Pitman error handling defines the syntax for define-condition to be:
815 ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]
816 ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
817 ;; or (:report exp)
818
819 (define-condition x-error (error) ())
820
821
822 ;;-----------------------------------------------------------------------------
823 ;; HOST hacking
824 ;;-----------------------------------------------------------------------------
825
826 (defun host-address (host &optional (family :internet))
827 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
828 ;; and cdr is a list of network address bytes.
829 (declare (type stringable host)
830 (type (or null (member :internet :decnet :chaos) card8) family))
831 (declare (clx-values list))
832 (ecase family
833 ((:internet nil 0)
834 (let* ((addr (ccl::host-as-inet-host host)))
835 (cons :internet (list
836 (ldb (byte 8 24) addr)
837 (ldb (byte 8 16) addr)
838 (ldb (byte 8 8) addr)
839 (ldb (byte 8 0) addr)))))))
840
841
842 ;;-----------------------------------------------------------------------------
843 ;; Whether to use closures for requests or not.
844 ;;-----------------------------------------------------------------------------
845
846 ;;; If this macro expands to non-NIL, then request and locking code is
847 ;;; compiled in a much more compact format, as the common code is shared, and
848 ;;; the specific code is built into a closure that is funcalled by the shared
849 ;;; code. If your compiler makes efficient use of closures then you probably
850 ;;; want to make this expand to T, as it makes the code more compact.
851
852 (defmacro use-closures () nil)
853
854 (defun clx-macroexpand (form env)
855 (macroexpand form env))
856
857
858 ;;-----------------------------------------------------------------------------
859 ;; Resource stuff
860 ;;-----------------------------------------------------------------------------
861
862
863 ;;; Utilities
864
865 (defun getenv (name)
866 (ccl::getenv name))
867
868 (defun get-host-name ()
869 "Return the same hostname as gethostname(3) would"
870 (machine-instance))
871
872 (defun homedir-file-pathname (name)
873 (merge-pathnames (user-homedir-pathname) (pathname name)))
874
875 ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
876 ;;; a resource manager isn't running.
877
878 (defun default-resources-pathname ()
879 (homedir-file-pathname ".Xdefaults"))
880
881 ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
882 ;;; defaults have been loaded.
883
884 (defun resources-pathname ()
885 (or (let ((string (getenv "XENVIRONMENT")))
886 (and string
887 (pathname string)))
888 (homedir-file-pathname
889 (concatenate 'string ".Xdefaults-" (get-host-name)))))
890
891 ;;; AUTHORITY-PATHNAME - The pathname of the authority file.
892
893 (defun authority-pathname ()
894 (or (let ((xauthority (getenv "XAUTHORITY")))
895 (and xauthority
896 (pathname xauthority)))
897 (homedir-file-pathname ".Xauthority")))
898
899 ;;; this particular defaulting behaviour is typical to most Unices, I think
900
901 (defun get-default-display (&optional display-name)
902 "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY
903 if it is NIL. Display names have the format
904
905 [protocol/] [hostname] : [:] displaynumber [.screennumber]
906
907 There are two special cases in parsing, to match that done in the Xlib
908 C language bindings
909
910 - If the hostname is ``unix'' or the empty string, any supplied
911 protocol is ignored and a connection is made using the :local
912 transport.
913
914 - If a double colon separates hostname from displaynumber, the
915 protocol is assumed to be decnet.
916
917 Returns a list of (host display-number screen protocol)."
918 (let* ((name (or display-name
919 (getenv "DISPLAY")
920 (error "DISPLAY environment variable is not set")))
921 (slash-i (or (position #\/ name) -1))
922 (colon-i (position #\: name :start (1+ slash-i)))
923 (decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
924 (host (subseq name (1+ slash-i) colon-i))
925 (dot-i (and colon-i (position #\. name :start colon-i)))
926 (display (when colon-i
927 (parse-integer name
928 :start (if decnet-colon-p
929 (+ colon-i 2)
930 (1+ colon-i))
931 :end dot-i)))
932 (screen (when dot-i
933 (parse-integer name :start (1+ dot-i))))
934 (protocol
935 (cond ((or (string= host "") (string-equal host "unix")) :local)
936 (decnet-colon-p :decnet)
937 ((> slash-i -1) (intern
938 (string-upcase (subseq name 0 slash-i))
939 :keyword))
940 (t :internet))))
941 (list host (or display 0) (or screen 0) protocol)))
942
943
944 ;;-----------------------------------------------------------------------------
945 ;; GC stuff
946 ;;-----------------------------------------------------------------------------
947
948 (defun gc-cleanup ()
949 (declare (special *event-free-list*
950 *pending-command-free-list*
951 *reply-buffer-free-lists*
952 *gcontext-local-state-cache*
953 *temp-gcontext-cache*))
954 (setq *event-free-list* nil)
955 (setq *pending-command-free-list* nil)
956 (when (boundp '*reply-buffer-free-lists*)
957 (fill *reply-buffer-free-lists* nil))
958 (setq *gcontext-local-state-cache* nil)
959 (setq *temp-gcontext-cache* nil)
960 nil)
961
962
963 ;;-----------------------------------------------------------------------------
964 ;; DEFAULT-KEYSYM-TRANSLATE
965 ;;-----------------------------------------------------------------------------
966
967 ;;; If object is a character, char-bits are set from state.
968 ;;;
969 ;;; [the following isn't implemented (should it be?)]
970 ;;; If object is a list, it is an alist with entries:
971 ;;; (base-char [modifiers] [mask-modifiers])
972 ;;; When MODIFIERS are specified, this character translation
973 ;;; will only take effect when the specified modifiers are pressed.
974 ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
975 ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
976 ;;; In ambiguous cases, the most specific translation is used.
977
978 (defun default-keysym-translate (display state object)
979 (declare (type display display)
980 (type card16 state)
981 (type t object)
982 (ignore display state)
983 (clx-values t))
984 object)
985
986
987 ;;-----------------------------------------------------------------------------
988 ;; Image stuff
989 ;;-----------------------------------------------------------------------------
990
991 ;;; Types
992
993 (deftype pixarray-1-element-type ()
994 'bit)
995
996 (deftype pixarray-4-element-type ()
997 '(unsigned-byte 4))
998
999 (deftype pixarray-8-element-type ()
1000 '(unsigned-byte 8))
1001
1002 (deftype pixarray-16-element-type ()
1003 '(unsigned-byte 16))
1004
1005 (deftype pixarray-24-element-type ()
1006 '(unsigned-byte 24))
1007
1008 (deftype pixarray-32-element-type ()
1009 '(unsigned-byte 32))
1010
1011 (deftype pixarray-1 ()
1012 '(array pixarray-1-element-type (* *)))
1013
1014 (deftype pixarray-4 ()
1015 '(array pixarray-4-element-type (* *)))
1016
1017 (deftype pixarray-8 ()
1018 '(array pixarray-8-element-type (* *)))
1019
1020 (deftype pixarray-16 ()
1021 '(array pixarray-16-element-type (* *)))
1022
1023 (deftype pixarray-24 ()
1024 '(array pixarray-24-element-type (* *)))
1025
1026 (deftype pixarray-32 ()
1027 '(array pixarray-32-element-type (* *)))
1028
1029 (deftype pixarray ()
1030 '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
1031
1032 (deftype bitmap ()
1033 'pixarray-1)
1034
1035 ;;; WITH-UNDERLYING-SIMPLE-VECTOR
1036
1037 (defmacro with-underlying-simple-vector ((variable element-type pixarray)
1038 &body body)
1039 (declare (ignore element-type))
1040 `(let* ((,variable (ccl::array-data-and-offset ,pixarray)))
1041 ,@body))
1042
1043 ;;; These are used to read and write pixels from and to CARD8s.
1044
1045 ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
1046
1047 (defmacro read-image-load-byte (size position integer)
1048 (unless +image-bit-lsb-first-p+ (setq position (- 7 position)))
1049 `(the (unsigned-byte ,size)
1050 (ldb
1051 (byte ,size ,position)
1052 (the card8 ,integer))))
1053
1054 ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from
1055 ;;; the appropriate number of CARD8s.
1056
1057 (defmacro read-image-assemble-bytes (&rest bytes)
1058 (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes)))
1059 (let ((it (first bytes))
1060 (count 0))
1061 (dolist (byte (rest bytes))
1062 (setq it
1063 `(dpb
1064 (the card8 ,byte)
1065 (byte 8 ,(incf count 8))
1066 (the (unsigned-byte ,count) ,it))))
1067 `(the (unsigned-byte ,(* (length bytes) 8)) ,it)))
1068
1069 ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
1070 ;;; pixel.
1071
1072 (defmacro write-image-load-byte (position integer integer-size)
1073 integer-size
1074 (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position)))
1075 `(the card8
1076 (ldb
1077 (byte 8 ,position)
1078 (the (unsigned-byte ,integer-size) ,integer))))
1079
1080 ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
1081 ;;; pixels.
1082
1083 (defmacro write-image-assemble-bytes (&rest bytes)
1084 (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes)))
1085 (let ((size (floor 8 (length bytes)))
1086 (it (first bytes))
1087 (count 0))
1088 (dolist (byte (rest bytes))
1089 (setq it `(dpb
1090 (the (unsigned-byte ,size) ,byte)
1091 (byte ,size ,(incf count size))
1092 (the (unsigned-byte ,count) ,it))))
1093 `(the card8 ,it)))
1094
1095
1096 ;;; If you can write fast routines that can read and write pixarrays out of a
1097 ;;; buffer-bytes, do it! It makes the image code a lot faster. The
1098 ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines
1099 ;;; return T if they can do it, NIL if they can't.
1100
1101 ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
1102
1103 (defun fast-read-pixarray (bbuf boffset pixarray
1104 x y width height padded-bytes-per-line
1105 bits-per-pixel
1106 unit byte-lsb-first-p bit-lsb-first-p)
1107 (declare (ignore bbuf boffset pixarray x y width height
1108 padded-bytes-per-line bits-per-pixel unit
1109 byte-lsb-first-p bit-lsb-first-p))
1110 nil)
1111
1112 ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
1113
1114 (defun fast-write-pixarray (bbuf boffset pixarray x y width height
1115 padded-bytes-per-line bits-per-pixel
1116 unit byte-lsb-first-p bit-lsb-first-p)
1117 (declare (ignore bbuf boffset pixarray x y width height
1118 padded-bytes-per-line bits-per-pixel unit
1119 byte-lsb-first-p bit-lsp-first-p))
1120 nil)
1121
1122 ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
1123
1124 (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel)
1125 (declare (ignore pixarray copy x y width height bits-per-pixel))
1126 nil)

  ViewVC Help
Powered by ViewVC 1.1.5