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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3.1.3 - (hide annotations) (vendor branch)
Fri Sep 30 16:17:28 1994 UTC (19 years, 6 months ago) by ram
Branch: cmu
Changes since 1.3.1.2: +1 -1 lines
Lucid tweak.
1 ram 1.3.1.1 ;;; -*- 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    
21     (in-package :xlib)
22    
23 ram 1.3.1.2 (proclaim '(declaration array-register))
24    
25 ram 1.3.1.1 #+cmu
26     (setf (getf ext:*herald-items* :xlib)
27     `(" CLX X Library " ,*version*))
28    
29 ram 1.2 ;;; The size of the output buffer. Must be a multiple of 4.
30     (defparameter *output-buffer-size* 8192)
31 ram 1.1
32     #+explorer
33     (zwei:define-indentation event-case (1 1))
34    
35     ;;; Number of seconds to wait for a reply to a server request
36     (defparameter *reply-timeout* nil)
37    
38     #-(or clx-overlapping-arrays (not clx-little-endian))
39     (progn
40     (defconstant *word-0* 0)
41     (defconstant *word-1* 1)
42    
43     (defconstant *long-0* 0)
44     (defconstant *long-1* 1)
45     (defconstant *long-2* 2)
46     (defconstant *long-3* 3))
47    
48     #-(or clx-overlapping-arrays clx-little-endian)
49     (progn
50     (defconstant *word-0* 1)
51     (defconstant *word-1* 0)
52    
53     (defconstant *long-0* 3)
54     (defconstant *long-1* 2)
55     (defconstant *long-2* 1)
56     (defconstant *long-3* 0))
57    
58     ;;; Set some compiler-options for often used code
59    
60     (eval-when (eval compile load)
61    
62 ram 1.3 (defconstant *buffer-speed* #+clx-debugging 1 #-clx-debugging 3
63 ram 1.1 "Speed compiler option for buffer code.")
64     (defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0
65     "Safety compiler option for buffer code.")
66    
67     (defun declare-bufmac ()
68     `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
69    
70     ;;; It's my impression that in lucid there's some way to make a declaration
71     ;;; called fast-entry or something that causes a function to not do some
72     ;;; checking on args. Sadly, we have no lucid manuals here. If such a
73     ;;; declaration is available, it would be a good idea to make it here when
74     ;;; *buffer-speed* is 3 and *buffer-safety* is 0.
75     (defun declare-buffun ()
76 ram 1.3.1.1 #+(and cmu clx-debugging)
77     '(declare (optimize (speed 1) (safety 1)))
78     #-(and cmu clx-debugging)
79 ram 1.1 `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
80    
81     )
82    
83     (declaim (inline card8->int8 int8->card8
84     card16->int16 int16->card16
85     card32->int32 int32->card32))
86    
87     #-Genera
88     (progn
89    
90     (defun card8->int8 (x)
91     (declare (type card8 x))
92 ram 1.3 (declare (clx-values int8))
93 ram 1.1 #.(declare-buffun)
94     (the int8 (if (logbitp 7 x)
95     (the int8 (- x #x100))
96     x)))
97    
98     (defun int8->card8 (x)
99     (declare (type int8 x))
100 ram 1.3 (declare (clx-values card8))
101 ram 1.1 #.(declare-buffun)
102     (the card8 (ldb (byte 8 0) x)))
103    
104     (defun card16->int16 (x)
105     (declare (type card16 x))
106 ram 1.3 (declare (clx-values int16))
107 ram 1.1 #.(declare-buffun)
108     (the int16 (if (logbitp 15 x)
109     (the int16 (- x #x10000))
110     x)))
111    
112     (defun int16->card16 (x)
113     (declare (type int16 x))
114 ram 1.3 (declare (clx-values card16))
115 ram 1.1 #.(declare-buffun)
116     (the card16 (ldb (byte 16 0) x)))
117    
118     (defun card32->int32 (x)
119     (declare (type card32 x))
120 ram 1.3 (declare (clx-values int32))
121 ram 1.1 #.(declare-buffun)
122     (the int32 (if (logbitp 31 x)
123     (the int32 (- x #x100000000))
124     x)))
125    
126     (defun int32->card32 (x)
127     (declare (type int32 x))
128 ram 1.3 (declare (clx-values card32))
129 ram 1.1 #.(declare-buffun)
130     (the card32 (ldb (byte 32 0) x)))
131    
132     )
133    
134     #+Genera
135     (progn
136    
137     (defun card8->int8 (x)
138     (declare lt:(side-effects simple reducible))
139     (if (logbitp 7 x) (- x #x100) x))
140    
141     (defun int8->card8 (x)
142     (declare lt:(side-effects simple reducible))
143     (ldb (byte 8 0) x))
144    
145     (defun card16->int16 (x)
146     (declare lt:(side-effects simple reducible))
147     (if (logbitp 15 x) (- x #x10000) x))
148    
149     (defun int16->card16 (x)
150     (declare lt:(side-effects simple reducible))
151     (ldb (byte 16 0) x))
152    
153     (defun card32->int32 (x)
154     (declare lt:(side-effects simple reducible))
155     (sys:%logldb (byte 32 0) x))
156    
157     (defun int32->card32 (x)
158     (declare lt:(side-effects simple reducible))
159     (ldb (byte 32 0) x))
160    
161     )
162    
163     (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
164    
165 ram 1.2 #-(or Genera lcl3.0 excl)
166 ram 1.1 (progn
167    
168     (defun aref-card8 (a i)
169     (declare (type buffer-bytes a)
170     (type array-index i))
171 ram 1.3 (declare (clx-values card8))
172 ram 1.1 #.(declare-buffun)
173     (the card8 (aref a i)))
174    
175     (defun aset-card8 (v a i)
176     (declare (type card8 v)
177     (type buffer-bytes a)
178     (type array-index i))
179     #.(declare-buffun)
180     (setf (aref a i) v))
181    
182     (defun aref-int8 (a i)
183     (declare (type buffer-bytes a)
184     (type array-index i))
185 ram 1.3 (declare (clx-values int8))
186 ram 1.1 #.(declare-buffun)
187     (card8->int8 (aref a i)))
188    
189     (defun aset-int8 (v a i)
190     (declare (type int8 v)
191     (type buffer-bytes a)
192     (type array-index i))
193     #.(declare-buffun)
194     (setf (aref a i) (int8->card8 v)))
195    
196     )
197    
198     #+Genera
199     (progn
200    
201     (defun aref-card8 (a i)
202     (aref a i))
203    
204     (defun aset-card8 (v a i)
205     (zl:aset v a i))
206    
207     (defun aref-int8 (a i)
208     (card8->int8 (aref a i)))
209    
210     (defun aset-int8 (v a i)
211     (zl:aset (int8->card8 v) a i))
212    
213     )
214    
215 ram 1.2 #+(or excl lcl3.0 clx-overlapping-arrays)
216 ram 1.1 (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
217     aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
218    
219     #+(and clx-overlapping-arrays Genera)
220     (progn
221    
222     (defun aref-card16 (a i)
223     (aref a i))
224    
225     (defun aset-card16 (v a i)
226     (zl:aset v a i))
227    
228     (defun aref-int16 (a i)
229     (card16->int16 (aref a i)))
230    
231     (defun aset-int16 (v a i)
232     (zl:aset (int16->card16 v) a i)
233     v)
234    
235     (defun aref-card32 (a i)
236     (int32->card32 (aref a i)))
237    
238     (defun aset-card32 (v a i)
239     (zl:aset (card32->int32 v) a i))
240    
241     (defun aref-int32 (a i) (aref a i))
242    
243     (defun aset-int32 (v a i)
244     (zl:aset v a i))
245    
246     (defun aref-card29 (a i)
247     (aref a i))
248    
249     (defun aset-card29 (v a i)
250     (zl:aset v a i))
251    
252     )
253    
254     #+(and clx-overlapping-arrays (not Genera))
255     (progn
256    
257     (defun aref-card16 (a i)
258     (aref a i))
259    
260     (defun aset-card16 (v a i)
261     (setf (aref a i) v))
262    
263     (defun aref-int16 (a i)
264     (card16->int16 (aref a i)))
265    
266     (defun aset-int16 (v a i)
267     (setf (aref a i) (int16->card16 v))
268     v)
269    
270     (defun aref-card32 (a i)
271     (aref a i))
272    
273     (defun aset-card32 (v a i)
274     (setf (aref a i) v))
275    
276     (defun aref-int32 (a i)
277     (card32->int32 (aref a i)))
278    
279     (defun aset-int32 (v a i)
280     (setf (aref a i) (int32->card32 v))
281     v)
282    
283     (defun aref-card29 (a i)
284     (aref a i))
285    
286     (defun aset-card29 (v a i)
287     (setf (aref a i) v))
288    
289     )
290    
291     #+excl
292     (progn
293    
294 ram 1.2 (defun aref-card8 (a i)
295     (declare (type buffer-bytes a)
296     (type array-index i))
297 ram 1.3 (declare (clx-values card8))
298 ram 1.2 #.(declare-buffun)
299     (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
300     :unsigned-byte)))
301    
302     (defun aset-card8 (v a i)
303     (declare (type card8 v)
304     (type buffer-bytes a)
305     (type array-index i))
306     #.(declare-buffun)
307     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
308     :unsigned-byte) v))
309    
310     (defun aref-int8 (a i)
311     (declare (type buffer-bytes a)
312     (type array-index i))
313 ram 1.3 (declare (clx-values int8))
314 ram 1.2 #.(declare-buffun)
315     (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
316     :signed-byte)))
317    
318     (defun aset-int8 (v a i)
319     (declare (type int8 v)
320     (type buffer-bytes a)
321     (type array-index i))
322     #.(declare-buffun)
323     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
324     :signed-byte) v))
325    
326     (defun aref-card16 (a i)
327     (declare (type buffer-bytes a)
328     (type array-index i))
329 ram 1.3 (declare (clx-values card16))
330 ram 1.2 #.(declare-buffun)
331     (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
332     :unsigned-word)))
333 ram 1.1
334 ram 1.2 (defun aset-card16 (v a i)
335     (declare (type card16 v)
336     (type buffer-bytes a)
337     (type array-index i))
338     #.(declare-buffun)
339     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
340     :unsigned-word) v))
341 ram 1.1
342 ram 1.2 (defun aref-int16 (a i)
343     (declare (type buffer-bytes a)
344     (type array-index i))
345 ram 1.3 (declare (clx-values int16))
346 ram 1.2 #.(declare-buffun)
347     (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
348     :signed-word)))
349 ram 1.1
350 ram 1.2 (defun aset-int16 (v a i)
351     (declare (type int16 v)
352     (type buffer-bytes a)
353     (type array-index i))
354     #.(declare-buffun)
355     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
356     :signed-word) v))
357 ram 1.1
358 ram 1.2 (defun aref-card32 (a i)
359     (declare (type buffer-bytes a)
360     (type array-index i))
361 ram 1.3 (declare (clx-values card32))
362 ram 1.2 #.(declare-buffun)
363     (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
364     :unsigned-long)))
365 ram 1.1
366 ram 1.2 (defun aset-card32 (v a i)
367     (declare (type card32 v)
368     (type buffer-bytes a)
369     (type array-index i))
370     #.(declare-buffun)
371     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
372     :unsigned-long) v))
373 ram 1.1
374 ram 1.2 (defun aref-int32 (a i)
375     (declare (type buffer-bytes a)
376     (type array-index i))
377 ram 1.3 (declare (clx-values int32))
378 ram 1.2 #.(declare-buffun)
379     (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
380     :signed-long)))
381 ram 1.1
382 ram 1.2 (defun aset-int32 (v a i)
383     (declare (type int32 v)
384     (type buffer-bytes a)
385     (type array-index i))
386     #.(declare-buffun)
387     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
388     :signed-long) v))
389 ram 1.1
390 ram 1.2 (defun aref-card29 (a i)
391     (declare (type buffer-bytes a)
392     (type array-index i))
393 ram 1.3 (declare (clx-values card29))
394 ram 1.2 #.(declare-buffun)
395     (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
396     :unsigned-long)))
397 ram 1.1
398 ram 1.2 (defun aset-card29 (v a i)
399     (declare (type card29 v)
400     (type buffer-bytes a)
401     (type array-index i))
402     #.(declare-buffun)
403     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
404     :unsigned-long) v))
405 ram 1.1
406     )
407    
408     #+lcl3.0
409 ram 1.2 (progn
410 ram 1.1
411 ram 1.2 (defun aref-card8 (a i)
412     (declare (type buffer-bytes a)
413     (type array-index i)
414 ram 1.3 (clx-values card8))
415 ram 1.2 #.(declare-buffun)
416     (the card8 (lucid::%svref-8bit a i)))
417    
418     (defun aset-card8 (v a i)
419     (declare (type card8 v)
420     (type buffer-bytes a)
421     (type array-index i))
422     #.(declare-buffun)
423     (setf (lucid::%svref-8bit a i) v))
424    
425     (defun aref-int8 (a i)
426     (declare (type buffer-bytes a)
427     (type array-index i)
428 ram 1.3 (clx-values int8))
429 ram 1.2 #.(declare-buffun)
430     (the int8 (lucid::%svref-signed-8bit a i)))
431    
432     (defun aset-int8 (v a i)
433     (declare (type int8 v)
434     (type buffer-bytes a)
435     (type array-index i))
436     #.(declare-buffun)
437     (setf (lucid::%svref-signed-8bit a i) v))
438    
439 ram 1.1 (defun aref-card16 (a i)
440 ram 1.2 (declare (type buffer-bytes a)
441     (type array-index i)
442 ram 1.3 (clx-values card16))
443 ram 1.1 #.(declare-buffun)
444 ram 1.2 (the card16 (lucid::%svref-16bit a (index-ash i -1))))
445 ram 1.1
446     (defun aset-card16 (v a i)
447 ram 1.2 (declare (type card16 v)
448     (type buffer-bytes a)
449     (type array-index i))
450 ram 1.1 #.(declare-buffun)
451 ram 1.2 (setf (lucid::%svref-16bit a (index-ash i -1)) v))
452 ram 1.1
453     (defun aref-int16 (a i)
454 ram 1.2 (declare (type buffer-bytes a)
455     (type array-index i)
456 ram 1.3 (clx-values int16))
457 ram 1.1 #.(declare-buffun)
458 ram 1.2 (the int16 (lucid::%svref-signed-16bit a (index-ash i -1))))
459 ram 1.1
460     (defun aset-int16 (v a i)
461 ram 1.2 (declare (type int16 v)
462     (type buffer-bytes a)
463     (type array-index i))
464 ram 1.1 #.(declare-buffun)
465 ram 1.2 (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v))
466 ram 1.1
467     (defun aref-card32 (a i)
468 ram 1.2 (declare (type buffer-bytes a)
469     (type array-index i)
470 ram 1.3 (clx-values card32))
471 ram 1.1 #.(declare-buffun)
472 ram 1.2 (the card32 (lucid::%svref-32bit a (index-ash i -2))))
473 ram 1.1
474     (defun aset-card32 (v a i)
475 ram 1.2 (declare (type card32 v)
476     (type buffer-bytes a)
477     (type array-index i))
478 ram 1.1 #.(declare-buffun)
479 ram 1.2 (setf (lucid::%svref-32bit a (index-ash i -2)) v))
480 ram 1.1
481     (defun aref-int32 (a i)
482 ram 1.2 (declare (type buffer-bytes a)
483     (type array-index i)
484 ram 1.3 (clx-values int32))
485 ram 1.1 #.(declare-buffun)
486 ram 1.2 (the int32 (lucid::%svref-signed-32bit a (index-ash i -2))))
487 ram 1.1
488     (defun aset-int32 (v a i)
489 ram 1.2 (declare (type int32 v)
490     (type buffer-bytes a)
491     (type array-index i))
492 ram 1.1 #.(declare-buffun)
493 ram 1.2 (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v))
494 ram 1.1
495     (defun aref-card29 (a i)
496 ram 1.2 (declare (type buffer-bytes a)
497     (type array-index i)
498 ram 1.3 (clx-values card29))
499 ram 1.1 #.(declare-buffun)
500 ram 1.2 (the card29 (lucid::%svref-32bit a (index-ash i -2))))
501 ram 1.1
502     (defun aset-card29 (v a i)
503 ram 1.2 (declare (type card29 v)
504     (type buffer-bytes a)
505     (type array-index i))
506 ram 1.1 #.(declare-buffun)
507 ram 1.2 (setf (lucid::%svref-32bit a (index-ash i -2)) v))
508    
509 ram 1.1 )
510    
511    
512    
513     #-(or excl lcl3.0 clx-overlapping-arrays)
514     (progn
515    
516     (defun aref-card16 (a i)
517     (declare (type buffer-bytes a)
518     (type array-index i))
519 ram 1.3 (declare (clx-values card16))
520 ram 1.1 #.(declare-buffun)
521     (the card16
522     (logior (the card16
523     (ash (the card8 (aref a (index+ i *word-1*))) 8))
524     (the card8
525     (aref a (index+ i *word-0*))))))
526    
527     (defun aset-card16 (v a i)
528     (declare (type card16 v)
529     (type buffer-bytes a)
530     (type array-index i))
531     #.(declare-buffun)
532     (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
533     (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
534     v)
535    
536     (defun aref-int16 (a i)
537     (declare (type buffer-bytes a)
538     (type array-index i))
539 ram 1.3 (declare (clx-values int16))
540 ram 1.1 #.(declare-buffun)
541     (the int16
542     (logior (the int16
543     (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))
544     (the card8
545     (aref a (index+ i *word-0*))))))
546    
547     (defun aset-int16 (v a i)
548     (declare (type int16 v)
549     (type buffer-bytes a)
550     (type array-index i))
551     #.(declare-buffun)
552     (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
553     (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
554     v)
555    
556     (defun aref-card32 (a i)
557     (declare (type buffer-bytes a)
558     (type array-index i))
559 ram 1.3 (declare (clx-values card32))
560 ram 1.1 #.(declare-buffun)
561     (the card32
562     (logior (the card32
563     (ash (the card8 (aref a (index+ i *long-3*))) 24))
564     (the card29
565     (ash (the card8 (aref a (index+ i *long-2*))) 16))
566     (the card16
567     (ash (the card8 (aref a (index+ i *long-1*))) 8))
568     (the card8
569     (aref a (index+ i *long-0*))))))
570    
571     (defun aset-card32 (v a i)
572     (declare (type card32 v)
573     (type buffer-bytes a)
574     (type array-index i))
575     #.(declare-buffun)
576     (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
577     (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
578     (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
579     (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
580     v)
581    
582     (defun aref-int32 (a i)
583     (declare (type buffer-bytes a)
584     (type array-index i))
585 ram 1.3 (declare (clx-values int32))
586 ram 1.1 #.(declare-buffun)
587     (the int32
588     (logior (the int32
589     (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))
590     (the card29
591     (ash (the card8 (aref a (index+ i *long-2*))) 16))
592     (the card16
593     (ash (the card8 (aref a (index+ i *long-1*))) 8))
594     (the card8
595     (aref a (index+ i *long-0*))))))
596    
597     (defun aset-int32 (v a i)
598     (declare (type int32 v)
599     (type buffer-bytes a)
600     (type array-index i))
601     #.(declare-buffun)
602     (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
603     (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
604     (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
605     (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
606     v)
607    
608     (defun aref-card29 (a i)
609     (declare (type buffer-bytes a)
610     (type array-index i))
611 ram 1.3 (declare (clx-values card29))
612 ram 1.1 #.(declare-buffun)
613     (the card29
614     (logior (the card29
615     (ash (the card8 (aref a (index+ i *long-3*))) 24))
616     (the card29
617     (ash (the card8 (aref a (index+ i *long-2*))) 16))
618     (the card16
619     (ash (the card8 (aref a (index+ i *long-1*))) 8))
620     (the card8
621     (aref a (index+ i *long-0*))))))
622    
623     (defun aset-card29 (v a i)
624     (declare (type card29 v)
625     (type buffer-bytes a)
626     (type array-index i))
627     #.(declare-buffun)
628     (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
629     (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
630     (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
631     (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
632     v)
633    
634     )
635    
636     (defsetf aref-card8 (a i) (v)
637     `(aset-card8 ,v ,a ,i))
638    
639     (defsetf aref-int8 (a i) (v)
640     `(aset-int8 ,v ,a ,i))
641    
642     (defsetf aref-card16 (a i) (v)
643     `(aset-card16 ,v ,a ,i))
644    
645     (defsetf aref-int16 (a i) (v)
646     `(aset-int16 ,v ,a ,i))
647    
648     (defsetf aref-card32 (a i) (v)
649     `(aset-card32 ,v ,a ,i))
650    
651     (defsetf aref-int32 (a i) (v)
652     `(aset-int32 ,v ,a ,i))
653    
654     (defsetf aref-card29 (a i) (v)
655     `(aset-card29 ,v ,a ,i))
656    
657     ;;; Other random conversions
658    
659     (defun rgb-val->card16 (value)
660     ;; Short floats are good enough
661     (declare (type rgb-val value))
662 ram 1.3 (declare (clx-values card16))
663 ram 1.1 #.(declare-buffun)
664     ;; Convert VALUE from float to card16
665     (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
666    
667     (defun card16->rgb-val (value)
668     ;; Short floats are good enough
669     (declare (type card16 value))
670 ram 1.3 (declare (clx-values short-float))
671 ram 1.1 #.(declare-buffun)
672     ;; Convert VALUE from card16 to float
673     (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
674    
675     (defun radians->int16 (value)
676     ;; Short floats are good enough
677     (declare (type angle value))
678 ram 1.3 (declare (clx-values int16))
679 ram 1.1 #.(declare-buffun)
680     (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
681    
682     (defun int16->radians (value)
683     ;; Short floats are good enough
684     (declare (type int16 value))
685 ram 1.3 (declare (clx-values short-float))
686 ram 1.1 #.(declare-buffun)
687     (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
688    
689 ram 1.3.1.1
690     #+cmu (progn
691    
692     ;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI
693     ;;; is irrational, there can't be a precise rational representation. In
694     ;;; particular, the different float approximations will always be /=. This
695     ;;; causes problems with type checking, because people might compute an
696     ;;; argument in any precision. What we do is discard all the excess precision
697     ;;; in the value, and see if the protocal encoding falls in the desired range
698     ;;; (64'ths of a degree.)
699     ;;;
700     (deftype angle () '(satisfies anglep))
701    
702     (defun anglep (x)
703     (and (typep x 'real)
704     (<= (* -360 64) (radians->int16 x) (* 360 64))))
705    
706     )
707    
708 ram 1.1
709     ;;-----------------------------------------------------------------------------
710     ;; Character transformation
711     ;;-----------------------------------------------------------------------------
712    
713    
714     ;;; This stuff transforms chars to ascii codes in card8's and back.
715     ;;; You might have to hack it a little to get it to work for your machine.
716    
717     (declaim (inline char->card8 card8->char))
718    
719     (macrolet ((char-translators ()
720     (let ((alist
721     `(#-lispm
722     ;; The normal ascii codes for the control characters.
723     ,@`((#\Return . 13)
724     (#\Linefeed . 10)
725     (#\Rubout . 127)
726     (#\Page . 12)
727     (#\Tab . 9)
728     (#\Backspace . 8)
729     (#\Newline . 10)
730     (#\Space . 32))
731     ;; One the lispm, #\Newline is #\Return, but we'd really like
732     ;; #\Newline to translate to ascii code 10, so we swap the
733     ;; Ascii codes for #\Return and #\Linefeed. We also provide
734     ;; mappings from the counterparts of these control characters
735     ;; so that the character mapping from the lisp machine
736     ;; character set to ascii is invertible.
737     #+lispm
738     ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return))
739     (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed))
740     (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout))
741     (#\Page . 12) (,(code-char 12) . ,(char-code #\Page))
742     (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab))
743     (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace))
744     (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline))
745     (#\Space . 32) (,(code-char 32) . ,(char-code #\Space)))
746     ;; The rest of the common lisp charater set with the normal
747     ;; ascii codes for them.
748     (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
749     (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
750     (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
751     (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
752     (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
753     (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
754     (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
755     (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
756     (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
757     (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
758     (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
759     (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
760     (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
761     (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
762     (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
763     (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
764     (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
765     (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
766     (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
767     (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
768     (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
769     (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
770     (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
771     (#\} . 125) (#\~ . 126))))
772     (cond ((dolist (pair alist nil)
773     (when (not (= (char-code (car pair)) (cdr pair)))
774     (return t)))
775     `(progn
776     (defconstant *char-to-card8-translation-table*
777     ',(let ((array (make-array
778     (let ((max-char-code 255))
779     (dolist (pair alist)
780     (setq max-char-code
781     (max max-char-code
782     (char-code (car pair)))))
783     (1+ max-char-code))
784     :element-type 'card8)))
785     (dotimes (i (length array))
786     (setf (aref array i) (mod i 256)))
787     (dolist (pair alist)
788     (setf (aref array (char-code (car pair)))
789     (cdr pair)))
790     array))
791     (defconstant *card8-to-char-translation-table*
792 ram 1.3 ',(let ((array (make-array 256)))
793 ram 1.1 (dotimes (i (length array))
794     (setf (aref array i) (code-char i)))
795     (dolist (pair alist)
796     (setf (aref array (cdr pair)) (car pair)))
797     array))
798     #-Genera
799     (progn
800     (defun char->card8 (char)
801 ram 1.2 (declare (type base-char char))
802 ram 1.1 #.(declare-buffun)
803     (the card8 (aref (the (simple-array card8 (*))
804     *char-to-card8-translation-table*)
805     (the array-index (char-code char)))))
806     (defun card8->char (card8)
807     (declare (type card8 card8))
808     #.(declare-buffun)
809 ram 1.2 (the base-char
810 ram 1.3 (or (aref (the simple-vector *card8-to-char-translation-table*)
811     card8)
812     (error "Invalid CHAR code ~D." card8))))
813 ram 1.1 )
814     #+Genera
815     (progn
816     (defun char->card8 (char)
817     (declare lt:(side-effects reader reducible))
818     (aref *char-to-card8-translation-table* (char-code char)))
819     (defun card8->char (card8)
820     (declare lt:(side-effects reader reducible))
821     (aref *card8-to-char-translation-table* card8))
822     )
823 ram 1.3 #-Minima
824 ram 1.1 (dotimes (i 256)
825     (unless (= i (char->card8 (card8->char i)))
826     (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S"
827     (list i
828     (card8->char i)
829     (char->card8 (card8->char i))))
830     (return nil)))
831 ram 1.3 #-Minima
832 ram 1.1 (dotimes (i (length *char-to-card8-translation-table*))
833     (let ((char (code-char i)))
834     (unless (eql char (card8->char (char->card8 char)))
835     (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S"
836     (list char
837     (char->card8 char)
838     (card8->char (char->card8 char))))
839     (return nil))))))
840     (t
841     `(progn
842     (defun char->card8 (char)
843 ram 1.2 (declare (type base-char char))
844 ram 1.1 #.(declare-buffun)
845     (the card8 (char-code char)))
846     (defun card8->char (card8)
847     (declare (type card8 card8))
848     #.(declare-buffun)
849 ram 1.2 (the base-char (code-char card8)))
850 ram 1.1 ))))))
851     (char-translators))
852    
853     ;;-----------------------------------------------------------------------------
854     ;; Process Locking
855     ;;
856     ;; Common-Lisp doesn't provide process locking primitives, so we define
857     ;; our own here, based on Zetalisp primitives. Holding-Lock is very
858     ;; similar to with-lock on The TI Explorer, and a little more efficient
859     ;; than with-process-lock on a Symbolics.
860     ;;-----------------------------------------------------------------------------
861    
862     ;;; MAKE-PROCESS-LOCK: Creating a process lock.
863    
864 ram 1.2 #-(or LispM excl Minima)
865 ram 1.1 (defun make-process-lock (name)
866     (declare (ignore name))
867     nil)
868    
869     #+excl
870     (defun make-process-lock (name)
871     (mp:make-process-lock :name name))
872    
873     #+(and LispM (not Genera))
874     (defun make-process-lock (name)
875     (vector nil name))
876    
877     #+Genera
878     (defun make-process-lock (name)
879     (process:make-lock name :flavor 'clx-lock))
880    
881 ram 1.2 #+Minima
882     (defun make-process-lock (name)
883 ram 1.3 (minima:make-lock name :recursive t))
884 ram 1.2
885 ram 1.1 ;;; HOLDING-LOCK: Execute a body of code with a lock held.
886    
887     ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN
888     ;;; passes its timeout to the holding-lock macro, so any timeout you want to
889     ;;; work for event-listen you should do for holding-lock.
890    
891     ;; If you're not sharing DISPLAY objects within a multi-processing
892     ;; shared-memory environment, this is sufficient
893 ram 1.3 #-(or lispm excl lcl3.0 Minima CMU)
894 ram 1.1 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
895     (declare (ignore locator display whostate timeout))
896     `(progn ,@body))
897    
898 ram 1.3 ;;; HOLDING-LOCK for CMU Common Lisp.
899     ;;;
900     ;;; We are not multi-processing, but we use this macro to try to protect
901     ;;; against re-entering request functions. This can happen if an interrupt
902     ;;; occurs and the handler attempts to use X over the same display connection.
903     ;;; This can happen if the GC hooks are used to notify the user over the same
904     ;;; display connection. We lock out GC's just as a dummy check for our users.
905     ;;; Locking out interrupts has the problem that CLX always waits for replies
906     ;;; within this dynamic scope, so if the server cannot reply for some reason,
907     ;;; we potentially dead-lock without interrupts.
908     ;;;
909     #+CMU
910     (defmacro holding-lock ((locator display &optional whostate &key timeout)
911     &body body)
912     (declare (ignore locator display whostate timeout))
913     `(lisp::without-gcing (system:without-interrupts (progn ,@body))))
914    
915 ram 1.1 #+Genera
916     (defmacro holding-lock ((locator display &optional whostate &key timeout)
917     &body body)
918     (declare (ignore whostate))
919     `(process:with-lock (,locator :timeout ,timeout)
920     (let ((.debug-io. (buffer-debug-io ,display)))
921     (scl:let-if .debug-io. ((*debug-io* .debug-io.))
922     ,@body))))
923    
924     #+(and lispm (not Genera))
925     (defmacro holding-lock ((locator display &optional whostate &key timeout)
926     &body body)
927     (declare (ignore display))
928     ;; This macro is for use in a multi-process environment.
929     (let ((lock (gensym))
930     (have-lock (gensym))
931     (timeo (gensym)))
932     `(let* ((,lock (zl:locf (svref ,locator 0)))
933     (,have-lock (eq (car ,lock) sys:current-process))
934     (,timeo ,timeout))
935     (unwind-protect
936     (when (cond (,have-lock)
937     ((#+explorer si:%store-conditional
938     #-explorer sys:store-conditional
939     ,lock nil sys:current-process))
940     ((null ,timeo)
941     (sys:process-lock ,lock nil ,(or whostate "CLX Lock")))
942     ((sys:process-wait-with-timeout
943     ,(or whostate "CLX Lock") (round (* ,timeo 60.))
944     #'(lambda (lock process)
945     (#+explorer si:%store-conditional
946     #-explorer sys:store-conditional
947     lock nil process))
948     ,lock sys:current-process)))
949     ,@body)
950     (unless ,have-lock
951     (#+explorer si:%store-conditional
952     #-explorer sys:store-conditional
953     ,lock sys:current-process nil))))))
954    
955     ;; Lucid has a process locking mechanism as well under release 3.0
956     #+lcl3.0
957     (defmacro holding-lock ((locator display &optional whostate &key timeout)
958     &body body)
959     (declare (ignore display))
960     (if timeout
961     ;; Hair to support timeout.
962     `(let ((.have-lock. (eq ,locator lcl:*current-process*))
963     (.timeout. ,timeout))
964     (unwind-protect
965     (when (cond (.have-lock.)
966     ((conditional-store ,locator nil lcl:*current-process*))
967     ((null .timeout.)
968     (lcl:process-lock ,locator)
969     t)
970     ((lcl:process-wait-with-timeout ,whostate .timeout.
971     #'(lambda ()
972 ram 1.2 (conditional-store ,locator nil lcl:*current-process*))))
973     ;; abort the PROCESS-UNLOCK if actually timing out
974     (t
975     (setf .have-lock. :abort)
976     nil))
977 ram 1.1 ,@body)
978     (unless .have-lock.
979     (lcl:process-unlock ,locator))))
980     `(lcl:with-process-lock (,locator)
981     ,@body)))
982    
983    
984     #+excl
985     (defmacro holding-lock ((locator display &optional whostate &key timeout)
986     &body body)
987     (declare (ignore display))
988     `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)
989     (unwind-protect
990     (block .hl-doit.
991     (when mp::*scheduler-stack-group* ; fast test for scheduler running
992     (setq .hl-lock. ,locator
993     .hl-curproc. mp::*current-process*)
994     (when (and .hl-curproc. ; nil if in process-wait fun
995     (not (eq (mp::process-lock-locker .hl-lock.)
996     .hl-curproc.)))
997     ;; Then we need to grab the lock.
998     ,(if timeout
999     `(if (not (mp::process-lock .hl-lock. .hl-curproc.
1000     ,whostate ,timeout))
1001     (return-from .hl-doit. nil))
1002     `(mp::process-lock .hl-lock. .hl-curproc.
1003     ,@(when whostate `(,whostate))))
1004 ram 1.2 ;; There is an apparent race condition here. However, there is
1005     ;; no actual race condition -- our implementation of mp:process-
1006     ;; lock guarantees that the lock will still be held when it
1007     ;; returns, and no interrupt can happen between that and the
1008     ;; execution of the next form. -- jdi 2/27/91
1009 ram 1.1 (setq .hl-obtained-lock. t)))
1010     ,@body)
1011     (if (and .hl-obtained-lock.
1012     ;; Note -- next form added to allow error handler inside
1013     ;; body to unlock the lock prematurely if it knows that
1014     ;; the current process cannot possibly continue but will
1015     ;; throw out (or is it throw up?).
1016     (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))
1017     (mp::process-unlock .hl-lock. .hl-curproc.)))))
1018    
1019 ram 1.2 #+Minima
1020     (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
1021     `(holding-lock-1 #'(lambda () ,@body) ,locator ,display
1022     ,@(and whostate `(:whostate ,whostate))
1023     ,@(and timeout `(:timeout ,timeout))))
1024 ram 1.1
1025 ram 1.2 #+Minima
1026     (defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout)
1027     (declare (dynamic-extent continuation))
1028     (declare (ignore display whostate timeout))
1029     (minima:with-lock (lock)
1030     (funcall continuation)))
1031    
1032 ram 1.1 ;;; WITHOUT-ABORTS
1033    
1034     ;;; If you can inhibit asynchronous keyboard aborts inside the body of this
1035     ;;; macro, then it is a good idea to do this. This macro is wrapped around
1036     ;;; request writing and reply reading to ensure that requests are atomically
1037     ;;; written and replies are atomically read from the stream.
1038    
1039     #-(or Genera excl lcl3.0)
1040     (defmacro without-aborts (&body body)
1041     `(progn ,@body))
1042    
1043     #+Genera
1044     (defmacro without-aborts (&body body)
1045     `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.")
1046     ,@body))
1047    
1048     #+excl
1049     (defmacro without-aborts (&body body)
1050     `(without-interrupts ,@body))
1051    
1052     #+lcl3.0
1053     (defmacro without-aborts (&body body)
1054     `(lcl:with-interruptions-inhibited ,@body))
1055    
1056     ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
1057     ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
1058     ;;; value changes.
1059    
1060 ram 1.2 #-(or lispm excl lcl3.0 Minima)
1061 ram 1.1 (defun process-block (whostate predicate &rest predicate-args)
1062     (declare (ignore whostate))
1063     (or (apply predicate predicate-args)
1064     (error "Program tried to wait with no scheduler.")))
1065    
1066     #+Genera
1067     (defun process-block (whostate predicate &rest predicate-args)
1068     (declare (type function predicate)
1069 ram 1.2 #+clx-ansi-common-lisp
1070     (dynamic-extent predicate)
1071     #-clx-ansi-common-lisp
1072     (sys:downward-funarg predicate))
1073 ram 1.1 (apply #'process:block-process whostate predicate predicate-args))
1074    
1075     #+(and lispm (not Genera))
1076     (defun process-block (whostate predicate &rest predicate-args)
1077     (declare (type function predicate)
1078 ram 1.2 #+clx-ansi-common-lisp
1079     (dynamic-extent predicate)
1080     #-clx-ansi-common-lisp
1081     (sys:downward-funarg predicate))
1082 ram 1.1 (apply #'global:process-wait whostate predicate predicate-args))
1083    
1084     #+excl
1085     (defun process-block (whostate predicate &rest predicate-args)
1086     (if mp::*scheduler-stack-group*
1087     (apply #'mp::process-wait whostate predicate predicate-args)
1088     (or (apply predicate predicate-args)
1089     (error "Program tried to wait with no scheduler."))))
1090    
1091     #+lcl3.0
1092     (defun process-block (whostate predicate &rest predicate-args)
1093     (declare (dynamic-extent predicate-args))
1094     (apply #'lcl:process-wait whostate predicate predicate-args))
1095    
1096 ram 1.2 #+Minima
1097     (defun process-block (whostate predicate &rest predicate-args)
1098     (declare (type function predicate)
1099     (dynamic-extent predicate))
1100     (apply #'minima:process-wait whostate predicate predicate-args))
1101    
1102 ram 1.1 ;;; PROCESS-WAKEUP: Check some other process' wait function.
1103    
1104     (declaim (inline process-wakeup))
1105    
1106 ram 1.2 #-(or excl Genera Minima)
1107 ram 1.1 (defun process-wakeup (process)
1108     (declare (ignore process))
1109     nil)
1110    
1111     #+excl
1112     (defun process-wakeup (process)
1113     (let ((curproc mp::*current-process*))
1114     (when (and curproc process)
1115     (unless (mp::process-p curproc)
1116     (error "~s is not a process" curproc))
1117     (unless (mp::process-p process)
1118     (error "~s is not a process" process))
1119     (if (> (mp::process-priority process) (mp::process-priority curproc))
1120     (mp::process-allow-schedule process)))))
1121    
1122     #+Genera
1123     (defun process-wakeup (process)
1124     (process:wakeup process))
1125    
1126 ram 1.2 #+Minima
1127     (defun process-wakeup (process)
1128 ram 1.3 (when process
1129     (minima:process-wakeup process)))
1130 ram 1.2
1131 ram 1.1 ;;; CURRENT-PROCESS: Return the current process object for input locking and
1132     ;;; for calling PROCESS-WAKEUP.
1133    
1134     (declaim (inline current-process))
1135    
1136     ;;; Default return NIL, which is acceptable even if there is a scheduler.
1137    
1138 ram 1.2 #-(or lispm excl lcl3.0 Minima)
1139 ram 1.1 (defun current-process ()
1140     nil)
1141    
1142     #+lispm
1143     (defun current-process ()
1144     sys:current-process)
1145    
1146     #+excl
1147     (defun current-process ()
1148     (and mp::*scheduler-stack-group*
1149     mp::*current-process*))
1150    
1151     #+lcl3.0
1152     (defun current-process ()
1153     lcl:*current-process*)
1154    
1155 ram 1.2 #+Minima
1156     (defun current-process ()
1157     (minima:current-process))
1158    
1159 ram 1.1 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
1160    
1161 ram 1.2 #-(or lispm excl lcl3.0 Minima)
1162 ram 1.1 (defmacro without-interrupts (&body body)
1163     `(progn ,@body))
1164    
1165     #+(and lispm (not Genera))
1166     (defmacro without-interrupts (&body body)
1167     `(sys:without-interrupts ,@body))
1168    
1169     #+Genera
1170     (defmacro without-interrupts (&body body)
1171     `(process:with-no-other-processes ,@body))
1172    
1173     #+LCL3.0
1174     (defmacro without-interrupts (&body body)
1175     `(lcl:with-scheduling-inhibited ,@body))
1176    
1177 ram 1.2 #+Minima
1178     (defmacro without-interrupts (&body body)
1179     `(minima:with-no-other-processes ,@body))
1180    
1181 ram 1.1 ;;; CONDITIONAL-STORE:
1182    
1183     ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
1184     ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
1185     (defmacro conditional-store (place old-value new-value)
1186     `(without-interrupts
1187     (cond ((eq ,place ,old-value)
1188     (setf ,place ,new-value)
1189     t))))
1190    
1191     ;;;----------------------------------------------------------------------------
1192     ;;; IO Error Recovery
1193     ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro.
1194     ;;; It prevents multiple mindless errors when the network craters.
1195     ;;;
1196     ;;;----------------------------------------------------------------------------
1197    
1198     #-Genera
1199     (defmacro wrap-buf-output ((buffer) &body body)
1200     ;; Error recovery wrapper
1201     `(unless (buffer-dead ,buffer)
1202     ,@body))
1203    
1204     #+Genera
1205     (defmacro wrap-buf-output ((buffer) &body body)
1206     ;; Error recovery wrapper
1207     `(let ((.buffer. ,buffer))
1208     (unless (buffer-dead .buffer.)
1209     (scl:condition-bind
1210     (((sys:network-error)
1211     #'(lambda (error)
1212     (scl:condition-case ()
1213     (funcall (buffer-close-function .buffer.) .buffer. :abort t)
1214     (sys:network-error))
1215     (setf (buffer-dead .buffer.) error)
1216     (setf (buffer-output-stream .buffer.) nil)
1217     (setf (buffer-input-stream .buffer.) nil)
1218     nil)))
1219     ,@body))))
1220    
1221     #-Genera
1222     (defmacro wrap-buf-input ((buffer) &body body)
1223     (declare (ignore buffer))
1224     ;; Error recovery wrapper
1225     `(progn ,@body))
1226    
1227     #+Genera
1228     (defmacro wrap-buf-input ((buffer) &body body)
1229     ;; Error recovery wrapper
1230     `(let ((.buffer. ,buffer))
1231     (scl:condition-bind
1232     (((sys:network-error)
1233     #'(lambda (error)
1234     (scl:condition-case ()
1235     (funcall (buffer-close-function .buffer.) .buffer. :abort t)
1236     (sys:network-error))
1237     (setf (buffer-dead .buffer.) error)
1238     (setf (buffer-output-stream .buffer.) nil)
1239     (setf (buffer-input-stream .buffer.) nil)
1240     nil)))
1241     ,@body)))
1242    
1243    
1244     ;;;----------------------------------------------------------------------------
1245     ;;; System dependent IO primitives
1246     ;;; Functions for opening, reading writing forcing-output and closing
1247     ;;; the stream to the server.
1248     ;;;----------------------------------------------------------------------------
1249    
1250     ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
1251     ;;; server
1252    
1253 ram 1.3 #-(or explorer Genera lucid kcl ibcl excl Minima CMU)
1254 ram 1.1 (defun open-x-stream (host display protocol)
1255     host display protocol ;; unused
1256     (error "OPEN-X-STREAM not implemented yet."))
1257    
1258     ;;; Genera:
1259    
1260     ;;; TCP and DNA are both layered products, so try to work with either one.
1261    
1262     #+Genera
1263     (when (fboundp 'tcp:add-tcp-port-for-protocol)
1264     (tcp:add-tcp-port-for-protocol :x-window-system 6000))
1265    
1266     #+Genera
1267     (when (fboundp 'dna:add-dna-contact-id-for-protocol)
1268     (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0"))
1269    
1270     #+Genera
1271     (net:define-protocol :x-window-system (:x-window-system :byte-stream)
1272     (:invoke-with-stream ((stream :characters nil :ascii-translation nil))
1273     stream))
1274    
1275     #+Genera
1276     (eval-when (compile)
1277     (compiler:function-defined 'tcp:open-tcp-stream)
1278     (compiler:function-defined 'dna:open-dna-bidirectional-stream))
1279    
1280     #+Genera
1281     (defun open-x-stream (host display protocol)
1282     (let ((host (net:parse-host host)))
1283     (if (or protocol (plusp display))
1284     ;; The protocol was specified or the display isn't 0, so we
1285     ;; can't use the Generic Network System. If the protocol was
1286     ;; specified, then use that protocol, otherwise, blindly use
1287     ;; TCP.
1288     (ccase protocol
1289     ((:tcp nil)
1290     (tcp:open-tcp-stream
1291     host (+ *x-tcp-port* display) nil
1292     :direction :io
1293     :characters nil
1294     :ascii-translation nil))
1295     ((:dna)
1296     (dna:open-dna-bidirectional-stream
1297     host (format nil "X$X~D" display)
1298     :characters nil
1299     :ascii-translation nil)))
1300     (let ((neti:*invoke-service-automatic-retry* t))
1301     (net:invoke-service-on-host :x-window-system host)))))
1302    
1303     #+explorer
1304     (defun open-x-stream (host display protocol)
1305     (declare (ignore protocol))
1306     (net:open-connection-on-medium
1307     (net:parse-host host) ;Host
1308     :byte-stream ;Medium
1309     "X11" ;Logical contact name
1310     :stream-type :character-stream
1311     :direction :bidirectional
1312     :timeout-after-open nil
1313     :remote-port (+ *x-tcp-port* display)))
1314    
1315     #+explorer
1316     (net:define-logical-contact-name
1317     "X11"
1318     `((:local "X11")
1319     (:chaos "X11")
1320     (:nsp-stream "X11")
1321     (:tcp ,*x-tcp-port*)))
1322    
1323     #+lucid
1324     (defun open-x-stream (host display protocol)
1325     protocol ;; unused
1326     (let ((fd (connect-to-server host display)))
1327     (when (minusp fd)
1328     (error "Failed to connect to server: ~A ~D" host display))
1329     (user::make-lisp-stream :input-handle fd
1330     :output-handle fd
1331     :element-type 'unsigned-byte
1332     #-lcl3.0 :stream-type #-lcl3.0 :ephemeral)))
1333    
1334     #+(or kcl ibcl)
1335     (defun open-x-stream (host display protocol)
1336     protocol ;; unused
1337     (let ((stream (open-socket-stream host display)))
1338     (if (streamp stream)
1339     stream
1340     (error "Cannot connect to server: ~A:~D" host display))))
1341    
1342     #+excl
1343     ;;
1344     ;; Note that since we don't use the CL i/o facilities to do i/o, the display
1345     ;; input and output "stream" is really a file descriptor (fixnum).
1346     ;;
1347     (defun open-x-stream (host display protocol)
1348     (declare (ignore protocol));; unused
1349     (let ((fd (connect-to-server (string host) display)))
1350     (when (minusp fd)
1351     (error "Failed to connect to server: ~A ~D" host display))
1352     fd))
1353    
1354 ram 1.2 #+Minima
1355     (defun open-x-stream (host display protocol)
1356     (declare (ignore protocol));; unused
1357 ram 1.3 (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address
1358     (cdr (host-address host)))
1359     :foreign-port (+ *x-tcp-port* display)))
1360 ram 1.2
1361 ram 1.3 ;;; OPEN-X-STREAM -- for CMU Common Lisp.
1362     ;;;
1363     ;;; The file descriptor here just gets tossed into the stream slot of the
1364     ;;; display object instead of a stream.
1365     ;;;
1366 ram 1.3.1.1 #+cmu
1367     (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
1368     c-call:int
1369     (host c-call:c-string)
1370     (port c-call:int))
1371     #+cmu
1372 ram 1.3 (defun open-x-stream (host display protocol)
1373     (declare (ignore protocol))
1374     (let ((server-fd (connect-to-server host display)))
1375     (unless (plusp server-fd)
1376     (error "Failed to connect to X11 server: ~A (display ~D)" host display))
1377     (system:make-fd-stream server-fd :input t :output t
1378     :element-type '(unsigned-byte 8))))
1379    
1380    
1381 ram 1.1 ;;; BUFFER-READ-DEFAULT - read data from the X stream
1382    
1383     #+(or Genera explorer)
1384     (defun buffer-read-default (display vector start end timeout)
1385     ;; returns non-NIL if EOF encountered
1386     ;; Returns :TIMEOUT when timeout exceeded
1387     (declare (type display display)
1388     (type buffer-bytes vector)
1389     (type array-index start end)
1390 ram 1.3 (type (or null (real 0 *)) timeout))
1391 ram 1.1 #.(declare-buffun)
1392     (let ((stream (display-input-stream display)))
1393     (or (cond ((null stream))
1394     ((funcall stream :listen) nil)
1395 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1396 ram 1.1 ((buffer-input-wait-default display timeout)))
1397     (multiple-value-bind (ignore eofp)
1398     (funcall stream :string-in nil vector start end)
1399     eofp))))
1400    
1401    
1402     #+excl
1403     ;;
1404     ;; Rewritten 10/89 to not use foreign function interface to do I/O.
1405     ;;
1406     (defun buffer-read-default (display vector start end timeout)
1407     (declare (type display display)
1408     (type buffer-bytes vector)
1409     (type array-index start end)
1410 ram 1.3 (type (or null (real 0 *)) timeout))
1411 ram 1.1 #.(declare-buffun)
1412    
1413     (let* ((howmany (- end start))
1414     (fd (display-input-stream display)))
1415     (declare (type array-index howmany)
1416     (fixnum fd))
1417     (or (cond ((fd-char-avail-p fd) nil)
1418 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1419 ram 1.1 ((buffer-input-wait-default display timeout)))
1420     (fd-read-bytes fd vector start howmany))))
1421    
1422    
1423     #+lcl3.0
1424 ram 1.2 (defmacro with-underlying-stream ((variable stream display direction) &body body)
1425     `(let ((,variable
1426     (or (getf (display-plist ,display) ',direction)
1427     (setf (getf (display-plist ,display) ',direction)
1428     (lucid::underlying-stream
1429     ,stream ,(if (eq direction 'input) :input :output))))))
1430     ,@body))
1431 ram 1.1
1432     #+lcl3.0
1433     (defun buffer-read-default (display vector start end timeout)
1434     ;;Note that LISTEN must still be done on "slow stream" or the I/O system
1435     ;;gets confused. But reading should be done from "fast stream" for speed.
1436 ram 1.2 ;;We used to inhibit scheduling because there were races in Lucid's
1437 ram 1.1 ;;multitasking system. Empirical evidence suggests they may be gone now.
1438 ram 1.2 ;;Should you decide you need to inhibit scheduling, do it around the
1439     ;;lcl:read-array.
1440 ram 1.1 (declare (type display display)
1441     (type buffer-bytes vector)
1442     (type array-index start end)
1443 ram 1.3 (type (or null (real 0 *)) timeout))
1444 ram 1.2 #.(declare-buffun)
1445 ram 1.1 (let ((stream (display-input-stream display)))
1446     (declare (type (or null stream) stream))
1447     (or (cond ((null stream))
1448     ((listen stream) nil)
1449 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1450 ram 1.1 ((buffer-input-wait-default display timeout)))
1451 ram 1.2 (with-underlying-stream (stream stream display input)
1452     (eq (lcl:read-array stream vector start end nil :eof) :eof)))))
1453 ram 1.1
1454 ram 1.2 #+Minima
1455     (defun buffer-read-default (display vector start end timeout)
1456     ;; returns non-NIL if EOF encountered
1457     ;; Returns :TIMEOUT when timeout exceeded
1458     (declare (type display display)
1459     (type buffer-bytes vector)
1460     (type array-index start end)
1461 ram 1.3 (type (or null (real 0 *)) timeout))
1462 ram 1.2 #.(declare-buffun)
1463     (let ((stream (display-input-stream display)))
1464     (or (cond ((null stream))
1465     ((listen stream) nil)
1466 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1467 ram 1.2 ((buffer-input-wait-default display timeout)))
1468 ram 1.3 (eq :eof (minima:read-vector vector stream nil start end)))))
1469 ram 1.1
1470 ram 1.3 ;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
1471     ;;;
1472     ;;; If timeout is 0, then we call LISTEN to see if there is any input.
1473     ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without
1474     ;;; first calling BUFFER-INPUT-WAIT-DEFAULT.
1475     ;;;
1476     #+CMU
1477     (defun buffer-read-default (display vector start end timeout)
1478     (declare (type display display)
1479     (type buffer-bytes vector)
1480     (type array-index start end)
1481 ram 1.3.1.1 (type (or null fixnum) timeout))
1482 ram 1.3 #.(declare-buffun)
1483 ram 1.3.1.1 (cond ((and (eql timeout 0)
1484 ram 1.3 (not (listen (display-input-stream display))))
1485     :timeout)
1486     (t
1487     (system:read-n-bytes (display-input-stream display)
1488     vector start (- end start))
1489     nil)))
1490    
1491 ram 1.3.1.1
1492 ram 1.1 ;;; WARNING:
1493     ;;; CLX performance will suffer if your lisp uses read-byte for
1494     ;;; receiving all data from the X Window System server.
1495     ;;; You are encouraged to write a specialized version of
1496     ;;; buffer-read-default that does block transfers.
1497 ram 1.3 #-(or Genera explorer excl lcl3.0 Minima CMU)
1498 ram 1.1 (defun buffer-read-default (display vector start end timeout)
1499     (declare (type display display)
1500     (type buffer-bytes vector)
1501     (type array-index start end)
1502 ram 1.3 (type (or null (real 0 *)) timeout))
1503 ram 1.1 #.(declare-buffun)
1504     (let ((stream (display-input-stream display)))
1505     (declare (type (or null stream) stream))
1506     (or (cond ((null stream))
1507     ((listen stream) nil)
1508 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1509 ram 1.1 ((buffer-input-wait-default display timeout)))
1510     (do* ((index start (index1+ index)))
1511     ((index>= index end) nil)
1512     (declare (type array-index index))
1513     (let ((c (read-byte stream nil nil)))
1514     (declare (type (or null card8) c))
1515     (if (null c)
1516     (return t)
1517     (setf (aref vector index) (the card8 c))))))))
1518    
1519     ;;; BUFFER-WRITE-DEFAULT - write data to the X stream
1520    
1521     #+(or Genera explorer)
1522     (defun buffer-write-default (vector display start end)
1523     ;; The default buffer write function for use with common-lisp streams
1524     (declare (type buffer-bytes vector)
1525     (type display display)
1526     (type array-index start end))
1527     #.(declare-buffun)
1528     (let ((stream (display-output-stream display)))
1529     (declare (type (or null stream) stream))
1530     (unless (null stream)
1531     (write-string vector stream :start start :end end))))
1532    
1533     #+excl
1534     (defun buffer-write-default (vector display start end)
1535     (declare (type buffer-bytes vector)
1536     (type display display)
1537     (type array-index start end))
1538     #.(declare-buffun)
1539     (excl::filesys-write-bytes (display-output-stream display) vector start
1540     (- end start)))
1541    
1542     #+lcl3.0
1543     (defun buffer-write-default (vector display start end)
1544 ram 1.2 ;;We used to inhibit scheduling because there were races in Lucid's
1545     ;;multitasking system. Empirical evidence suggests they may be gone now.
1546     ;;Should you decide you need to inhibit scheduling, do it around the
1547     ;;lcl:write-array.
1548 ram 1.1 (declare (type display display)
1549     (type buffer-bytes vector)
1550 ram 1.2 (type array-index start end))
1551     #.(declare-buffun)
1552 ram 1.1 (let ((stream (display-output-stream display)))
1553     (declare (type (or null stream) stream))
1554     (unless (null stream)
1555 ram 1.2 (with-underlying-stream (stream stream display output)
1556     (lcl:write-array stream vector start end)))))
1557 ram 1.1
1558 ram 1.2 #+Minima
1559     (defun buffer-write-default (vector display start end)
1560     ;; The default buffer write function for use with common-lisp streams
1561     (declare (type buffer-bytes vector)
1562     (type display display)
1563     (type array-index start end))
1564     #.(declare-buffun)
1565     (let ((stream (display-output-stream display)))
1566     (declare (type (or null stream) stream))
1567     (unless (null stream)
1568 ram 1.3 (minima:write-vector vector stream start end))))
1569 ram 1.2
1570 ram 1.3 #+CMU
1571     (defun buffer-write-default (vector display start end)
1572     (declare (type buffer-bytes vector)
1573     (type display display)
1574     (type array-index start end))
1575     #.(declare-buffun)
1576     (system:output-raw-bytes (display-output-stream display) vector start end)
1577     nil)
1578    
1579 ram 1.1 ;;; WARNING:
1580     ;;; CLX performance will be severely degraded if your lisp uses
1581     ;;; write-byte to send all data to the X Window System server.
1582     ;;; You are STRONGLY encouraged to write a specialized version
1583     ;;; of buffer-write-default that does block transfers.
1584    
1585 ram 1.3 #-(or Genera explorer excl lcl3.0 Minima CMU)
1586 ram 1.1 (defun buffer-write-default (vector display start end)
1587     ;; The default buffer write function for use with common-lisp streams
1588     (declare (type buffer-bytes vector)
1589     (type display display)
1590     (type array-index start end))
1591     #.(declare-buffun)
1592     (let ((stream (display-output-stream display)))
1593     (declare (type (or null stream) stream))
1594     (unless (null stream)
1595     (with-vector (vector buffer-bytes)
1596     (do ((index start (index1+ index)))
1597     ((index>= index end))
1598     (declare (type array-index index))
1599     (write-byte (aref vector index) stream))))))
1600    
1601 ram 1.3.1.1 #+CMU
1602     (defun buffer-write-default (vector display start end)
1603     (declare (type buffer-bytes vector)
1604     (type display display)
1605     (type array-index start end))
1606     #.(declare-buffun)
1607     (system:output-raw-bytes (display-output-stream display) vector start end)
1608     nil)
1609    
1610 ram 1.1 ;;; buffer-force-output-default - force output to the X stream
1611    
1612     #+excl
1613     (defun buffer-force-output-default (display)
1614     ;; buffer-write-default does the actual writing.
1615     (declare (ignore display)))
1616    
1617 ram 1.3.1.1 #-(or excl)
1618 ram 1.1 (defun buffer-force-output-default (display)
1619     ;; The default buffer force-output function for use with common-lisp streams
1620     (declare (type display display))
1621     (let ((stream (display-output-stream display)))
1622     (declare (type (or null stream) stream))
1623     (unless (null stream)
1624     (force-output stream))))
1625    
1626     ;;; BUFFER-CLOSE-DEFAULT - close the X stream
1627    
1628     #+excl
1629     (defun buffer-close-default (display &key abort)
1630     ;; The default buffer close function for use with common-lisp streams
1631     (declare (type display display)
1632     (ignore abort))
1633     #.(declare-buffun)
1634     (excl::filesys-checking-close (display-output-stream display)))
1635    
1636 ram 1.3.1.1 #-(or excl)
1637 ram 1.1 (defun buffer-close-default (display &key abort)
1638     ;; The default buffer close function for use with common-lisp streams
1639     (declare (type display display))
1640     #.(declare-buffun)
1641     (let ((stream (display-output-stream display)))
1642     (declare (type (or null stream) stream))
1643     (unless (null stream)
1644     (close stream :abort abort))))
1645    
1646     ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
1647     ;;; buffer. This is called in read-input between requests, so that a process
1648     ;;; waiting for input is abortable when between requests. Should return
1649     ;;; :TIMEOUT if it times out, NIL otherwise.
1650    
1651     ;;; The default implementation
1652    
1653     ;; Poll for input every *buffer-read-polling-time* SECONDS.
1654 ram 1.3 #-(or Genera explorer excl lcl3.0 CMU)
1655 ram 1.1 (defparameter *buffer-read-polling-time* 0.5)
1656    
1657 ram 1.3 #-(or Genera explorer excl lcl3.0 CMU)
1658 ram 1.1 (defun buffer-input-wait-default (display timeout)
1659     (declare (type display display)
1660 ram 1.3 (type (or null (real 0 *)) timeout))
1661     (declare (clx-values timeout))
1662 ram 1.1
1663     (let ((stream (display-input-stream display)))
1664     (declare (type (or null stream) stream))
1665     (cond ((null stream))
1666     ((listen stream) nil)
1667 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1668 ram 1.1 ((not (null timeout))
1669     (multiple-value-bind (npoll fraction)
1670     (truncate timeout *buffer-read-polling-time*)
1671     (dotimes (i npoll) ; Sleep for a time, then listen again
1672     (sleep *buffer-read-polling-time*)
1673     (when (listen stream)
1674     (return-from buffer-input-wait-default nil)))
1675     (when (plusp fraction)
1676     (sleep fraction) ; Sleep a fraction of a second
1677     (when (listen stream) ; and listen one last time
1678     (return-from buffer-input-wait-default nil)))
1679     :timeout)))))
1680    
1681 ram 1.3 #+CMU
1682     (defun buffer-input-wait-default (display timeout)
1683     (declare (type display display)
1684 ram 1.3.1.1 (type (or null number) timeout))
1685 ram 1.3 (let ((stream (display-input-stream display)))
1686     (declare (type (or null stream) stream))
1687     (cond ((null stream))
1688     ((listen stream) nil)
1689 ram 1.3.1.1 ((eql timeout 0) :timeout)
1690 ram 1.3 (t
1691     (if (system:wait-until-fd-usable (system:fd-stream-fd stream)
1692     :input timeout)
1693     nil
1694     :timeout)))))
1695    
1696 ram 1.1 #+Genera
1697     (defun buffer-input-wait-default (display timeout)
1698     (declare (type display display)
1699 ram 1.3 (type (or null (real 0 *)) timeout))
1700     (declare (clx-values timeout))
1701 ram 1.1 (let ((stream (display-input-stream display)))
1702     (declare (type (or null stream) stream))
1703     (cond ((null stream))
1704     ((scl:send stream :listen) nil)
1705 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1706 ram 1.1 ((null timeout) (si:stream-input-block stream "CLX Input"))
1707     (t
1708     (scl:condition-bind ((neti:protocol-timeout
1709     #'(lambda (error)
1710     (when (eq stream (scl:send error :stream))
1711     (return-from buffer-input-wait-default :timeout)))))
1712     (neti:with-stream-timeout (stream :input timeout)
1713     (si:stream-input-block stream "CLX Input")))))
1714     nil))
1715    
1716     #+explorer
1717     (defun buffer-input-wait-default (display timeout)
1718     (declare (type display display)
1719 ram 1.3 (type (or null (real 0 *)) timeout))
1720     (declare (clx-values timeout))
1721 ram 1.1 (let ((stream (display-input-stream display)))
1722     (declare (type (or null stream) stream))
1723     (cond ((null stream))
1724     ((zl:send stream :listen) nil)
1725 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1726 ram 1.1 ((null timeout)
1727     (si:process-wait "CLX Input" stream :listen))
1728     (t
1729     (unless (si:process-wait-with-timeout
1730     "CLX Input" (round (* timeout 60.)) stream :listen)
1731     (return-from buffer-input-wait-default :timeout))))
1732     nil))
1733    
1734     #+excl
1735     ;;
1736     ;; This is used so an 'eq' test may be used to find out whether or not we can
1737     ;; safely throw this process out of the CLX read loop.
1738     ;;
1739 ram 1.2 (defparameter *read-whostate* "waiting for input from X server")
1740 ram 1.1
1741     ;;
1742     ;; Note that this function returns nil on error if the scheduler is running,
1743     ;; t on error if not. This is ok since buffer-read will detect the error.
1744     ;;
1745     #+excl
1746     (defun buffer-input-wait-default (display timeout)
1747     (declare (type display display)
1748 ram 1.3 (type (or null (real 0 *)) timeout))
1749     (declare (clx-values timeout))
1750 ram 1.1 (let ((fd (display-input-stream display)))
1751     (declare (fixnum fd))
1752     (when (>= fd 0)
1753     (cond ((fd-char-avail-p fd)
1754     nil)
1755    
1756     ;; Otherwise no bytes were available on the socket
1757 ram 1.3 ((and timeout (= timeout 0))
1758 ram 1.1 ;; If there aren't enough and timeout == 0, timeout.
1759     :timeout)
1760    
1761     ;; If the scheduler is running let it do timeouts.
1762     (mp::*scheduler-stack-group*
1763     #+allegro
1764     (if (not
1765     (mp:wait-for-input-available fd :whostate *read-whostate*
1766     :wait-function #'fd-char-avail-p
1767     :timeout timeout))
1768     (return-from buffer-input-wait-default :timeout))
1769     #-allegro
1770     (mp::wait-for-input-available fd :whostate *read-whostate*
1771     :wait-function #'fd-char-avail-p))
1772    
1773     ;; Otherwise we have to handle timeouts by hand, and call select()
1774     ;; to block until input is available. Note we don't really handle
1775     ;; the interaction of interrupts and (numberp timeout) here. XX
1776     (t
1777     (let ((res 0))
1778     (declare (fixnum res))
1779     (with-interrupt-checking-on
1780     (loop
1781     (setq res (fd-wait-for-input fd (if (null timeout) 0
1782     (truncate timeout))))
1783     (cond ((plusp res) ; success
1784     (return nil))
1785     ((eq res 0) ; timeout
1786     (return :timeout))
1787     ((eq res -1) ; error
1788     (return t))
1789     ;; Otherwise we got an interrupt -- go around again.
1790     )))))))))
1791    
1792    
1793     #+lcl3.0
1794     (defun buffer-input-wait-default (display timeout)
1795     (declare (type display display)
1796 ram 1.3 (type (or null (real 0 *)) timeout)
1797     (clx-values timeout))
1798 ram 1.2 #.(declare-buffun)
1799 ram 1.1 (let ((stream (display-input-stream display)))
1800     (declare (type (or null stream) stream))
1801     (cond ((null stream))
1802     ((listen stream) nil)
1803 ram 1.3 ((and timeout (= timeout 0)) :timeout)
1804 ram 1.2 ((with-underlying-stream (stream stream display input)
1805 ram 1.1 (lucid::waiting-for-input-from-stream stream
1806     (lucid::with-io-unlocked
1807     (if (null timeout)
1808     (lcl:process-wait "CLX Input" #'listen stream)
1809     (lcl:process-wait-with-timeout
1810     "CLX Input" timeout #'listen stream)))))
1811     nil)
1812     (:timeout))))
1813    
1814    
1815     ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
1816     ;;; buffer. This should never block, so it can be called from the scheduler.
1817    
1818     ;;; The default implementation is to just use listen.
1819 ram 1.3.1.1 #-(or excl)
1820 ram 1.1 (defun buffer-listen-default (display)
1821     (declare (type display display))
1822     (let ((stream (display-input-stream display)))
1823     (declare (type (or null stream) stream))
1824     (if (null stream)
1825     t
1826     (listen stream))))
1827    
1828     #+excl
1829     (defun buffer-listen-default (display)
1830     (declare (type display display))
1831     (let ((fd (display-input-stream display)))
1832     (declare (type fixnum fd))
1833     (if (= fd -1)
1834     t
1835     (fd-char-avail-p fd))))
1836    
1837    
1838     ;;;----------------------------------------------------------------------------
1839     ;;; System dependent speed hacks
1840     ;;;----------------------------------------------------------------------------
1841    
1842     ;;
1843     ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
1844     ;; If your lisp doesn't have stack-lists, and you're worried about
1845     ;; consing garbage, you may want to re-write this to allocate and
1846     ;; initialize lists from a resource.
1847     ;;
1848     #-lispm
1849     (defmacro with-stack-list ((var &rest elements) &body body)
1850     ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
1851     ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
1852     ;; except that the list produced by MAPCAR resides on the stack and
1853     ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
1854 ram 1.2 `(let ((,var (list ,@elements)))
1855     (declare (type cons ,var)
1856     #+clx-ansi-common-lisp (dynamic-extent ,var))
1857     ,@body))
1858 ram 1.1
1859     #-lispm
1860     (defmacro with-stack-list* ((var &rest elements) &body body)
1861     ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
1862     ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
1863     ;; except that the list produced by MAPCAR resides on the stack and
1864     ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
1865 ram 1.2 `(let ((,var (list* ,@elements)))
1866     (declare (type cons ,var)
1867     #+clx-ansi-common-lisp (dynamic-extent ,var))
1868     ,@body))
1869 ram 1.1
1870     (declaim (inline buffer-replace))
1871    
1872     #+lispm
1873     (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1874     (declare (type vector buf1 buf2)
1875     (type array-index start1 end1 start2))
1876     (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))
1877    
1878     #+excl
1879     (defun buffer-replace (target-sequence source-sequence target-start
1880     target-end &optional (source-start 0))
1881     (declare (type buffer-bytes target-sequence source-sequence)
1882     (type array-index target-start target-end source-start)
1883     (optimize (speed 3) (safety 0)))
1884    
1885     (let ((source-end (length source-sequence)))
1886     (declare (type array-index source-end))
1887    
1888 ram 1.2 (excl:if* (and (eq target-sequence source-sequence)
1889     (> target-start source-start))
1890 ram 1.1 then (let ((nelts (min (- target-end target-start)
1891     (- source-end source-start))))
1892     (do ((target-index (+ target-start nelts -1) (1- target-index))
1893     (source-index (+ source-start nelts -1) (1- source-index)))
1894     ((= target-index (1- target-start)) target-sequence)
1895     (declare (type array-index target-index source-index))
1896    
1897     (setf (aref target-sequence target-index)
1898     (aref source-sequence source-index))))
1899     else (do ((target-index target-start (1+ target-index))
1900     (source-index source-start (1+ source-index)))
1901     ((or (= target-index target-end) (= source-index source-end))
1902     target-sequence)
1903     (declare (type array-index target-index source-index))
1904    
1905     (setf (aref target-sequence target-index)
1906     (aref source-sequence source-index))))))
1907    
1908 ram 1.3 #+cmu
1909     (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1910     (declare (type buffer-bytes buf1 buf2)
1911     (type array-index start1 end1 start2))
1912     #.(declare-buffun)
1913     (kernel:bit-bash-copy
1914     buf2 (+ (* start2 vm:byte-bits)
1915     (* vm:vector-data-offset vm:word-bits))
1916     buf1 (+ (* start1 vm:byte-bits)
1917     (* vm:vector-data-offset vm:word-bits))
1918     (* (- end1 start1) vm:byte-bits)))
1919    
1920 ram 1.1 #+lucid
1921     ;;;The compiler is *supposed* to optimize calls to replace, but in actual
1922     ;;;fact it does not.
1923     (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1924     (declare (type buffer-bytes buf1 buf2)
1925     (type array-index start1 end1 start2))
1926     #.(declare-buffun)
1927     (let ((end2 (lucid::%simple-8bit-vector-length buf2)))
1928     (declare (type array-index end2))
1929     (lucid::simple-8bit-vector-replace-internal
1930     buf1 buf2 start1 end1 start2 end2)))
1931    
1932     #+(and clx-overlapping-arrays (not (or lispm excl)))
1933     (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1934     (declare (type vector buf1 buf2)
1935     (type array-index start1 end1 start2))
1936     (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
1937    
1938 ram 1.3 #-(or lispm lucid excl CMU clx-overlapping-arrays)
1939 ram 1.1 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1940     (declare (type buffer-bytes buf1 buf2)
1941     (type array-index start1 end1 start2))
1942     (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
1943    
1944     #+ti
1945     (defun with-location-bindings (sys:&quote bindings &rest body)
1946     (do ((bindings bindings (cdr bindings)))
1947     ((null bindings)
1948     (sys:eval-body-as-progn body))
1949     (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))
1950     (sys:*eval (cadar bindings)))))
1951    
1952     #+ti
1953     (compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)
1954     (let ((bindings (cadr form))
1955     (body (cddr form)))
1956     `(let ()
1957     ,@(loop for (accessor value) in bindings
1958     collect `(si:bind (si:locf ,accessor) ,value))
1959     ,@body)))
1960    
1961     #+ti
1962     (defun (:property with-location-bindings compiler::cw-handler) (exp)
1963     (let* ((bindlist (mapcar #'compiler::cw-clause (second exp)))
1964     (body (compiler::cw-clause (cddr exp))))
1965     (and compiler::cw-return-expansion-flag
1966     (list* (first exp) bindlist body))))
1967    
1968     #+(and lispm (not ti))
1969     (defmacro with-location-bindings (bindings &body body)
1970     `(sys:letf* ,bindings ,@body))
1971    
1972     #+lispm
1973     (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
1974     &body body)
1975     ;; don't use svref on LHS because Symbolics didn't define locf for it
1976     (let* ((local-state (gensym))
1977     (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway
1978     (dolist (index indexes)
1979     (push `((aref ,local-state ,index) (svref ,saved-state ,index))
1980     bindings))
1981     `(let ((,local-state (gcontext-local-state ,gc)))
1982     (declare (type gcontext-state ,local-state))
1983     (unwind-protect
1984     (with-location-bindings ,bindings
1985     ,@body)
1986     (setf (svref ,local-state ,ts-index) 0)
1987     (when ,temp-gc
1988     (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
1989     (deallocate-gcontext-state ,saved-state)))))
1990    
1991     #-lispm
1992     (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
1993     &body body)
1994     (let ((local-state (gensym))
1995     (resets nil))
1996     (dolist (index indexes)
1997     (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
1998     resets))
1999     `(unwind-protect
2000     (progn
2001     ,@body)
2002     (let ((,local-state (gcontext-local-state ,gc)))
2003     (declare (type gcontext-state ,local-state))
2004     ,@resets
2005     (setf (svref ,local-state ,ts-index) 0))
2006     (when ,temp-gc
2007     (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))