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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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