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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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