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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Aug 11 15:15:55 1992 UTC (21 years, 8 months ago) by ram
Branch: MAIN
Branch point for: cmu
Changes since 1.2: +377 -160 lines
This is CLX R5.01
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 ;;; The size of the output buffer. Must be a multiple of 4.
24 (defparameter *output-buffer-size* 8192)
25
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* #+clx-debugging 1 #-clx-debugging 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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 #-(or Genera lcl3.0 excl)
157 (progn
158
159 (defun aref-card8 (a i)
160 (declare (type buffer-bytes a)
161 (type array-index i))
162 (declare (clx-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 (clx-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 #+(or excl lcl3.0 clx-overlapping-arrays)
207 (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 (defun aref-card8 (a i)
286 (declare (type buffer-bytes a)
287 (type array-index i))
288 (declare (clx-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 (clx-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 (clx-values card16))
321 #.(declare-buffun)
322 (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
323 :unsigned-word)))
324
325 (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
333 (defun aref-int16 (a i)
334 (declare (type buffer-bytes a)
335 (type array-index i))
336 (declare (clx-values int16))
337 #.(declare-buffun)
338 (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
339 :signed-word)))
340
341 (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
349 (defun aref-card32 (a i)
350 (declare (type buffer-bytes a)
351 (type array-index i))
352 (declare (clx-values card32))
353 #.(declare-buffun)
354 (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
355 :unsigned-long)))
356
357 (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
365 (defun aref-int32 (a i)
366 (declare (type buffer-bytes a)
367 (type array-index i))
368 (declare (clx-values int32))
369 #.(declare-buffun)
370 (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
371 :signed-long)))
372
373 (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
381 (defun aref-card29 (a i)
382 (declare (type buffer-bytes a)
383 (type array-index i))
384 (declare (clx-values card29))
385 #.(declare-buffun)
386 (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
387 :unsigned-long)))
388
389 (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
397 )
398
399 #+lcl3.0
400 (progn
401
402 (defun aref-card8 (a i)
403 (declare (type buffer-bytes a)
404 (type array-index i)
405 (clx-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 (clx-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 (defun aref-card16 (a i)
431 (declare (type buffer-bytes a)
432 (type array-index i)
433 (clx-values card16))
434 #.(declare-buffun)
435 (the card16 (lucid::%svref-16bit a (index-ash i -1))))
436
437 (defun aset-card16 (v a i)
438 (declare (type card16 v)
439 (type buffer-bytes a)
440 (type array-index i))
441 #.(declare-buffun)
442 (setf (lucid::%svref-16bit a (index-ash i -1)) v))
443
444 (defun aref-int16 (a i)
445 (declare (type buffer-bytes a)
446 (type array-index i)
447 (clx-values int16))
448 #.(declare-buffun)
449 (the int16 (lucid::%svref-signed-16bit a (index-ash i -1))))
450
451 (defun aset-int16 (v a i)
452 (declare (type int16 v)
453 (type buffer-bytes a)
454 (type array-index i))
455 #.(declare-buffun)
456 (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v))
457
458 (defun aref-card32 (a i)
459 (declare (type buffer-bytes a)
460 (type array-index i)
461 (clx-values card32))
462 #.(declare-buffun)
463 (the card32 (lucid::%svref-32bit a (index-ash i -2))))
464
465 (defun aset-card32 (v a i)
466 (declare (type card32 v)
467 (type buffer-bytes a)
468 (type array-index i))
469 #.(declare-buffun)
470 (setf (lucid::%svref-32bit a (index-ash i -2)) v))
471
472 (defun aref-int32 (a i)
473 (declare (type buffer-bytes a)
474 (type array-index i)
475 (clx-values int32))
476 #.(declare-buffun)
477 (the int32 (lucid::%svref-signed-32bit a (index-ash i -2))))
478
479 (defun aset-int32 (v a i)
480 (declare (type int32 v)
481 (type buffer-bytes a)
482 (type array-index i))
483 #.(declare-buffun)
484 (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v))
485
486 (defun aref-card29 (a i)
487 (declare (type buffer-bytes a)
488 (type array-index i)
489 (clx-values card29))
490 #.(declare-buffun)
491 (the card29 (lucid::%svref-32bit a (index-ash i -2))))
492
493 (defun aset-card29 (v a i)
494 (declare (type card29 v)
495 (type buffer-bytes a)
496 (type array-index i))
497 #.(declare-buffun)
498 (setf (lucid::%svref-32bit a (index-ash i -2)) v))
499
500 )
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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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-array 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 (declare (type base-char char))
774 #.(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 (the base-char
782 (or (aref (the simple-vector *card8-to-char-translation-table*)
783 card8)
784 (error "Invalid CHAR code ~D." card8))))
785 )
786 #+Genera
787 (progn
788 (defun char->card8 (char)
789 (declare lt:(side-effects reader reducible))
790 (aref *char-to-card8-translation-table* (char-code char)))
791 (defun card8->char (card8)
792 (declare lt:(side-effects reader reducible))
793 (aref *card8-to-char-translation-table* card8))
794 )
795 #-Minima
796 (dotimes (i 256)
797 (unless (= i (char->card8 (card8->char i)))
798 (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S"
799 (list i
800 (card8->char i)
801 (char->card8 (card8->char i))))
802 (return nil)))
803 #-Minima
804 (dotimes (i (length *char-to-card8-translation-table*))
805 (let ((char (code-char i)))
806 (unless (eql char (card8->char (char->card8 char)))
807 (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S"
808 (list char
809 (char->card8 char)
810 (card8->char (char->card8 char))))
811 (return nil))))))
812 (t
813 `(progn
814 (defun char->card8 (char)
815 (declare (type base-char char))
816 #.(declare-buffun)
817 (the card8 (char-code char)))
818 (defun card8->char (card8)
819 (declare (type card8 card8))
820 #.(declare-buffun)
821 (the base-char (code-char card8)))
822 ))))))
823 (char-translators))
824
825 ;;-----------------------------------------------------------------------------
826 ;; Process Locking
827 ;;
828 ;; Common-Lisp doesn't provide process locking primitives, so we define
829 ;; our own here, based on Zetalisp primitives. Holding-Lock is very
830 ;; similar to with-lock on The TI Explorer, and a little more efficient
831 ;; than with-process-lock on a Symbolics.
832 ;;-----------------------------------------------------------------------------
833
834 ;;; MAKE-PROCESS-LOCK: Creating a process lock.
835
836 #-(or LispM excl Minima)
837 (defun make-process-lock (name)
838 (declare (ignore name))
839 nil)
840
841 #+excl
842 (defun make-process-lock (name)
843 (mp:make-process-lock :name name))
844
845 #+(and LispM (not Genera))
846 (defun make-process-lock (name)
847 (vector nil name))
848
849 #+Genera
850 (defun make-process-lock (name)
851 (process:make-lock name :flavor 'clx-lock))
852
853 #+Minima
854 (defun make-process-lock (name)
855 (minima:make-lock name :recursive t))
856
857 ;;; HOLDING-LOCK: Execute a body of code with a lock held.
858
859 ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN
860 ;;; passes its timeout to the holding-lock macro, so any timeout you want to
861 ;;; work for event-listen you should do for holding-lock.
862
863 ;; If you're not sharing DISPLAY objects within a multi-processing
864 ;; shared-memory environment, this is sufficient
865 #-(or lispm excl lcl3.0 Minima CMU)
866 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
867 (declare (ignore locator display whostate timeout))
868 `(progn ,@body))
869
870 ;;; HOLDING-LOCK for CMU Common Lisp.
871 ;;;
872 ;;; We are not multi-processing, but we use this macro to try to protect
873 ;;; against re-entering request functions. This can happen if an interrupt
874 ;;; occurs and the handler attempts to use X over the same display connection.
875 ;;; This can happen if the GC hooks are used to notify the user over the same
876 ;;; display connection. We lock out GC's just as a dummy check for our users.
877 ;;; Locking out interrupts has the problem that CLX always waits for replies
878 ;;; within this dynamic scope, so if the server cannot reply for some reason,
879 ;;; we potentially dead-lock without interrupts.
880 ;;;
881 #+CMU
882 (defmacro holding-lock ((locator display &optional whostate &key timeout)
883 &body body)
884 (declare (ignore locator display whostate timeout))
885 `(lisp::without-gcing (system:without-interrupts (progn ,@body))))
886
887 #+Genera
888 (defmacro holding-lock ((locator display &optional whostate &key timeout)
889 &body body)
890 (declare (ignore whostate))
891 `(process:with-lock (,locator :timeout ,timeout)
892 (let ((.debug-io. (buffer-debug-io ,display)))
893 (scl:let-if .debug-io. ((*debug-io* .debug-io.))
894 ,@body))))
895
896 #+(and lispm (not Genera))
897 (defmacro holding-lock ((locator display &optional whostate &key timeout)
898 &body body)
899 (declare (ignore display))
900 ;; This macro is for use in a multi-process environment.
901 (let ((lock (gensym))
902 (have-lock (gensym))
903 (timeo (gensym)))
904 `(let* ((,lock (zl:locf (svref ,locator 0)))
905 (,have-lock (eq (car ,lock) sys:current-process))
906 (,timeo ,timeout))
907 (unwind-protect
908 (when (cond (,have-lock)
909 ((#+explorer si:%store-conditional
910 #-explorer sys:store-conditional
911 ,lock nil sys:current-process))
912 ((null ,timeo)
913 (sys:process-lock ,lock nil ,(or whostate "CLX Lock")))
914 ((sys:process-wait-with-timeout
915 ,(or whostate "CLX Lock") (round (* ,timeo 60.))
916 #'(lambda (lock process)
917 (#+explorer si:%store-conditional
918 #-explorer sys:store-conditional
919 lock nil process))
920 ,lock sys:current-process)))
921 ,@body)
922 (unless ,have-lock
923 (#+explorer si:%store-conditional
924 #-explorer sys:store-conditional
925 ,lock sys:current-process nil))))))
926
927 ;; Lucid has a process locking mechanism as well under release 3.0
928 #+lcl3.0
929 (defmacro holding-lock ((locator display &optional whostate &key timeout)
930 &body body)
931 (declare (ignore display))
932 (if timeout
933 ;; Hair to support timeout.
934 `(let ((.have-lock. (eq ,locator lcl:*current-process*))
935 (.timeout. ,timeout))
936 (unwind-protect
937 (when (cond (.have-lock.)
938 ((conditional-store ,locator nil lcl:*current-process*))
939 ((null .timeout.)
940 (lcl:process-lock ,locator)
941 t)
942 ((lcl:process-wait-with-timeout ,whostate .timeout.
943 #'(lambda ()
944 (conditional-store ,locator nil lcl:*current-process*))))
945 ;; abort the PROCESS-UNLOCK if actually timing out
946 (t
947 (setf .have-lock. :abort)
948 nil))
949 ,@body)
950 (unless .have-lock.
951 (lcl:process-unlock ,locator))))
952 `(lcl:with-process-lock (,locator)
953 ,@body)))
954
955
956 #+excl
957 (defmacro holding-lock ((locator display &optional whostate &key timeout)
958 &body body)
959 (declare (ignore display))
960 `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)
961 (unwind-protect
962 (block .hl-doit.
963 (when mp::*scheduler-stack-group* ; fast test for scheduler running
964 (setq .hl-lock. ,locator
965 .hl-curproc. mp::*current-process*)
966 (when (and .hl-curproc. ; nil if in process-wait fun
967 (not (eq (mp::process-lock-locker .hl-lock.)
968 .hl-curproc.)))
969 ;; Then we need to grab the lock.
970 ,(if timeout
971 `(if (not (mp::process-lock .hl-lock. .hl-curproc.
972 ,whostate ,timeout))
973 (return-from .hl-doit. nil))
974 `(mp::process-lock .hl-lock. .hl-curproc.
975 ,@(when whostate `(,whostate))))
976 ;; There is an apparent race condition here. However, there is
977 ;; no actual race condition -- our implementation of mp:process-
978 ;; lock guarantees that the lock will still be held when it
979 ;; returns, and no interrupt can happen between that and the
980 ;; execution of the next form. -- jdi 2/27/91
981 (setq .hl-obtained-lock. t)))
982 ,@body)
983 (if (and .hl-obtained-lock.
984 ;; Note -- next form added to allow error handler inside
985 ;; body to unlock the lock prematurely if it knows that
986 ;; the current process cannot possibly continue but will
987 ;; throw out (or is it throw up?).
988 (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))
989 (mp::process-unlock .hl-lock. .hl-curproc.)))))
990
991 #+Minima
992 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
993 `(holding-lock-1 #'(lambda () ,@body) ,locator ,display
994 ,@(and whostate `(:whostate ,whostate))
995 ,@(and timeout `(:timeout ,timeout))))
996
997 #+Minima
998 (defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout)
999 (declare (dynamic-extent continuation))
1000 (declare (ignore display whostate timeout))
1001 (minima:with-lock (lock)
1002 (funcall continuation)))
1003
1004 ;;; WITHOUT-ABORTS
1005
1006 ;;; If you can inhibit asynchronous keyboard aborts inside the body of this
1007 ;;; macro, then it is a good idea to do this. This macro is wrapped around
1008 ;;; request writing and reply reading to ensure that requests are atomically
1009 ;;; written and replies are atomically read from the stream.
1010
1011 #-(or Genera excl lcl3.0)
1012 (defmacro without-aborts (&body body)
1013 `(progn ,@body))
1014
1015 #+Genera
1016 (defmacro without-aborts (&body body)
1017 `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.")
1018 ,@body))
1019
1020 #+excl
1021 (defmacro without-aborts (&body body)
1022 `(without-interrupts ,@body))
1023
1024 #+lcl3.0
1025 (defmacro without-aborts (&body body)
1026 `(lcl:with-interruptions-inhibited ,@body))
1027
1028 ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
1029 ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
1030 ;;; value changes.
1031
1032 #-(or lispm excl lcl3.0 Minima)
1033 (defun process-block (whostate predicate &rest predicate-args)
1034 (declare (ignore whostate))
1035 (or (apply predicate predicate-args)
1036 (error "Program tried to wait with no scheduler.")))
1037
1038 #+Genera
1039 (defun process-block (whostate predicate &rest predicate-args)
1040 (declare (type function predicate)
1041 #+clx-ansi-common-lisp
1042 (dynamic-extent predicate)
1043 #-clx-ansi-common-lisp
1044 (sys:downward-funarg predicate))
1045 (apply #'process:block-process whostate predicate predicate-args))
1046
1047 #+(and lispm (not Genera))
1048 (defun process-block (whostate predicate &rest predicate-args)
1049 (declare (type function predicate)
1050 #+clx-ansi-common-lisp
1051 (dynamic-extent predicate)
1052 #-clx-ansi-common-lisp
1053 (sys:downward-funarg predicate))
1054 (apply #'global:process-wait whostate predicate predicate-args))
1055
1056 #+excl
1057 (defun process-block (whostate predicate &rest predicate-args)
1058 (if mp::*scheduler-stack-group*
1059 (apply #'mp::process-wait whostate predicate predicate-args)
1060 (or (apply predicate predicate-args)
1061 (error "Program tried to wait with no scheduler."))))
1062
1063 #+lcl3.0
1064 (defun process-block (whostate predicate &rest predicate-args)
1065 (declare (dynamic-extent predicate-args))
1066 (apply #'lcl:process-wait whostate predicate predicate-args))
1067
1068 #+Minima
1069 (defun process-block (whostate predicate &rest predicate-args)
1070 (declare (type function predicate)
1071 (dynamic-extent predicate))
1072 (apply #'minima:process-wait whostate predicate predicate-args))
1073
1074 ;;; PROCESS-WAKEUP: Check some other process' wait function.
1075
1076 (declaim (inline process-wakeup))
1077
1078 #-(or excl Genera Minima)
1079 (defun process-wakeup (process)
1080 (declare (ignore process))
1081 nil)
1082
1083 #+excl
1084 (defun process-wakeup (process)
1085 (let ((curproc mp::*current-process*))
1086 (when (and curproc process)
1087 (unless (mp::process-p curproc)
1088 (error "~s is not a process" curproc))
1089 (unless (mp::process-p process)
1090 (error "~s is not a process" process))
1091 (if (> (mp::process-priority process) (mp::process-priority curproc))
1092 (mp::process-allow-schedule process)))))
1093
1094 #+Genera
1095 (defun process-wakeup (process)
1096 (process:wakeup process))
1097
1098 #+Minima
1099 (defun process-wakeup (process)
1100 (when process
1101 (minima:process-wakeup process)))
1102
1103 ;;; CURRENT-PROCESS: Return the current process object for input locking and
1104 ;;; for calling PROCESS-WAKEUP.
1105
1106 (declaim (inline current-process))
1107
1108 ;;; Default return NIL, which is acceptable even if there is a scheduler.
1109
1110 #-(or lispm excl lcl3.0 Minima)
1111 (defun current-process ()
1112 nil)
1113
1114 #+lispm
1115 (defun current-process ()
1116 sys:current-process)
1117
1118 #+excl
1119 (defun current-process ()
1120 (and mp::*scheduler-stack-group*
1121 mp::*current-process*))
1122
1123 #+lcl3.0
1124 (defun current-process ()
1125 lcl:*current-process*)
1126
1127 #+Minima
1128 (defun current-process ()
1129 (minima:current-process))
1130
1131 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
1132
1133 #-(or lispm excl lcl3.0 Minima)
1134 (defmacro without-interrupts (&body body)
1135 `(progn ,@body))
1136
1137 #+(and lispm (not Genera))
1138 (defmacro without-interrupts (&body body)
1139 `(sys:without-interrupts ,@body))
1140
1141 #+Genera
1142 (defmacro without-interrupts (&body body)
1143 `(process:with-no-other-processes ,@body))
1144
1145 #+LCL3.0
1146 (defmacro without-interrupts (&body body)
1147 `(lcl:with-scheduling-inhibited ,@body))
1148
1149 #+Minima
1150 (defmacro without-interrupts (&body body)
1151 `(minima:with-no-other-processes ,@body))
1152
1153 ;;; CONDITIONAL-STORE:
1154
1155 ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
1156 ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
1157 (defmacro conditional-store (place old-value new-value)
1158 `(without-interrupts
1159 (cond ((eq ,place ,old-value)
1160 (setf ,place ,new-value)
1161 t))))
1162
1163 ;;;----------------------------------------------------------------------------
1164 ;;; IO Error Recovery
1165 ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro.
1166 ;;; It prevents multiple mindless errors when the network craters.
1167 ;;;
1168 ;;;----------------------------------------------------------------------------
1169
1170 #-Genera
1171 (defmacro wrap-buf-output ((buffer) &body body)
1172 ;; Error recovery wrapper
1173 `(unless (buffer-dead ,buffer)
1174 ,@body))
1175
1176 #+Genera
1177 (defmacro wrap-buf-output ((buffer) &body body)
1178 ;; Error recovery wrapper
1179 `(let ((.buffer. ,buffer))
1180 (unless (buffer-dead .buffer.)
1181 (scl:condition-bind
1182 (((sys:network-error)
1183 #'(lambda (error)
1184 (scl:condition-case ()
1185 (funcall (buffer-close-function .buffer.) .buffer. :abort t)
1186 (sys:network-error))
1187 (setf (buffer-dead .buffer.) error)
1188 (setf (buffer-output-stream .buffer.) nil)
1189 (setf (buffer-input-stream .buffer.) nil)
1190 nil)))
1191 ,@body))))
1192
1193 #-Genera
1194 (defmacro wrap-buf-input ((buffer) &body body)
1195 (declare (ignore buffer))
1196 ;; Error recovery wrapper
1197 `(progn ,@body))
1198
1199 #+Genera
1200 (defmacro wrap-buf-input ((buffer) &body body)
1201 ;; Error recovery wrapper
1202 `(let ((.buffer. ,buffer))
1203 (scl:condition-bind
1204 (((sys:network-error)
1205 #'(lambda (error)
1206 (scl:condition-case ()
1207 (funcall (buffer-close-function .buffer.) .buffer. :abort t)
1208 (sys:network-error))
1209 (setf (buffer-dead .buffer.) error)
1210 (setf (buffer-output-stream .buffer.) nil)
1211 (setf (buffer-input-stream .buffer.) nil)
1212 nil)))
1213 ,@body)))
1214
1215
1216 ;;;----------------------------------------------------------------------------
1217 ;;; System dependent IO primitives
1218 ;;; Functions for opening, reading writing forcing-output and closing
1219 ;;; the stream to the server.
1220 ;;;----------------------------------------------------------------------------
1221
1222 ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
1223 ;;; server
1224
1225 #-(or explorer Genera lucid kcl ibcl excl Minima CMU)
1226 (defun open-x-stream (host display protocol)
1227 host display protocol ;; unused
1228 (error "OPEN-X-STREAM not implemented yet."))
1229
1230 ;;; Genera:
1231
1232 ;;; TCP and DNA are both layered products, so try to work with either one.
1233
1234 #+Genera
1235 (when (fboundp 'tcp:add-tcp-port-for-protocol)
1236 (tcp:add-tcp-port-for-protocol :x-window-system 6000))
1237
1238 #+Genera
1239 (when (fboundp 'dna:add-dna-contact-id-for-protocol)
1240 (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0"))
1241
1242 #+Genera
1243 (net:define-protocol :x-window-system (:x-window-system :byte-stream)
1244 (:invoke-with-stream ((stream :characters nil :ascii-translation nil))
1245 stream))
1246
1247 #+Genera
1248 (eval-when (compile)
1249 (compiler:function-defined 'tcp:open-tcp-stream)
1250 (compiler:function-defined 'dna:open-dna-bidirectional-stream))
1251
1252 #+Genera
1253 (defun open-x-stream (host display protocol)
1254 (let ((host (net:parse-host host)))
1255 (if (or protocol (plusp display))
1256 ;; The protocol was specified or the display isn't 0, so we
1257 ;; can't use the Generic Network System. If the protocol was
1258 ;; specified, then use that protocol, otherwise, blindly use
1259 ;; TCP.
1260 (ccase protocol
1261 ((:tcp nil)
1262 (tcp:open-tcp-stream
1263 host (+ *x-tcp-port* display) nil
1264 :direction :io
1265 :characters nil
1266 :ascii-translation nil))
1267 ((:dna)
1268 (dna:open-dna-bidirectional-stream
1269 host (format nil "X$X~D" display)
1270 :characters nil
1271 :ascii-translation nil)))
1272 (let ((neti:*invoke-service-automatic-retry* t))
1273 (net:invoke-service-on-host :x-window-system host)))))
1274
1275 #+explorer
1276 (defun open-x-stream (host display protocol)
1277 (declare (ignore protocol))
1278 (net:open-connection-on-medium
1279 (net:parse-host host) ;Host
1280 :byte-stream ;Medium
1281 "X11" ;Logical contact name
1282 :stream-type :character-stream
1283 :direction :bidirectional
1284 :timeout-after-open nil
1285 :remote-port (+ *x-tcp-port* display)))
1286
1287 #+explorer
1288 (net:define-logical-contact-name
1289 "X11"
1290 `((:local "X11")
1291 (:chaos "X11")
1292 (:nsp-stream "X11")
1293 (:tcp ,*x-tcp-port*)))
1294
1295 #+lucid
1296 (defun open-x-stream (host display protocol)
1297 protocol ;; unused
1298 (let ((fd (connect-to-server host display)))
1299 (when (minusp fd)
1300 (error "Failed to connect to server: ~A ~D" host display))
1301 (user::make-lisp-stream :input-handle fd
1302 :output-handle fd
1303 :element-type 'unsigned-byte
1304 #-lcl3.0 :stream-type #-lcl3.0 :ephemeral)))
1305
1306 #+(or kcl ibcl)
1307 (defun open-x-stream (host display protocol)
1308 protocol ;; unused
1309 (let ((stream (open-socket-stream host display)))
1310 (if (streamp stream)
1311 stream
1312 (error "Cannot connect to server: ~A:~D" host display))))
1313
1314 #+excl
1315 ;;
1316 ;; Note that since we don't use the CL i/o facilities to do i/o, the display
1317 ;; input and output "stream" is really a file descriptor (fixnum).
1318 ;;
1319 (defun open-x-stream (host display protocol)
1320 (declare (ignore protocol));; unused
1321 (let ((fd (connect-to-server (string host) display)))
1322 (when (minusp fd)
1323 (error "Failed to connect to server: ~A ~D" host display))
1324 fd))
1325
1326 #+Minima
1327 (defun open-x-stream (host display protocol)
1328 (declare (ignore protocol));; unused
1329 (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address
1330 (cdr (host-address host)))
1331 :foreign-port (+ *x-tcp-port* display)))
1332
1333 ;;; OPEN-X-STREAM -- for CMU Common Lisp.
1334 ;;;
1335 ;;; The file descriptor here just gets tossed into the stream slot of the
1336 ;;; display object instead of a stream.
1337 ;;;
1338 #+CMU
1339 (defun open-x-stream (host display protocol)
1340 (declare (ignore protocol))
1341 (let ((server-fd (connect-to-server host display)))
1342 (unless (plusp server-fd)
1343 (error "Failed to connect to X11 server: ~A (display ~D)" host display))
1344 (system:make-fd-stream server-fd :input t :output t
1345 :element-type '(unsigned-byte 8))))
1346
1347 ;;; This loads the C foreign function used to make an IPC connection
1348 ;;; to the X11 server. It also defines the necessary types and things
1349 ;;; to actually make the foreign call. See the OPEN-X-STREAM function
1350 ;;; in the dependent.lisp file.
1351 ;;;
1352 #+CMU
1353 (ext:def-c-routine ("connect_to_server" connect-to-server) (ext:int)
1354 (host system:null-terminated-string)
1355 (port ext:int))
1356
1357 ;;; BUFFER-READ-DEFAULT - read data from the X stream
1358
1359 #+(or Genera explorer)
1360 (defun buffer-read-default (display vector start end timeout)
1361 ;; returns non-NIL if EOF encountered
1362 ;; Returns :TIMEOUT when timeout exceeded
1363 (declare (type display display)
1364 (type buffer-bytes vector)
1365 (type array-index start end)
1366 (type (or null (real 0 *)) timeout))
1367 #.(declare-buffun)
1368 (let ((stream (display-input-stream display)))
1369 (or (cond ((null stream))
1370 ((funcall stream :listen) nil)
1371 ((and timeout (= timeout 0)) :timeout)
1372 ((buffer-input-wait-default display timeout)))
1373 (multiple-value-bind (ignore eofp)
1374 (funcall stream :string-in nil vector start end)
1375 eofp))))
1376
1377
1378 #+excl
1379 ;;
1380 ;; Rewritten 10/89 to not use foreign function interface to do I/O.
1381 ;;
1382 (defun buffer-read-default (display vector start end timeout)
1383 (declare (type display display)
1384 (type buffer-bytes vector)
1385 (type array-index start end)
1386 (type (or null (real 0 *)) timeout))
1387 #.(declare-buffun)
1388
1389 (let* ((howmany (- end start))
1390 (fd (display-input-stream display)))
1391 (declare (type array-index howmany)
1392 (fixnum fd))
1393 (or (cond ((fd-char-avail-p fd) nil)
1394 ((and timeout (= timeout 0)) :timeout)
1395 ((buffer-input-wait-default display timeout)))
1396 (fd-read-bytes fd vector start howmany))))
1397
1398
1399 #+lcl3.0
1400 (defmacro with-underlying-stream ((variable stream display direction) &body body)
1401 `(let ((,variable
1402 (or (getf (display-plist ,display) ',direction)
1403 (setf (getf (display-plist ,display) ',direction)
1404 (lucid::underlying-stream
1405 ,stream ,(if (eq direction 'input) :input :output))))))
1406 ,@body))
1407
1408 #+lcl3.0
1409 (defun buffer-read-default (display vector start end timeout)
1410 ;;Note that LISTEN must still be done on "slow stream" or the I/O system
1411 ;;gets confused. But reading should be done from "fast stream" for speed.
1412 ;;We used to inhibit scheduling because there were races in Lucid's
1413 ;;multitasking system. Empirical evidence suggests they may be gone now.
1414 ;;Should you decide you need to inhibit scheduling, do it around the
1415 ;;lcl:read-array.
1416 (declare (type display display)
1417 (type buffer-bytes vector)
1418 (type array-index start end)
1419 (type (or null (real 0 *)) timeout))
1420 #.(declare-buffun)
1421 (let ((stream (display-input-stream display)))
1422 (declare (type (or null stream) stream))
1423 (or (cond ((null stream))
1424 ((listen stream) nil)
1425 ((and timeout (= timeout 0)) :timeout)
1426 ((buffer-input-wait-default display timeout)))
1427 (with-underlying-stream (stream stream display input)
1428 (eq (lcl:read-array stream vector start end nil :eof) :eof)))))
1429
1430 #+Minima
1431 (defun buffer-read-default (display vector start end timeout)
1432 ;; returns non-NIL if EOF encountered
1433 ;; Returns :TIMEOUT when timeout exceeded
1434 (declare (type display display)
1435 (type buffer-bytes vector)
1436 (type array-index start end)
1437 (type (or null (real 0 *)) timeout))
1438 #.(declare-buffun)
1439 (let ((stream (display-input-stream display)))
1440 (or (cond ((null stream))
1441 ((listen stream) nil)
1442 ((and timeout (= timeout 0)) :timeout)
1443 ((buffer-input-wait-default display timeout)))
1444 (eq :eof (minima:read-vector vector stream nil start end)))))
1445
1446 ;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
1447 ;;;
1448 ;;; If timeout is 0, then we call LISTEN to see if there is any input.
1449 ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without
1450 ;;; first calling BUFFER-INPUT-WAIT-DEFAULT.
1451 ;;;
1452 #+CMU
1453 (defun buffer-read-default (display vector start end timeout)
1454 (declare (type display display)
1455 (type buffer-bytes vector)
1456 (type array-index start end)
1457 (type (or null (real 0 *)) timeout))
1458 #.(declare-buffun)
1459 (cond ((and (and timeout (= timeout 0))
1460 (not (listen (display-input-stream display))))
1461 :timeout)
1462 (t
1463 (system:read-n-bytes (display-input-stream display)
1464 vector start (- end start))
1465 nil)))
1466
1467 ;;; WARNING:
1468 ;;; CLX performance will suffer if your lisp uses read-byte for
1469 ;;; receiving all data from the X Window System server.
1470 ;;; You are encouraged to write a specialized version of
1471 ;;; buffer-read-default that does block transfers.
1472 #-(or Genera explorer excl lcl3.0 Minima CMU)
1473 (defun buffer-read-default (display vector start end timeout)
1474 (declare (type display display)
1475 (type buffer-bytes vector)
1476 (type array-index start end)
1477 (type (or null (real 0 *)) timeout))
1478 #.(declare-buffun)
1479 (let ((stream (display-input-stream display)))
1480 (declare (type (or null stream) stream))
1481 (or (cond ((null stream))
1482 ((listen stream) nil)
1483 ((and timeout (= timeout 0)) :timeout)
1484 ((buffer-input-wait-default display timeout)))
1485 (do* ((index start (index1+ index)))
1486 ((index>= index end) nil)
1487 (declare (type array-index index))
1488 (let ((c (read-byte stream nil nil)))
1489 (declare (type (or null card8) c))
1490 (if (null c)
1491 (return t)
1492 (setf (aref vector index) (the card8 c))))))))
1493
1494 ;;; BUFFER-WRITE-DEFAULT - write data to the X stream
1495
1496 #+(or Genera explorer)
1497 (defun buffer-write-default (vector display start end)
1498 ;; The default buffer write function for use with common-lisp streams
1499 (declare (type buffer-bytes vector)
1500 (type display display)
1501 (type array-index start end))
1502 #.(declare-buffun)
1503 (let ((stream (display-output-stream display)))
1504 (declare (type (or null stream) stream))
1505 (unless (null stream)
1506 (write-string vector stream :start start :end end))))
1507
1508 #+excl
1509 (defun buffer-write-default (vector display start end)
1510 (declare (type buffer-bytes vector)
1511 (type display display)
1512 (type array-index start end))
1513 #.(declare-buffun)
1514 (excl::filesys-write-bytes (display-output-stream display) vector start
1515 (- end start)))
1516
1517 #+lcl3.0
1518 (defun buffer-write-default (vector display start end)
1519 ;;We used to inhibit scheduling because there were races in Lucid's
1520 ;;multitasking system. Empirical evidence suggests they may be gone now.
1521 ;;Should you decide you need to inhibit scheduling, do it around the
1522 ;;lcl:write-array.
1523 (declare (type display display)
1524 (type buffer-bytes vector)
1525 (type array-index start end))
1526 #.(declare-buffun)
1527 (let ((stream (display-output-stream display)))
1528 (declare (type (or null stream) stream))
1529 (unless (null stream)
1530 (with-underlying-stream (stream stream display output)
1531 (lcl:write-array stream vector start end)))))
1532
1533 #+Minima
1534 (defun buffer-write-default (vector display start end)
1535 ;; The default buffer write function for use with common-lisp streams
1536 (declare (type buffer-bytes vector)
1537 (type display display)
1538 (type array-index start end))
1539 #.(declare-buffun)
1540 (let ((stream (display-output-stream display)))
1541 (declare (type (or null stream) stream))
1542 (unless (null stream)
1543 (minima:write-vector vector stream start end))))
1544
1545 #+CMU
1546 (defun buffer-write-default (vector display start end)
1547 (declare (type buffer-bytes vector)
1548 (type display display)
1549 (type array-index start end))
1550 #.(declare-buffun)
1551 (system:output-raw-bytes (display-output-stream display) vector start end)
1552 nil)
1553
1554 ;;; WARNING:
1555 ;;; CLX performance will be severely degraded if your lisp uses
1556 ;;; write-byte to send all data to the X Window System server.
1557 ;;; You are STRONGLY encouraged to write a specialized version
1558 ;;; of buffer-write-default that does block transfers.
1559
1560 #-(or Genera explorer excl lcl3.0 Minima CMU)
1561 (defun buffer-write-default (vector display start end)
1562 ;; The default buffer write function for use with common-lisp streams
1563 (declare (type buffer-bytes vector)
1564 (type display display)
1565 (type array-index start end))
1566 #.(declare-buffun)
1567 (let ((stream (display-output-stream display)))
1568 (declare (type (or null stream) stream))
1569 (unless (null stream)
1570 (with-vector (vector buffer-bytes)
1571 (do ((index start (index1+ index)))
1572 ((index>= index end))
1573 (declare (type array-index index))
1574 (write-byte (aref vector index) stream))))))
1575
1576 ;;; buffer-force-output-default - force output to the X stream
1577
1578 #+excl
1579 (defun buffer-force-output-default (display)
1580 ;; buffer-write-default does the actual writing.
1581 (declare (ignore display)))
1582
1583 #-excl
1584 (defun buffer-force-output-default (display)
1585 ;; The default buffer force-output function for use with common-lisp streams
1586 (declare (type display display))
1587 (let ((stream (display-output-stream display)))
1588 (declare (type (or null stream) stream))
1589 (unless (null stream)
1590 (force-output stream))))
1591
1592 ;;; BUFFER-CLOSE-DEFAULT - close the X stream
1593
1594 #+excl
1595 (defun buffer-close-default (display &key abort)
1596 ;; The default buffer close function for use with common-lisp streams
1597 (declare (type display display)
1598 (ignore abort))
1599 #.(declare-buffun)
1600 (excl::filesys-checking-close (display-output-stream display)))
1601
1602 #-excl
1603 (defun buffer-close-default (display &key abort)
1604 ;; The default buffer close function for use with common-lisp streams
1605 (declare (type display display))
1606 #.(declare-buffun)
1607 (let ((stream (display-output-stream display)))
1608 (declare (type (or null stream) stream))
1609 (unless (null stream)
1610 (close stream :abort abort))))
1611
1612 ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
1613 ;;; buffer. This is called in read-input between requests, so that a process
1614 ;;; waiting for input is abortable when between requests. Should return
1615 ;;; :TIMEOUT if it times out, NIL otherwise.
1616
1617 ;;; The default implementation
1618
1619 ;; Poll for input every *buffer-read-polling-time* SECONDS.
1620 #-(or Genera explorer excl lcl3.0 CMU)
1621 (defparameter *buffer-read-polling-time* 0.5)
1622
1623 #-(or Genera explorer excl lcl3.0 CMU)
1624 (defun buffer-input-wait-default (display timeout)
1625 (declare (type display display)
1626 (type (or null (real 0 *)) timeout))
1627 (declare (clx-values timeout))
1628
1629 (let ((stream (display-input-stream display)))
1630 (declare (type (or null stream) stream))
1631 (cond ((null stream))
1632 ((listen stream) nil)
1633 ((and timeout (= timeout 0)) :timeout)
1634 ((not (null timeout))
1635 (multiple-value-bind (npoll fraction)
1636 (truncate timeout *buffer-read-polling-time*)
1637 (dotimes (i npoll) ; Sleep for a time, then listen again
1638 (sleep *buffer-read-polling-time*)
1639 (when (listen stream)
1640 (return-from buffer-input-wait-default nil)))
1641 (when (plusp fraction)
1642 (sleep fraction) ; Sleep a fraction of a second
1643 (when (listen stream) ; and listen one last time
1644 (return-from buffer-input-wait-default nil)))
1645 :timeout)))))
1646
1647 #+CMU
1648 (defun buffer-input-wait-default (display timeout)
1649 (declare (type display display)
1650 (type (or null (real 0 *)) timeout))
1651 (let ((stream (display-input-stream display)))
1652 (declare (type (or null stream) stream))
1653 (cond ((null stream))
1654 ((listen stream) nil)
1655 ((and timeout (= timeout 0)) :timeout)
1656 (t
1657 (if (system:wait-until-fd-usable (system:fd-stream-fd stream)
1658 :input timeout)
1659 nil
1660 :timeout)))))
1661
1662 #+Genera
1663 (defun buffer-input-wait-default (display timeout)
1664 (declare (type display display)
1665 (type (or null (real 0 *)) timeout))
1666 (declare (clx-values timeout))
1667 (let ((stream (display-input-stream display)))
1668 (declare (type (or null stream) stream))
1669 (cond ((null stream))
1670 ((scl:send stream :listen) nil)
1671 ((and timeout (= timeout 0)) :timeout)
1672 ((null timeout) (si:stream-input-block stream "CLX Input"))
1673 (t
1674 (scl:condition-bind ((neti:protocol-timeout
1675 #'(lambda (error)
1676 (when (eq stream (scl:send error :stream))
1677 (return-from buffer-input-wait-default :timeout)))))
1678 (neti:with-stream-timeout (stream :input timeout)
1679 (si:stream-input-block stream "CLX Input")))))
1680 nil))
1681
1682 #+explorer
1683 (defun buffer-input-wait-default (display timeout)
1684 (declare (type display display)
1685 (type (or null (real 0 *)) timeout))
1686 (declare (clx-values timeout))
1687 (let ((stream (display-input-stream display)))
1688 (declare (type (or null stream) stream))
1689 (cond ((null stream))
1690 ((zl:send stream :listen) nil)
1691 ((and timeout (= timeout 0)) :timeout)
1692 ((null timeout)
1693 (si:process-wait "CLX Input" stream :listen))
1694 (t
1695 (unless (si:process-wait-with-timeout
1696 "CLX Input" (round (* timeout 60.)) stream :listen)
1697 (return-from buffer-input-wait-default :timeout))))
1698 nil))
1699
1700 #+excl
1701 ;;
1702 ;; This is used so an 'eq' test may be used to find out whether or not we can
1703 ;; safely throw this process out of the CLX read loop.
1704 ;;
1705 (defparameter *read-whostate* "waiting for input from X server")
1706
1707 ;;
1708 ;; Note that this function returns nil on error if the scheduler is running,
1709 ;; t on error if not. This is ok since buffer-read will detect the error.
1710 ;;
1711 #+excl
1712 (defun buffer-input-wait-default (display timeout)
1713 (declare (type display display)
1714 (type (or null (real 0 *)) timeout))
1715 (declare (clx-values timeout))
1716 (let ((fd (display-input-stream display)))
1717 (declare (fixnum fd))
1718 (when (>= fd 0)
1719 (cond ((fd-char-avail-p fd)
1720 nil)
1721
1722 ;; Otherwise no bytes were available on the socket
1723 ((and timeout (= timeout 0))
1724 ;; If there aren't enough and timeout == 0, timeout.
1725 :timeout)
1726
1727 ;; If the scheduler is running let it do timeouts.
1728 (mp::*scheduler-stack-group*
1729 #+allegro
1730 (if (not
1731 (mp:wait-for-input-available fd :whostate *read-whostate*
1732 :wait-function #'fd-char-avail-p
1733 :timeout timeout))
1734 (return-from buffer-input-wait-default :timeout))
1735 #-allegro
1736 (mp::wait-for-input-available fd :whostate *read-whostate*
1737 :wait-function #'fd-char-avail-p))
1738
1739 ;; Otherwise we have to handle timeouts by hand, and call select()
1740 ;; to block until input is available. Note we don't really handle
1741 ;; the interaction of interrupts and (numberp timeout) here. XX
1742 (t
1743 (let ((res 0))
1744 (declare (fixnum res))
1745 (with-interrupt-checking-on
1746 (loop
1747 (setq res (fd-wait-for-input fd (if (null timeout) 0
1748 (truncate timeout))))
1749 (cond ((plusp res) ; success
1750 (return nil))
1751 ((eq res 0) ; timeout
1752 (return :timeout))
1753 ((eq res -1) ; error
1754 (return t))
1755 ;; Otherwise we got an interrupt -- go around again.
1756 )))))))))
1757
1758
1759 #+lcl3.0
1760 (defun buffer-input-wait-default (display timeout)
1761 (declare (type display display)
1762 (type (or null (real 0 *)) timeout)
1763 (clx-values timeout))
1764 #.(declare-buffun)
1765 (let ((stream (display-input-stream display)))
1766 (declare (type (or null stream) stream))
1767 (cond ((null stream))
1768 ((listen stream) nil)
1769 ((and timeout (= timeout 0)) :timeout)
1770 ((with-underlying-stream (stream stream display input)
1771 (lucid::waiting-for-input-from-stream stream
1772 (lucid::with-io-unlocked
1773 (if (null timeout)
1774 (lcl:process-wait "CLX Input" #'listen stream)
1775 (lcl:process-wait-with-timeout
1776 "CLX Input" timeout #'listen stream)))))
1777 nil)
1778 (:timeout))))
1779
1780
1781 ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
1782 ;;; buffer. This should never block, so it can be called from the scheduler.
1783
1784 ;;; The default implementation is to just use listen.
1785 #-excl
1786 (defun buffer-listen-default (display)
1787 (declare (type display display))
1788 (let ((stream (display-input-stream display)))
1789 (declare (type (or null stream) stream))
1790 (if (null stream)
1791 t
1792 (listen stream))))
1793
1794 #+excl
1795 (defun buffer-listen-default (display)
1796 (declare (type display display))
1797 (let ((fd (display-input-stream display)))
1798 (declare (type fixnum fd))
1799 (if (= fd -1)
1800 t
1801 (fd-char-avail-p fd))))
1802
1803
1804 ;;;----------------------------------------------------------------------------
1805 ;;; System dependent speed hacks
1806 ;;;----------------------------------------------------------------------------
1807
1808 ;;
1809 ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
1810 ;; If your lisp doesn't have stack-lists, and you're worried about
1811 ;; consing garbage, you may want to re-write this to allocate and
1812 ;; initialize lists from a resource.
1813 ;;
1814 #-lispm
1815 (defmacro with-stack-list ((var &rest elements) &body body)
1816 ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
1817 ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
1818 ;; except that the list produced by MAPCAR resides on the stack and
1819 ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
1820 `(let ((,var (list ,@elements)))
1821 (declare (type cons ,var)
1822 #+clx-ansi-common-lisp (dynamic-extent ,var))
1823 ,@body))
1824
1825 #-lispm
1826 (defmacro with-stack-list* ((var &rest elements) &body body)
1827 ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
1828 ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
1829 ;; except that the list produced by MAPCAR resides on the stack and
1830 ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
1831 `(let ((,var (list* ,@elements)))
1832 (declare (type cons ,var)
1833 #+clx-ansi-common-lisp (dynamic-extent ,var))
1834 ,@body))
1835
1836 (declaim (inline buffer-replace))
1837
1838 #+lispm
1839 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1840 (declare (type vector buf1 buf2)
1841 (type array-index start1 end1 start2))
1842 (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))
1843
1844 #+excl
1845 (defun buffer-replace (target-sequence source-sequence target-start
1846 target-end &optional (source-start 0))
1847 (declare (type buffer-bytes target-sequence source-sequence)
1848 (type array-index target-start target-end source-start)
1849 (optimize (speed 3) (safety 0)))
1850
1851 (let ((source-end (length source-sequence)))
1852 (declare (type array-index source-end))
1853
1854 (excl:if* (and (eq target-sequence source-sequence)
1855 (> target-start source-start))
1856 then (let ((nelts (min (- target-end target-start)
1857 (- source-end source-start))))
1858 (do ((target-index (+ target-start nelts -1) (1- target-index))
1859 (source-index (+ source-start nelts -1) (1- source-index)))
1860 ((= target-index (1- target-start)) target-sequence)
1861 (declare (type array-index target-index source-index))
1862
1863 (setf (aref target-sequence target-index)
1864 (aref source-sequence source-index))))
1865 else (do ((target-index target-start (1+ target-index))
1866 (source-index source-start (1+ source-index)))
1867 ((or (= target-index target-end) (= source-index source-end))
1868 target-sequence)
1869 (declare (type array-index target-index source-index))
1870
1871 (setf (aref target-sequence target-index)
1872 (aref source-sequence source-index))))))
1873
1874 #+cmu
1875 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1876 (declare (type buffer-bytes buf1 buf2)
1877 (type array-index start1 end1 start2))
1878 #.(declare-buffun)
1879 (kernel:bit-bash-copy
1880 buf2 (+ (* start2 vm:byte-bits)
1881 (* vm:vector-data-offset vm:word-bits))
1882 buf1 (+ (* start1 vm:byte-bits)
1883 (* vm:vector-data-offset vm:word-bits))
1884 (* (- end1 start1) vm:byte-bits)))
1885
1886 #+lucid
1887 ;;;The compiler is *supposed* to optimize calls to replace, but in actual
1888 ;;;fact it does not.
1889 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1890 (declare (type buffer-bytes buf1 buf2)
1891 (type array-index start1 end1 start2))
1892 #.(declare-buffun)
1893 (let ((end2 (lucid::%simple-8bit-vector-length buf2)))
1894 (declare (type array-index end2))
1895 (lucid::simple-8bit-vector-replace-internal
1896 buf1 buf2 start1 end1 start2 end2)))
1897
1898 #+(and clx-overlapping-arrays (not (or lispm excl)))
1899 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1900 (declare (type vector buf1 buf2)
1901 (type array-index start1 end1 start2))
1902 (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
1903
1904 #-(or lispm lucid excl CMU clx-overlapping-arrays)
1905 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
1906 (declare (type buffer-bytes buf1 buf2)
1907 (type array-index start1 end1 start2))
1908 (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
1909
1910 #+ti
1911 (defun with-location-bindings (sys:&quote bindings &rest body)
1912 (do ((bindings bindings (cdr bindings)))
1913 ((null bindings)
1914 (sys:eval-body-as-progn body))
1915 (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))
1916 (sys:*eval (cadar bindings)))))
1917
1918 #+ti
1919 (compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)
1920 (let ((bindings (cadr form))
1921 (body (cddr form)))
1922 `(let ()
1923 ,@(loop for (accessor value) in bindings
1924 collect `(si:bind (si:locf ,accessor) ,value))
1925 ,@body)))
1926
1927 #+ti
1928 (defun (:property with-location-bindings compiler::cw-handler) (exp)
1929 (let* ((bindlist (mapcar #'compiler::cw-clause (second exp)))
1930 (body (compiler::cw-clause (cddr exp))))
1931 (and compiler::cw-return-expansion-flag
1932 (list* (first exp) bindlist body))))
1933
1934 #+(and lispm (not ti))
1935 (defmacro with-location-bindings (bindings &body body)
1936 `(sys:letf* ,bindings ,@body))
1937
1938 #+lispm
1939 (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
1940 &body body)
1941 ;; don't use svref on LHS because Symbolics didn't define locf for it
1942 (let* ((local-state (gensym))
1943 (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway
1944 (dolist (index indexes)
1945 (push `((aref ,local-state ,index) (svref ,saved-state ,index))
1946 bindings))
1947 `(let ((,local-state (gcontext-local-state ,gc)))
1948 (declare (type gcontext-state ,local-state))
1949 (unwind-protect
1950 (with-location-bindings ,bindings
1951 ,@body)
1952 (setf (svref ,local-state ,ts-index) 0)
1953 (when ,temp-gc
1954 (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
1955 (deallocate-gcontext-state ,saved-state)))))
1956
1957 #-lispm
1958 (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
1959 &body body)
1960 (let ((local-state (gensym))
1961 (resets nil))
1962 (dolist (index indexes)
1963 (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
1964 resets))
1965 `(unwind-protect
1966 (progn
1967 ,@body)
1968 (let ((,local-state (gcontext-local-state ,gc)))
1969 (declare (type gcontext-state ,local-state))
1970 ,@resets
1971 (setf (svref ,local-state ,ts-index) 0))
1972 (when ,temp-gc
1973 (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
1974 (deallocate-gcontext-state ,saved-state))))
1975
1976 ;;;----------------------------------------------------------------------------
1977 ;;; How error detection should CLX do?
1978 ;;; Several levels are possible:
1979 ;;;
1980 ;;; 1. Do the equivalent of check-type on every argument.
1981 ;;;
1982 ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format
1983 ;;; strings generated by check-type.
1984 ;;;
1985 ;;; 3. Do error checking only on arguments that are likely to have errors
1986 ;;; (like keyword names)
1987 ;;;
1988 ;;; 4. Do error checking only where not doing so may dammage the envirnment
1989 ;;; on a non-tagged machine (i.e. when storing into a structure that has
1990 ;;; been passed in)
1991 ;;;
1992 ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to
1993 ;;; store a non-integer into a number array.
1994 ;;;
1995 ;;; How extensive should the error checking be? For example, if the server
1996 ;;; expects a CARD16, is is sufficient for CLX to check for integer, or
1997 ;;; should it also check for non-negative and less than 65536?
1998 ;;;----------------------------------------------------------------------------
1999
2000 ;; The *TYPE-CHECK?* constant controls how much error checking is done.
2001 ;; Possible values are:
2002 ;; NIL - Don't do any error checking
2003 ;; t - Do the equivalent of checktype on every argument
2004 ;; :minimal - Do error checking only where errors are likely
2005
2006 ;;; This controls macro expansion, and isn't changable at run-time You will
2007 ;;; probably want to set this to nil if you want good performance at
2008 ;;; production time.
2009 (defconstant *type-check?* #+(or Genera Minima CMU) nil #-(or Genera Minima CMU) t)
2010
2011 ;; TYPE? is used to allow the code to do error checking at a different level from
2012 ;; the declarations. It also does some optimizations for systems that don't have
2013 ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc.
2014 ;; include range checks. You can modify TYPE? to do less extensive checking
2015 ;; for these types if you desire.
2016
2017 ;;
2018 ;; ### This comment is a lie! TYPE? is really also used for run-time type
2019 ;; dispatching, not just type checking. -- Ram.
2020
2021 (defmacro type? (object type)
2022 #+cmu
2023 `(typep ,object ,type)
2024 #-cmu
2025 (if (not (constantp type))
2026 `(typep ,object ,type)
2027 (progn
2028 (setq type (eval type))
2029 #+(or Genera explorer Minima)
2030 (if *type-check?*
2031 `(locally (declare (optimize safety)) (typep ,object ',type))
2032 `(typep ,object ',type))
2033 #-(or Genera explorer Minima)
2034 (let ((predicate (assoc type
2035 '((drawable drawable-p) (window window-p)
2036 (pixmap pixmap-p) (cursor cursor-p)
2037 (font font-p) (gcontext gcontext-p)
2038 (colormap colormap-p) (null null)
2039 (integer integerp)))))
2040 (cond (predicate
2041 `(,(second predicate) ,object))
2042 ((eq type 'boolean)
2043 't) ; Everything is a boolean.
2044 (*type-check?*
2045 `(locally (declare (optimize safety)) (typep ,object ',type)))
2046 (t
2047 `(typep ,object ',type)))))))
2048
2049 ;; X-TYPE-ERROR is the function called for type errors.
2050 ;; If you want lots of checking, but are concerned about code size,
2051 ;; this can be made into a macro that ignores some parameters.
2052
2053 (defun x-type-error (object type &optional error-string)
2054 (x-error 'x-type-error
2055 :datum object
2056 :expected-type type
2057 :type-string error-string))
2058
2059
2060 ;;-----------------------------------------------------------------------------
2061 ;; Error handlers
2062 ;; Hack up KMP error signaling using zetalisp until the real thing comes
2063 ;; along
2064 ;;-----------------------------------------------------------------------------
2065
2066 (defun default-error-handler (display error-key &rest key-vals
2067 &key asynchronous &allow-other-keys)
2068 (declare (type boolean asynchronous)
2069 (dynamic-extent key-vals))
2070 ;; The default display-error-handler.
2071 ;; It signals the conditions listed in the DISPLAY file.
2072 (if asynchronous
2073 (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)
2074 (apply #'x-error error-key :display display :error-key error-key key-vals)))
2075
2076 #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2077 (defun x-error (condition &rest keyargs)
2078 (apply #'sys:signal condition keyargs))
2079
2080 #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2081 (defun x-cerror (proceed-format-string condition &rest keyargs)
2082 (sys:signal (apply #'zl:make-condition condition keyargs)
2083 :proceed-types proceed-format-string))
2084
2085 #+(and Genera (not clx-ansi-common-lisp))
2086 (defun x-error (condition &rest keyargs)
2087 (declare (dbg:error-reporter))
2088 (apply #'sys:signal condition keyargs))
2089
2090 #+(and Genera (not clx-ansi-common-lisp))
2091 (defun x-cerror (proceed-format-string condition &rest keyargs)
2092 (declare (dbg:error-reporter))
2093 (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))
2094
2095 #+(or clx-ansi-common-lisp excl lcl3.0)
2096 (defun x-error (condition &rest keyargs)
2097 (declare (dynamic-extent keyargs))
2098 (apply #'error condition keyargs))
2099
2100 #+(or clx-ansi-common-lisp excl lcl3.0 CMU)
2101 (defun x-cerror (proceed-format-string condition &rest keyargs)
2102 (declare (dynamic-extent keyargs))
2103 (apply #'cerror proceed-format-string condition keyargs))
2104
2105 ;;; X-ERROR for CMU Common Lisp
2106 ;;;
2107 ;;; We detect a couple condition types for which we disable event handling in
2108 ;;; our system. This prevents going into the debugger or returning to a
2109 ;;; command prompt with CLX repeatedly seeing the same condition. This occurs
2110 ;;; because CMU Common Lisp provides for all events (that is, X, input on file
2111 ;;; descriptors, Mach messages, etc.) to come through one routine anyone can
2112 ;;; use to wait for input.
2113 ;;;
2114 #+CMU
2115 (defun x-error (condition &rest keyargs)
2116 (let ((condx (apply #'make-condition condition keyargs)))
2117 (typecase condx
2118 ;; This condition no longer exists.
2119 #||
2120 (server-disconnect
2121 (let ((disp (server-disconnect-display condx)))
2122 (warn "Disabled event handling on ~S." disp)
2123 (ext::disable-clx-event-handling disp)))
2124 ||#
2125 (closed-display
2126 (let ((disp (closed-display-display condx)))
2127 (warn "Disabled event handling on ~S." disp)
2128 (ext::disable-clx-event-handling disp))))
2129 (error condx)))
2130
2131 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
2132 (defun x-error (condition &rest keyargs)
2133 (error "X-Error: ~a"
2134 (princ-to-string (apply #'make-condition condition keyargs))))
2135
2136 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
2137 (defun x-cerror (proceed-format-string condition &rest keyargs)
2138 (cerror proceed-format-string "X-Error: ~a"
2139 (princ-to-string (apply #'make-condition condition keyargs))))
2140
2141 ;; version 15 of Pitman error handling defines the syntax for define-condition to be:
2142 ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]
2143 ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
2144 ;; or (:report exp)
2145
2146 #+lcl3.0
2147 (defmacro define-condition (name parent-types &optional slots &rest args)
2148 `(lcl:define-condition
2149 ,name (,(first parent-types))
2150 ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2151 slots)
2152 ,@args))
2153
2154 #+(and excl (not clx-ansi-common-lisp))
2155 (defmacro define-condition (name parent-types &optional slots &rest args)
2156 `(excl::define-condition
2157 ,name (,(first parent-types))
2158 ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2159 slots)
2160 ,@args))
2161
2162 #+(and CMU (not clx-ansi-common-lisp))
2163 (defmacro define-condition (name parent-types &optional slots &rest args)
2164 `(lisp:define-condition
2165 ,name (,(first parent-types))
2166 ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2167 slots)
2168 ,@args))
2169
2170 #+(and lispm (not clx-ansi-common-lisp))
2171 (defmacro define-condition (name parent-types &body options)
2172 (let ((slot-names
2173 (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2174 (pop options)))
2175 (documentation nil)
2176 (conc-name (concatenate 'string (string name) "-"))
2177 (reporter nil))
2178 (dolist (item options)
2179 (ecase (first item)
2180 (:documentation (setq documentation (second item)))
2181 (:conc-name (setq conc-name (string (second item))))
2182 (:report (setq reporter (second item)))))
2183 `(within-definition (,name define-condition)
2184 (zl:defflavor ,name ,slot-names ,parent-types
2185 :initable-instance-variables
2186 #-Genera
2187 (:accessor-prefix ,conc-name)
2188 #+Genera
2189 (:conc-name ,conc-name)
2190 #-Genera
2191 (:outside-accessible-instance-variables ,@slot-names)
2192 #+Genera
2193 (:readable-instance-variables ,@slot-names))
2194 ,(when reporter ;; when no reporter, parent's is inherited
2195 `(zl:defmethod #-Genera (,name :report)
2196 #+Genera (dbg:report ,name) (stream)
2197 ,(if (stringp reporter)
2198 `(write-string ,reporter stream)
2199 `(,reporter global:self stream))
2200 global:self))
2201 (zl:compile-flavor-methods ,name)
2202 ,(when documentation
2203 `(setf (documentation name 'type) ,documentation))
2204 ',name)))
2205
2206 #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2207 (zl:defflavor x-error () (global:error))
2208
2209 #+(and Genera (not clx-ansi-common-lisp))
2210 (scl:defflavor x-error
2211 ((dbg:proceed-types '(:continue)) ;
2212 continue-format-string)
2213 (sys:error)
2214 (:initable-instance-variables continue-format-string))
2215
2216 #+(and Genera (not clx-ansi-common-lisp))
2217 (scl:defmethod (scl:make-instance x-error) (&rest ignore)
2218 (when (not (sys:variable-boundp continue-format-string))
2219 (setf dbg:proceed-types (remove :continue dbg:proceed-types))))
2220
2221 #+(and Genera (not clx-ansi-common-lisp))
2222 (scl:defmethod (dbg:proceed x-error :continue) ()
2223 :continue)
2224
2225 #+(and Genera (not clx-ansi-common-lisp))
2226 (sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
2227 (format stream continue-format-string))
2228
2229 #+(or clx-ansi-common-lisp excl lcl3.0 CMU)
2230 (define-condition x-error (error) ())
2231
2232 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
2233 (defstruct x-error
2234 report-function)
2235
2236 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
2237 (defmacro define-condition (name parent-types &body options)
2238 ;; Define a structure that when printed displays an error message
2239 (flet ((reporter-for-condition (name)
2240 (xintern "." name '-reporter.)))
2241 (let ((slot-names
2242 (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2243 (pop options)))
2244 (documentation nil)
2245 (conc-name (concatenate 'string (string name) "-"))
2246 (reporter nil)
2247 (condition (gensym))
2248 (stream (gensym))
2249 (report-function (reporter-for-condition name)))
2250 (dolist (item options)
2251 (ecase (first item)
2252 (:documentation (setq documentation (second item)))
2253 (:conc-name (setq conc-name (string (second item))))
2254 (:report (setq reporter (second item)))))
2255 (unless reporter
2256 (setq report-function (reporter-for-condition (first parent-types))))
2257 `(within-definition (,name define-condition)
2258 (defstruct (,name (:conc-name ,(intern conc-name))
2259 (:print-function condition-print)
2260 (:include ,(first parent-types)
2261 (report-function ',report-function)))
2262 ,@slot-names)
2263 ,(when documentation
2264 `(setf (documentation name 'type) ,documentation))
2265 ,(when reporter
2266 `(defun ,report-function (,condition ,stream)
2267 ,(if (stringp reporter)
2268 `(write-string ,reporter ,stream)
2269 `(,reporter ,condition ,stream))
2270 ,condition))
2271 ',name))))
2272
2273 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
2274 (defun condition-print (condition stream depth)
2275 (declare (type x-error condition)
2276 (type stream stream)
2277 (ignore depth))
2278 (if *print-escape*
2279 (print-unreadable-object (condition stream :type t))
2280 (funcall (x-error-report-function condition) condition stream))
2281 condition)
2282
2283 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
2284 (defun make-condition (type &rest slot-initializations)
2285 (declare (dynamic-extent slot-initializations))
2286 (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
2287 (symbol-package type))))
2288 (apply make-function slot-initializations)))
2289
2290 #-(or clx-ansi-common-lisp excl lcl3.0 CMU)
2291 (define-condition type-error (x-error)
2292 ((datum :reader type-error-datum :initarg :datum)
2293 (expected-type :reader type-error-expected-type :initarg :expected-type))
2294 (:report
2295 (lambda (condition stream)
2296 (format stream "~s isn't a ~a"
2297 (type-error-datum condition)
2298 (type-error-expected-type condition)))))
2299
2300
2301 ;;-----------------------------------------------------------------------------
2302 ;; HOST hacking
2303 ;;-----------------------------------------------------------------------------
2304
2305 #-(or explorer Genera Minima Allegro CMU)
2306 (defun host-address (host &optional (family :internet))
2307 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2308 ;; and cdr is a list of network address bytes.
2309 (declare (type stringable host)
2310 (type (or null (member :internet :decnet :chaos) card8) family))
2311 (declare (clx-values list))
2312 host family
2313 (error "HOST-ADDRESS not implemented yet."))
2314
2315 #+explorer
2316 (defun host-address (host &optional (family :internet))
2317 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2318 ;; and cdr is a list of network address bytes.
2319 (declare (type stringable host)
2320 (type (or null (member :internet :decnet :chaos) card8) family))
2321 (declare (clx-values list))
2322 (ecase family
2323 ((:internet nil 0)
2324 (let ((addr (ip:get-ip-address host)))
2325 (unless addr (error "~s isn't an internet host name" host))
2326 (list :internet
2327 (ldb (byte 8 24) addr)
2328 (ldb (byte 8 16) addr)
2329 (ldb (byte 8 8) addr)
2330 (ldb (byte 8 0) addr))))
2331 ((:chaos 2)
2332 (let ((addr (first (chaos:chaos-addresses host))))
2333 (unless addr (error "~s isn't a chaos host name" host))
2334 (list :chaos
2335 (ldb (byte 8 0) addr)
2336 (ldb (byte 8 8) addr))))))
2337
2338 #+Genera
2339 (defun host-address (host &optional (family :internet))
2340 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2341 ;; and cdr is a list of network address bytes.
2342 (declare (type stringable host)
2343 (type (or null (member :internet :decnet :chaos) card8) family))
2344 (declare (clx-values list))
2345 (setf host (string host))
2346 (let ((net-type (ecase family
2347 ((:internet nil 0) :internet)
2348 ((:DECnet 1) :dna)
2349 ((:chaos 2) :chaos))))
2350 (dolist (addr
2351 (sys:send (net:parse-host host) :network-addresses)
2352 (error "~S isn't a valid ~(~A~) host name" host family))
2353 (let ((network (car addr))
2354 (address (cadr addr)))
2355 (when (sys:send network :network-typep net-type)
2356 (return (ecase family
2357 ((:internet nil 0)
2358 (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
2359 (list :internet a b c d)))
2360 ((:DECnet 1)
2361 (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address)))
2362 ((:chaos 2)
2363 (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))
2364
2365 #+Minima
2366 (defun host-address (host &optional (family :internet))
2367 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2368 ;; and cdr is a list of network address bytes.
2369 (declare (type stringable host)
2370 (type (or null (member :internet :decnet :chaos) card8) family))
2371 (declare (clx-values list))
2372 (etypecase family
2373 ((:internet nil 0)
2374 (list* :internet
2375 (multiple-value-list
2376 (minima:ip-address-components (minima:parse-ip-address (string host))))))))
2377
2378 #+Allegro
2379 (defun host-address (host &optional (family :internet))
2380 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2381 ;; and cdr is a list of network address bytes.
2382 (declare (type stringable host)
2383 (type (or null (member :internet :decnet :chaos) card8) family))
2384 (declare (clx-values list))
2385 (labels ((no-host-error ()
2386 (error "Unknown host ~S" host))
2387 (no-address-error ()
2388 (error "Host ~S has no ~S address" host family)))
2389 (let ((hostent 0))
2390 (unwind-protect
2391 (progn
2392 (setf hostent (ipc::gethostbyname (string host)))
2393 (when (zerop hostent)
2394 (no-host-error))
2395 (ecase family
2396 ((:internet nil 0)
2397 (unless (= (ipc::hostent-addrtype hostent) 2)
2398 (no-address-error))
2399 (assert (= (ipc::hostent-length hostent) 4))
2400 (let ((addr (ipc::hostent-addr hostent)))
2401 (when (or (member comp::.target.
2402 '(:hp :sgi4d :sony :dec3100)
2403 :test #'eq)
2404 (probe-file "/lib/ld.so"))
2405 ;; BSD 4.3 based systems require an extra indirection
2406 (setq addr (si:memref-int addr 0 0 :unsigned-long)))
2407 (list :internet
2408 (si:memref-int addr 0 0 :unsigned-byte)
2409 (si:memref-int addr 1 0 :unsigned-byte)
2410 (si:memref-int addr 2 0 :unsigned-byte)
2411 (si:memref-int addr 3 0 :unsigned-byte))))))
2412 (ff:free-cstruct hostent)))))
2413
2414 #+CMU
2415 (defun host-address (host &optional (family :internet))
2416 ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2417 ;; and cdr is a list of network address bytes.
2418 (declare (type stringable host)
2419 (type (or null (member :internet :decnet :chaos) card8) family))
2420 (declare (clx-values list))
2421 (labels ((no-host-error ()
2422 (error "Unknown host ~S" host))
2423 (no-address-error ()
2424 (error "Host ~S has no ~S address" host family)))
2425 (let ((hostent (ext:lookup-host-entry (string host))))
2426 (when (not hostent)
2427 (no-host-error))
2428 (ecase family