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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.4 - (hide annotations) (vendor branch)
Fri May 17 15:54:33 1991 UTC (22 years, 11 months ago) by ram
Changes since 1.1.1.3: +21 -7 lines
.../systems-work/clx/dependent.lisp, 24-May-90 16:00:24, Edit by Chiles.
  Wrote CALL-UNIX-SELECT to avoid problems with MACH:UNIX-SELECT returning nil
  when someone interrupts the system since calls to MACH:UNIX-SELECT occur
  within a WITHOUT-INTERRUPTS.

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