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