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

Contents of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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