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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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