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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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