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

Diff of /src/clx/dependent.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11.2.1 by rtoy, Sat May 22 11:54:04 2004 UTC revision 1.18 by rtoy, Wed Jun 17 18:28:11 2009 UTC
# Line 17  Line 17 
17  ;;; Texas Instruments Incorporated provides this software "as is" without  ;;; Texas Instruments Incorporated provides this software "as is" without
18  ;;; express or implied warranty.  ;;; express or implied warranty.
19  ;;;  ;;;
20  (ext:file-comment  
21    "$Header$")  #+cmu
22    (ext:file-comment "$Id$")
23    
24  (in-package :xlib)  (in-package :xlib)
25    
26  (proclaim '(declaration array-register))  (proclaim '(declaration array-register))
27    
28    #+cmu
29  (setf (getf ext:*herald-items* :xlib)  (setf (getf ext:*herald-items* :xlib)
30        `("    CLX X Library " ,*version*))        `("    CLX X Library " ,*version*))
31    
32    
33  ;;; The size of the output buffer.  Must be a multiple of 4.  ;;; The size of the output buffer.  Must be a multiple of 4.
34  (defparameter *output-buffer-size* 8192)  (defparameter *output-buffer-size* 8192)
35    
36    #+explorer
37    (zwei:define-indentation event-case (1 1))
38    
39  ;;; Number of seconds to wait for a reply to a server request  ;;; Number of seconds to wait for a reply to a server request
40  (defparameter *reply-timeout* nil)  (defparameter *reply-timeout* nil)
41    
42  #-(or (not clx-little-endian))  #-(or clx-overlapping-arrays (not clx-little-endian))
43  (progn  (progn
44    (defconstant *word-0* 0)    (defconstant +word-0+ 0)
45    (defconstant *word-1* 1)    (defconstant +word-1+ 1)
46    
47    (defconstant *long-0* 0)    (defconstant +long-0+ 0)
48    (defconstant *long-1* 1)    (defconstant +long-1+ 1)
49    (defconstant *long-2* 2)    (defconstant +long-2+ 2)
50    (defconstant *long-3* 3))    (defconstant +long-3+ 3))
51    
52  #-(or clx-little-endian)  #-(or clx-overlapping-arrays clx-little-endian)
53  (progn  (progn
54    (defconstant *word-0* 1)    (defconstant +word-0+ 1)
55    (defconstant *word-1* 0)    (defconstant +word-1+ 0)
56    
57    (defconstant *long-0* 3)    (defconstant +long-0+ 3)
58    (defconstant *long-1* 2)    (defconstant +long-1+ 2)
59    (defconstant *long-2* 1)    (defconstant +long-2+ 1)
60    (defconstant *long-3* 0))    (defconstant +long-3+ 0))
61    
62  ;;; Set some compiler-options for often used code  ;;; Set some compiler-options for often used code
63    
64  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
65      (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3
66  (defconstant *buffer-speed* #+clx-debugging 1 #-clx-debugging 3      "Speed compiler option for buffer code.")
67    "Speed compiler option for buffer code.")    (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0
68  (defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0      "Safety compiler option for buffer code.")
69    "Safety compiler option for buffer code.")    (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1
70        "Debug compiler option for buffer code>")
71  (defun declare-bufmac ()    (defun declare-bufmac ()
72    `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))      `(declare (optimize
73                   (speed ,+buffer-speed+)
74  ;;; It's my impression that in lucid there's some way to make a declaration                 (safety ,+buffer-safety+)
75  ;;; called fast-entry or something that causes a function to not do some                 (debug ,+buffer-debug+))))
76  ;;; checking on args. Sadly, we have no lucid manuals here.  If such a    ;; It's my impression that in lucid there's some way to make a
77  ;;; declaration is available, it would be a good idea to make it here when    ;; declaration called fast-entry or something that causes a function
78  ;;; *buffer-speed* is 3 and *buffer-safety* is 0.    ;; to not do some checking on args. Sadly, we have no lucid manuals
79  (defun declare-buffun ()    ;; here.  If such a declaration is available, it would be a good
80    #+clx-debugging    ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+
81    '(declare (optimize (speed 1) (safety 1)))    ;; is 0.
82    #-clx-debugging    (defun declare-buffun ()
83    `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))      `(declare (optimize
84                   (speed ,+buffer-speed+)
85  )                 (safety ,+buffer-safety+)
86                   (debug ,+buffer-debug+)))))
87    
88  (declaim (inline card8->int8 int8->card8  (declaim (inline card8->int8 int8->card8
89                   card16->int16 int16->card16                   card16->int16 int16->card16
90                   card32->int32 int32->card32))                   card32->int32 int32->card32))
91    
92    #-Genera
93  (progn  (progn
94    
95  (defun card8->int8 (x)  (defun card8->int8 (x)
# Line 129  Line 136 
136    
137  )  )
138    
139  (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))  #+Genera
140    (progn
141    
142    (defun card8->int8 (x)
143      (declare lt:(side-effects simple reducible))
144      (if (logbitp 7 x) (- x #x100) x))
145    
146    (defun int8->card8 (x)
147      (declare lt:(side-effects simple reducible))
148      (ldb (byte 8 0) x))
149    
150    (defun card16->int16 (x)
151      (declare lt:(side-effects simple reducible))
152      (if (logbitp 15 x) (- x #x10000) x))
153    
154    (defun int16->card16 (x)
155      (declare lt:(side-effects simple reducible))
156      (ldb (byte 16 0) x))
157    
158    (defun card32->int32 (x)
159      (declare lt:(side-effects simple reducible))
160      (sys:%logldb (byte 32 0) x))
161    
162    (defun int32->card32 (x)
163      (declare lt:(side-effects simple reducible))
164      (ldb (byte 32 0) x))
165    
166    )
167    
168    (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
169    
170    #-(or Genera lcl3.0 excl)
171  (progn  (progn
172    
173  (defun aref-card8 (a i)  (defun aref-card8 (a i)
# Line 164  Line 200 
200    
201  )  )
202    
203    #+Genera
204    (progn
205    
206    (defun aref-card8 (a i)
207      (aref a i))
208    
209    (defun aset-card8 (v a i)
210      (zl:aset v a i))
211    
212    (defun aref-int8 (a i)
213      (card8->int8 (aref a i)))
214    
215    (defun aset-int8 (v a i)
216      (zl:aset (int8->card8 v) a i))
217    
218    )
219    
220    #+(or excl lcl3.0 clx-overlapping-arrays)
221    (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
222                     aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
223    
224    #+(and clx-overlapping-arrays Genera)
225    (progn
226    
227    (defun aref-card16 (a i)
228      (aref a i))
229    
230    (defun aset-card16 (v a i)
231      (zl:aset v a i))
232    
233    (defun aref-int16 (a i)
234      (card16->int16 (aref a i)))
235    
236    (defun aset-int16 (v a i)
237      (zl:aset (int16->card16 v) a i)
238      v)
239    
240    (defun aref-card32 (a i)
241      (int32->card32 (aref a i)))
242    
243    (defun aset-card32 (v a i)
244      (zl:aset (card32->int32 v) a i))
245    
246    (defun aref-int32 (a i) (aref a i))
247    
248    (defun aset-int32 (v a i)
249      (zl:aset v a i))
250    
251    (defun aref-card29 (a i)
252      (aref a i))
253    
254    (defun aset-card29 (v a i)
255      (zl:aset v a i))
256    
257    )
258    
259    #+(and clx-overlapping-arrays (not Genera))
260    (progn
261    
262    (defun aref-card16 (a i)
263      (aref a i))
264    
265    (defun aset-card16 (v a i)
266      (setf (aref a i) v))
267    
268    (defun aref-int16 (a i)
269      (card16->int16 (aref a i)))
270    
271    (defun aset-int16 (v a i)
272      (setf (aref a i) (int16->card16 v))
273      v)
274    
275    (defun aref-card32 (a i)
276      (aref a i))
277    
278    (defun aset-card32 (v a i)
279      (setf (aref a i) v))
280    
281    (defun aref-int32 (a i)
282      (card32->int32 (aref a i)))
283    
284    (defun aset-int32 (v a i)
285      (setf (aref a i) (int32->card32 v))
286      v)
287    
288    (defun aref-card29 (a i)
289      (aref a i))
290    
291    (defun aset-card29 (v a i)
292      (setf (aref a i) v))
293    
294    )
295    
296    #+excl
297    (progn
298    
299    (defun aref-card8 (a i)
300      (declare (type buffer-bytes a)
301               (type array-index i))
302      (declare (clx-values card8))
303      #.(declare-buffun)
304      (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
305                             :unsigned-byte)))
306    
307    (defun aset-card8 (v a i)
308      (declare (type card8 v)
309               (type buffer-bytes a)
310               (type array-index i))
311      #.(declare-buffun)
312      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
313                        :unsigned-byte) v))
314    
315    (defun aref-int8 (a i)
316      (declare (type buffer-bytes a)
317               (type array-index i))
318      (declare (clx-values int8))
319      #.(declare-buffun)
320      (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
321                            :signed-byte)))
322    
323    (defun aset-int8 (v a i)
324      (declare (type int8 v)
325               (type buffer-bytes a)
326               (type array-index i))
327      #.(declare-buffun)
328      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
329                        :signed-byte) v))
330    
331    (defun aref-card16 (a i)
332      (declare (type buffer-bytes a)
333               (type array-index i))
334      (declare (clx-values card16))
335      #.(declare-buffun)
336      (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
337                              :unsigned-word)))
338    
339    (defun aset-card16 (v a i)
340      (declare (type card16 v)
341               (type buffer-bytes a)
342               (type array-index i))
343      #.(declare-buffun)
344      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
345                        :unsigned-word) v))
346    
347    (defun aref-int16 (a i)
348      (declare (type buffer-bytes a)
349               (type array-index i))
350      (declare (clx-values int16))
351      #.(declare-buffun)
352      (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
353                             :signed-word)))
354    
355    (defun aset-int16 (v a i)
356      (declare (type int16 v)
357               (type buffer-bytes a)
358               (type array-index i))
359      #.(declare-buffun)
360      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
361                        :signed-word) v))
362    
363    (defun aref-card32 (a i)
364      (declare (type buffer-bytes a)
365               (type array-index i))
366      (declare (clx-values card32))
367      #.(declare-buffun)
368      (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
369                              :unsigned-long)))
370    
371    (defun aset-card32 (v a i)
372      (declare (type card32 v)
373               (type buffer-bytes a)
374               (type array-index i))
375      #.(declare-buffun)
376      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
377                        :unsigned-long) v))
378    
379    (defun aref-int32 (a i)
380      (declare (type buffer-bytes a)
381               (type array-index i))
382      (declare (clx-values int32))
383      #.(declare-buffun)
384      (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
385                             :signed-long)))
386    
387    (defun aset-int32 (v a i)
388      (declare (type int32 v)
389               (type buffer-bytes a)
390               (type array-index i))
391      #.(declare-buffun)
392      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
393                        :signed-long) v))
394    
395    (defun aref-card29 (a i)
396      (declare (type buffer-bytes a)
397               (type array-index i))
398      (declare (clx-values card29))
399      #.(declare-buffun)
400      (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
401                              :unsigned-long)))
402    
403    (defun aset-card29 (v a i)
404      (declare (type card29 v)
405               (type buffer-bytes a)
406               (type array-index i))
407      #.(declare-buffun)
408      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
409                        :unsigned-long) v))
410    
411    )
412    
413    #+lcl3.0
414    (progn
415    
416    (defun aref-card8 (a i)
417      (declare (type buffer-bytes a)
418               (type array-index i)
419               (clx-values card8))
420      #.(declare-buffun)
421      (the card8 (lucid::%svref-8bit a i)))
422    
423    (defun aset-card8 (v a i)
424      (declare (type card8 v)
425               (type buffer-bytes a)
426               (type array-index i))
427      #.(declare-buffun)
428      (setf (lucid::%svref-8bit a i) v))
429    
430    (defun aref-int8 (a i)
431      (declare (type buffer-bytes a)
432               (type array-index i)
433               (clx-values int8))
434      #.(declare-buffun)
435      (the int8 (lucid::%svref-signed-8bit a i)))
436    
437    (defun aset-int8 (v a i)
438      (declare (type int8 v)
439               (type buffer-bytes a)
440               (type array-index i))
441      #.(declare-buffun)
442      (setf (lucid::%svref-signed-8bit a i) v))
443    
444    (defun aref-card16 (a i)
445      (declare (type buffer-bytes a)
446               (type array-index i)
447               (clx-values card16))
448      #.(declare-buffun)
449      (the card16 (lucid::%svref-16bit a (index-ash i -1))))
450    
451    (defun aset-card16 (v a i)
452      (declare (type card16 v)
453               (type buffer-bytes a)
454               (type array-index i))
455      #.(declare-buffun)
456      (setf (lucid::%svref-16bit a (index-ash i -1)) v))
457    
458    (defun aref-int16 (a i)
459      (declare (type buffer-bytes a)
460               (type array-index i)
461               (clx-values int16))
462      #.(declare-buffun)
463      (the int16 (lucid::%svref-signed-16bit a (index-ash i -1))))
464    
465    (defun aset-int16 (v a i)
466      (declare (type int16 v)
467               (type buffer-bytes a)
468               (type array-index i))
469      #.(declare-buffun)
470      (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v))
471    
472    (defun aref-card32 (a i)
473      (declare (type buffer-bytes a)
474               (type array-index i)
475               (clx-values card32))
476      #.(declare-buffun)
477      (the card32 (lucid::%svref-32bit a (index-ash i -2))))
478    
479    (defun aset-card32 (v a i)
480      (declare (type card32 v)
481               (type buffer-bytes a)
482               (type array-index i))
483      #.(declare-buffun)
484      (setf (lucid::%svref-32bit a (index-ash i -2)) v))
485    
486    (defun aref-int32 (a i)
487      (declare (type buffer-bytes a)
488               (type array-index i)
489               (clx-values int32))
490      #.(declare-buffun)
491      (the int32 (lucid::%svref-signed-32bit a (index-ash i -2))))
492    
493    (defun aset-int32 (v a i)
494      (declare (type int32 v)
495               (type buffer-bytes a)
496               (type array-index i))
497      #.(declare-buffun)
498      (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v))
499    
500    (defun aref-card29 (a i)
501      (declare (type buffer-bytes a)
502               (type array-index i)
503               (clx-values card29))
504      #.(declare-buffun)
505      (the card29 (lucid::%svref-32bit a (index-ash i -2))))
506    
507    (defun aset-card29 (v a i)
508      (declare (type card29 v)
509               (type buffer-bytes a)
510               (type array-index i))
511      #.(declare-buffun)
512      (setf (lucid::%svref-32bit a (index-ash i -2)) v))
513    
514    )
515    
516    
517    
518    #-(or excl lcl3.0 clx-overlapping-arrays)
519  (progn  (progn
520    
521  (defun aref-card16 (a i)  (defun aref-card16 (a i)
# Line 174  Line 525 
525    #.(declare-buffun)    #.(declare-buffun)
526    (the card16    (the card16
527         (logior (the card16         (logior (the card16
528                      (ash (the card8 (aref a (index+ i *word-1*))) 8))                      (ash (the card8 (aref a (index+ i +word-1+))) 8))
529                 (the card8                 (the card8
530                      (aref a (index+ i *word-0*))))))                      (aref a (index+ i +word-0+))))))
531    
532  (defun aset-card16 (v a i)  (defun aset-card16 (v a i)
533    (declare (type card16 v)    (declare (type card16 v)
534             (type buffer-bytes a)             (type buffer-bytes a)
535             (type array-index i))             (type array-index i))
536    #.(declare-buffun)    #.(declare-buffun)
537    (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))    (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v))
538          (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))          (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v)))
539    v)    v)
540    
541  (defun aref-int16 (a i)  (defun aref-int16 (a i)
# Line 194  Line 545 
545    #.(declare-buffun)    #.(declare-buffun)
546    (the int16    (the int16
547         (logior (the int16         (logior (the int16
548                      (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))                      (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8))
549                 (the card8                 (the card8
550                      (aref a (index+ i *word-0*))))))                      (aref a (index+ i +word-0+))))))
551    
552  (defun aset-int16 (v a i)  (defun aset-int16 (v a i)
553    (declare (type int16 v)    (declare (type int16 v)
554             (type buffer-bytes a)             (type buffer-bytes a)
555             (type array-index i))             (type array-index i))
556    #.(declare-buffun)    #.(declare-buffun)
557    (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))    (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v))
558          (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))          (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v)))
559    v)    v)
560    
561  (defun aref-card32 (a i)  (defun aref-card32 (a i)
# Line 214  Line 565 
565    #.(declare-buffun)    #.(declare-buffun)
566    (the card32    (the card32
567         (logior (the card32         (logior (the card32
568                      (ash (the card8 (aref a (index+ i *long-3*))) 24))                      (ash (the card8 (aref a (index+ i +long-3+))) 24))
569                 (the card29                 (the card29
570                      (ash (the card8 (aref a (index+ i *long-2*))) 16))                      (ash (the card8 (aref a (index+ i +long-2+))) 16))
571                 (the card16                 (the card16
572                      (ash (the card8 (aref a (index+ i *long-1*))) 8))                      (ash (the card8 (aref a (index+ i +long-1+))) 8))
573                 (the card8                 (the card8
574                      (aref a (index+ i *long-0*))))))                      (aref a (index+ i +long-0+))))))
575    
576  (defun aset-card32 (v a i)  (defun aset-card32 (v a i)
577    (declare (type card32 v)    (declare (type card32 v)
578             (type buffer-bytes a)             (type buffer-bytes a)
579             (type array-index i))             (type array-index i))
580    #.(declare-buffun)    #.(declare-buffun)
581    (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))    (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v))
582          (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))          (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v))
583          (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))          (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v))
584          (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))          (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v)))
585    v)    v)
586    
587  (defun aref-int32 (a i)  (defun aref-int32 (a i)
# Line 240  Line 591 
591    #.(declare-buffun)    #.(declare-buffun)
592    (the int32    (the int32
593         (logior (the int32         (logior (the int32
594                      (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))                      (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24))
595                 (the card29                 (the card29
596                      (ash (the card8 (aref a (index+ i *long-2*))) 16))                      (ash (the card8 (aref a (index+ i +long-2+))) 16))
597                 (the card16                 (the card16
598                      (ash (the card8 (aref a (index+ i *long-1*))) 8))                      (ash (the card8 (aref a (index+ i +long-1+))) 8))
599                 (the card8                 (the card8
600                      (aref a (index+ i *long-0*))))))                      (aref a (index+ i +long-0+))))))
601    
602  (defun aset-int32 (v a i)  (defun aset-int32 (v a i)
603    (declare (type int32 v)    (declare (type int32 v)
604             (type buffer-bytes a)             (type buffer-bytes a)
605             (type array-index i))             (type array-index i))
606    #.(declare-buffun)    #.(declare-buffun)
607    (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))    (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v))
608          (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))          (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v))
609          (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))          (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v))
610          (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))          (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v)))
611    v)    v)
612    
613  (defun aref-card29 (a i)  (defun aref-card29 (a i)
# Line 266  Line 617 
617    #.(declare-buffun)    #.(declare-buffun)
618    (the card29    (the card29
619         (logior (the card29         (logior (the card29
620                      (ash (the card8 (aref a (index+ i *long-3*))) 24))                      (ash (the card8 (aref a (index+ i +long-3+))) 24))
621                 (the card29                 (the card29
622                      (ash (the card8 (aref a (index+ i *long-2*))) 16))                      (ash (the card8 (aref a (index+ i +long-2+))) 16))
623                 (the card16                 (the card16
624                      (ash (the card8 (aref a (index+ i *long-1*))) 8))                      (ash (the card8 (aref a (index+ i +long-1+))) 8))
625                 (the card8                 (the card8
626                      (aref a (index+ i *long-0*))))))                      (aref a (index+ i +long-0+))))))
627    
628  (defun aset-card29 (v a i)  (defun aset-card29 (v a i)
629    (declare (type card29 v)    (declare (type card29 v)
630             (type buffer-bytes a)             (type buffer-bytes a)
631             (type array-index i))             (type array-index i))
632    #.(declare-buffun)    #.(declare-buffun)
633    (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))    (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v))
634          (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))          (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v))
635          (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))          (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v))
636          (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))          (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v)))
637    v)    v)
638    
639  )  )
# Line 341  Line 692 
692    (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))    (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
693    
694    
695  #+cmu  #+(or cmu sbcl clisp) (progn
 (progn  
696    
697  ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI  ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
698  ;;; is irrational, there can't be a precise rational representation.  In  ;;; is irrational, there can't be a precise rational representation.  In
699  ;;; particular, the different float approximations will always be /=.  This  ;;; particular, the different float approximations will always be /=.  This
700  ;;; causes problems with type checking, because people might compute an  ;;; causes problems with type checking, because people might compute an
701  ;;; argument in any precision.  What we do is discard all the excess precision  ;;; argument in any precision.  What we do is discard all the excess precision
702  ;;; in the value, and see if the protocal encoding falls in the desired range  ;;; in the value, and see if the protocol encoding falls in the desired range
703  ;;; (64'ths of a degree.)  ;;; (64'ths of a degree.)
704  ;;;  ;;;
705  (deftype angle () '(satisfies anglep))  (deftype angle () '(satisfies anglep))
# Line 373  Line 723 
723    
724  (macrolet ((char-translators ()  (macrolet ((char-translators ()
725               (let ((alist               (let ((alist
726                       `(;; The normal ascii codes for the control characters.                       `(#-lispm
727                           ;; The normal ascii codes for the control characters.
728                         ,@`((#\Return . 13)                         ,@`((#\Return . 13)
729                             (#\Linefeed . 10)                             (#\Linefeed . 10)
730                             (#\Rubout . 127)                             (#\Rubout . 127)
# Line 382  Line 733 
733                             (#\Backspace . 8)                             (#\Backspace . 8)
734                             (#\Newline . 10)                             (#\Newline . 10)
735                             (#\Space . 32))                             (#\Space . 32))
736                           ;; One the lispm, #\Newline is #\Return, but we'd really like
737                           ;; #\Newline to translate to ascii code 10, so we swap the
738                           ;; Ascii codes for #\Return and #\Linefeed. We also provide
739                           ;; mappings from the counterparts of these control characters
740                           ;; so that the character mapping from the lisp machine
741                           ;; character set to ascii is invertible.
742                           #+lispm
743                           ,@`((#\Return . 10)   (,(code-char  10) . ,(char-code #\Return))
744                               (#\Linefeed . 13) (,(code-char  13) . ,(char-code #\Linefeed))
745                               (#\Rubout . 127)  (,(code-char 127) . ,(char-code #\Rubout))
746                               (#\Page . 12)     (,(code-char  12) . ,(char-code #\Page))
747                               (#\Tab . 9)       (,(code-char   9) . ,(char-code #\Tab))
748                               (#\Backspace . 8) (,(code-char   8) . ,(char-code #\Backspace))
749                               (#\Newline . 10)  (,(code-char  10) . ,(char-code #\Newline))
750                               (#\Space . 32)    (,(code-char  32) . ,(char-code #\Space)))
751                         ;; The rest of the common lisp charater set with the normal                         ;; The rest of the common lisp charater set with the normal
752                         ;; ascii codes for them.                         ;; ascii codes for them.
753                         (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)                         (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
# Line 435  Line 800 
800                                            (dolist (pair alist)                                            (dolist (pair alist)
801                                              (setf (aref array (cdr pair)) (car pair)))                                              (setf (aref array (cdr pair)) (car pair)))
802                                            array))                                            array))
803                             #-Genera
804                           (progn                           (progn
805                             (defun char->card8 (char)                             (defun char->card8 (char)
806                               (declare (type base-char char))                               (declare (type base-char char))
# Line 450  Line 816 
816                                              card8)                                              card8)
817                                        (error "Invalid CHAR code ~D." card8))))                                        (error "Invalid CHAR code ~D." card8))))
818                             )                             )
819                           (dotimes (i 256)                           #+Genera
820                             (progn
821                               (defun char->card8 (char)
822                                 (declare lt:(side-effects reader reducible))
823                                 (aref *char-to-card8-translation-table* (char-code char)))
824                               (defun card8->char (card8)
825                                 (declare lt:(side-effects reader reducible))
826                                 (aref *card8-to-char-translation-table* card8))
827                               )
828                             #-Minima
829                             (dotimes (i 256)
830                             (unless (= i (char->card8 (card8->char i)))                             (unless (= i (char->card8 (card8->char i)))
831                               (warn "The card8->char mapping is not invertible through char->card8.  Info:~%~S"                               (warn "The card8->char mapping is not invertible through char->card8.  Info:~%~S"
832                                     (list i                                     (list i
833                                           (card8->char i)                                           (card8->char i)
834                                           (char->card8 (card8->char i))))                                           (char->card8 (card8->char i))))
835                               (return nil)))                               (return nil)))
836                             #-Minima
837                           (dotimes (i (length *char-to-card8-translation-table*))                           (dotimes (i (length *char-to-card8-translation-table*))
838                             (let ((char (code-char i)))                             (let ((char (code-char i)))
839                               (unless (eql char (card8->char (char->card8 char)))                               (unless (eql char (card8->char (char->card8 char)))
# Line 489  Line 866 
866    
867  ;;; MAKE-PROCESS-LOCK: Creating a process lock.  ;;; MAKE-PROCESS-LOCK: Creating a process lock.
868    
869  #-mp  #-(or LispM excl Minima sbcl (and cmu mp))
870  (defun make-process-lock (name)  (defun make-process-lock (name)
871    (declare (ignore name))    (declare (ignore name))
872    nil)    nil)
873    
874  #+mp  #+excl
875    (defun make-process-lock (name)
876      (mp:make-process-lock :name name))
877    
878    #+(and LispM (not Genera))
879    (defun make-process-lock (name)
880      (vector nil name))
881    
882    #+Genera
883    (defun make-process-lock (name)
884      (process:make-lock name :flavor 'clx-lock))
885    
886    #+Minima
887    (defun make-process-lock (name)
888      (minima:make-lock name :recursive t))
889    
890    #+(and cmu mp)
891  (defun make-process-lock (name)  (defun make-process-lock (name)
892    (mp:make-lock name))    (mp:make-lock name))
893    
894    #+sbcl
895    (defun make-process-lock (name)
896      (sb-thread:make-mutex :name name))
897    
898  ;;; HOLDING-LOCK: Execute a body of code with a lock held.  ;;; HOLDING-LOCK: Execute a body of code with a lock held.
899    
900  ;;; The holding-lock macro takes a timeout keyword argument.  EVENT-LISTEN  ;;; The holding-lock macro takes a timeout keyword argument.  EVENT-LISTEN
# Line 506  Line 903 
903    
904  ;; If you're not sharing DISPLAY objects within a multi-processing  ;; If you're not sharing DISPLAY objects within a multi-processing
905  ;; shared-memory environment, this is sufficient  ;; shared-memory environment, this is sufficient
906  #-cmu  #-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) )
907  (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)  (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
908    (declare (ignore locator display whostate timeout))    (declare (ignore locator display whostate timeout))
909    `(progn ,@body))    `(progn ,@body))
# Line 520  Line 917 
917  ;;; display connection.  We inhibit GC notifications since display of them  ;;; display connection.  We inhibit GC notifications since display of them
918  ;;; could cause recursive entry into CLX.  ;;; could cause recursive entry into CLX.
919  ;;;  ;;;
920  #-mp  #+(and CMU (not mp))
921  (defmacro holding-lock ((locator display &optional whostate &key timeout)  (defmacro holding-lock ((locator display &optional whostate &key timeout)
922                          &body body)                          &body body)
923    `(let ((ext:*gc-verbose* nil)    `(let #+cmu((ext:*gc-verbose* nil)
924           (ext:*gc-inhibit-hook* nil)                (ext:*gc-inhibit-hook* nil)
925           (ext:*before-gc-hooks* nil)                (ext:*before-gc-hooks* nil)
926           (ext:*after-gc-hooks* nil))                (ext:*after-gc-hooks* nil))
927            #+sbcl()
928       ,locator ,display ,whostate ,timeout       ,locator ,display ,whostate ,timeout
929       (system:without-interrupts (progn ,@body))))       (system:without-interrupts (progn ,@body))))
930    
931  ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.  ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
932  ;;;  ;;;
933  #+mp  #+(and cmu mp)
934  (defmacro holding-lock ((lock display &optional (whostate "CLX wait")  (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
935                                &key timeout)                                &key timeout)
936                          &body body)                          &body body)
# Line 540  Line 938 
938    `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))    `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
939      ,@body))      ,@body))
940    
941    #+clisp
942    (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
943                                  &key timeout)
944                            &body body)
945      (declare (ignore lock display whostate timeout))
946      `(progn
947         ,@body))
948    
949    #+sbcl
950    (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
951                                  &key timeout)
952                            &body body)
953      ;; This macro is used by WITH-DISPLAY, which claims to be callable
954      ;; recursively.  So, had better use a recursive lock.
955      ;;
956      ;; FIXME: This is hideously ugly.  If WITH-TIMEOUT handled NIL
957      ;; timeouts...
958      (declare (ignore display whostate))
959      (if timeout
960          `(if ,timeout
961               (handler-case
962                   (sb-ext:with-timeout ,timeout
963                     (sb-thread:with-recursive-lock (,lock)
964                       ,@body))
965                 (sb-ext:timeout () nil))
966               (sb-thread:with-recursive-lock (,lock)
967                 ,@body))
968          `(sb-thread:with-recursive-lock (,lock)
969             ,@body)))
970    
971    #+Genera
972    (defmacro holding-lock ((locator display &optional whostate &key timeout)
973                            &body body)
974      (declare (ignore whostate))
975      `(process:with-lock (,locator :timeout ,timeout)
976         (let ((.debug-io. (buffer-debug-io ,display)))
977           (scl:let-if .debug-io. ((*debug-io* .debug-io.))
978             ,@body))))
979    
980    #+(and lispm (not Genera))
981    (defmacro holding-lock ((locator display &optional whostate &key timeout)
982                            &body body)
983      (declare (ignore display))
984      ;; This macro is for use in a multi-process environment.
985      (let ((lock (gensym))
986            (have-lock (gensym))
987            (timeo (gensym)))
988        `(let* ((,lock (zl:locf (svref ,locator 0)))
989                (,have-lock (eq (car ,lock) sys:current-process))
990                (,timeo ,timeout))
991           (unwind-protect
992               (when (cond (,have-lock)
993                           ((#+explorer si:%store-conditional
994                             #-explorer sys:store-conditional
995                             ,lock nil sys:current-process))
996                           ((null ,timeo)
997                            (sys:process-lock ,lock nil ,(or whostate "CLX Lock")))
998                           ((sys:process-wait-with-timeout
999                                ,(or whostate "CLX Lock") (round (* ,timeo 60.))
1000                              #'(lambda (lock process)
1001                                  (#+explorer si:%store-conditional
1002                                   #-explorer sys:store-conditional
1003                                   lock nil process))
1004                              ,lock sys:current-process)))
1005                 ,@body)
1006             (unless ,have-lock
1007               (#+explorer si:%store-conditional
1008                #-explorer sys:store-conditional
1009                ,lock sys:current-process nil))))))
1010    
1011    ;; Lucid has a process locking mechanism as well under release 3.0
1012    #+lcl3.0
1013    (defmacro holding-lock ((locator display &optional whostate &key timeout)
1014                            &body body)
1015      (declare (ignore display))
1016      (if timeout
1017          ;; Hair to support timeout.
1018          `(let ((.have-lock. (eq ,locator lcl:*current-process*))
1019                 (.timeout. ,timeout))
1020             (unwind-protect
1021                 (when (cond (.have-lock.)
1022                             ((conditional-store ,locator nil lcl:*current-process*))
1023                             ((null .timeout.)
1024                              (lcl:process-lock ,locator)
1025                              t)
1026                             ((lcl:process-wait-with-timeout ,whostate .timeout.
1027                                #'(lambda ()
1028                                    (conditional-store ,locator nil lcl:*current-process*))))
1029                             ;; abort the PROCESS-UNLOCK if actually timing out
1030                             (t
1031                              (setf .have-lock. :abort)
1032                              nil))
1033                   ,@body)
1034               (unless .have-lock.
1035                 (lcl:process-unlock ,locator))))
1036        `(lcl:with-process-lock (,locator)
1037           ,@body)))
1038    
1039    
1040    #+excl
1041    (defmacro holding-lock ((locator display &optional whostate &key timeout)
1042                            &body body)
1043      (declare (ignore display))
1044      `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)
1045         (unwind-protect
1046             (block .hl-doit.
1047               (when mp::*scheduler-stack-group* ; fast test for scheduler running
1048                 (setq .hl-lock. ,locator
1049                       .hl-curproc. mp::*current-process*)
1050                 (when (and .hl-curproc.    ; nil if in process-wait fun
1051                            (not (eq (mp::process-lock-locker .hl-lock.)
1052                                     .hl-curproc.)))
1053                   ;; Then we need to grab the lock.
1054                   ,(if timeout
1055                        `(if (not (mp::process-lock .hl-lock. .hl-curproc.
1056                                                    ,whostate ,timeout))
1057                             (return-from .hl-doit. nil))
1058                      `(mp::process-lock .hl-lock. .hl-curproc.
1059                                         ,@(when whostate `(,whostate))))
1060                   ;; There is an apparent race condition here.  However, there is
1061                   ;; no actual race condition -- our implementation of mp:process-
1062                   ;; lock guarantees that the lock will still be held when it
1063                   ;; returns, and no interrupt can happen between that and the
1064                   ;; execution of the next form.  -- jdi 2/27/91
1065                   (setq .hl-obtained-lock. t)))
1066               ,@body)
1067           (if (and .hl-obtained-lock.
1068                    ;; Note -- next form added to allow error handler inside
1069                    ;; body to unlock the lock prematurely if it knows that
1070                    ;; the current process cannot possibly continue but will
1071                    ;; throw out (or is it throw up?).
1072                    (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))
1073               (mp::process-unlock .hl-lock. .hl-curproc.)))))
1074    
1075    #+Minima
1076    (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
1077      `(holding-lock-1 #'(lambda () ,@body) ,locator ,display
1078                       ,@(and whostate `(:whostate ,whostate))
1079                       ,@(and timeout `(:timeout ,timeout))))
1080    
1081    #+Minima
1082    (defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout)
1083      (declare (dynamic-extent continuation))
1084      (declare (ignore display whostate timeout))
1085      (minima:with-lock (lock)
1086        (funcall continuation)))
1087    
1088  ;;; WITHOUT-ABORTS  ;;; WITHOUT-ABORTS
1089    
# Line 548  Line 1092 
1092  ;;; request writing and reply reading to ensure that requests are atomically  ;;; request writing and reply reading to ensure that requests are atomically
1093  ;;; written and replies are atomically read from the stream.  ;;; written and replies are atomically read from the stream.
1094    
1095    #-(or Genera excl lcl3.0)
1096  (defmacro without-aborts (&body body)  (defmacro without-aborts (&body body)
1097    `(progn ,@body))    `(progn ,@body))
1098    
1099    #+Genera
1100    (defmacro without-aborts (&body body)
1101      `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.")
1102         ,@body))
1103    
1104    #+excl
1105    (defmacro without-aborts (&body body)
1106      `(without-interrupts ,@body))
1107    
1108    #+lcl3.0
1109    (defmacro without-aborts (&body body)
1110      `(lcl:with-interruptions-inhibited ,@body))
1111    
1112  ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.  ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
1113  ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's  ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
1114  ;;; value changes.  ;;; value changes.
1115  #-mp  
1116    #-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp))
1117  (defun process-block (whostate predicate &rest predicate-args)  (defun process-block (whostate predicate &rest predicate-args)
1118    (declare (ignore whostate))    (declare (ignore whostate))
1119    (or (apply predicate predicate-args)    (or (apply predicate predicate-args)
1120        (error "Program tried to wait with no scheduler.")))        (error "Program tried to wait with no scheduler.")))
1121    
1122  #+mp  #+Genera
1123    (defun process-block (whostate predicate &rest predicate-args)
1124      (declare (type function predicate)
1125               #+clx-ansi-common-lisp
1126               (dynamic-extent predicate)
1127               #-clx-ansi-common-lisp
1128               (sys:downward-funarg predicate))
1129      (apply #'process:block-process whostate predicate predicate-args))
1130    
1131    #+(and lispm (not Genera))
1132    (defun process-block (whostate predicate &rest predicate-args)
1133      (declare (type function predicate)
1134               #+clx-ansi-common-lisp
1135               (dynamic-extent predicate)
1136               #-clx-ansi-common-lisp
1137               (sys:downward-funarg predicate))
1138      (apply #'global:process-wait whostate predicate predicate-args))
1139    
1140    #+excl
1141    (defun process-block (whostate predicate &rest predicate-args)
1142      (if mp::*scheduler-stack-group*
1143          (apply #'mp::process-wait whostate predicate predicate-args)
1144          (or (apply predicate predicate-args)
1145              (error "Program tried to wait with no scheduler."))))
1146    
1147    #+lcl3.0
1148    (defun process-block (whostate predicate &rest predicate-args)
1149      (declare (dynamic-extent predicate-args))
1150      (apply #'lcl:process-wait whostate predicate predicate-args))
1151    
1152    #+Minima
1153    (defun process-block (whostate predicate &rest predicate-args)
1154      (declare (type function predicate)
1155               (dynamic-extent predicate))
1156      (apply #'minima:process-wait whostate predicate predicate-args))
1157    
1158    #+(and cmu mp)
1159  (defun process-block (whostate predicate &rest predicate-args)  (defun process-block (whostate predicate &rest predicate-args)
1160    (declare (type function predicate))    (declare (type function predicate))
1161    (mp:process-wait whostate #'(lambda ()    (mp:process-wait whostate #'(lambda ()
1162                                  (apply predicate predicate-args))))                                  (apply predicate predicate-args))))
1163    
1164    #+(and sbcl sb-thread)
1165    (progn
1166      (declaim (inline yield))
1167      (defun yield ()
1168        (declare (optimize speed (safety 0)))
1169        (sb-alien:alien-funcall
1170         (sb-alien:extern-alien "sched_yield" (function sb-alien:int)))
1171        (values)))
1172    
1173    #+(and sbcl sb-thread)
1174    (defun process-block (whostate predicate &rest predicate-args)
1175      (declare (ignore whostate))
1176      (declare (type function predicate))
1177      (loop
1178       (when (apply predicate predicate-args)
1179         (return))
1180       (yield)))
1181    
1182    
1183    ;;; FIXME: the below implementation for threaded PROCESS-BLOCK using
1184    ;;; queues and condition variables might seem better, but in fact it
1185    ;;; turns out to make performance extremely suboptimal, at least as
1186    ;;; measured by McCLIM on linux 2.4 kernels.  -- CSR, 2003-11-10
1187    #+(or)
1188    (defvar *process-conditions* (make-hash-table))
1189    
1190    #+(or)
1191    (defun process-block (whostate predicate &rest predicate-args)
1192      (declare (ignore whostate))
1193      (declare (type function predicate))
1194      (let* ((pid (sb-thread:current-thread-id))
1195             (last (gethash  pid *process-conditions*))
1196             (lock
1197              (or (car last)
1198                  (sb-thread:make-mutex :name (format nil "lock ~A" pid))))
1199             (queue
1200              (or (cdr last)
1201                  (sb-thread:make-waitqueue :name (format nil "queue ~A" pid)))))
1202        (unless last
1203          (setf (gethash pid *process-conditions*) (cons lock queue)))
1204        (sb-thread:with-mutex (lock)
1205          (loop
1206           (when (apply predicate predicate-args) (return))
1207           (handler-case
1208               (sb-ext:with-timeout .5
1209                 (sb-thread:condition-wait queue lock))
1210             (sb-ext:timeout ()
1211               (format *trace-output* "thread ~A, process-block timed out~%"
1212                       (sb-thread:current-thread-id) )))))))
1213    
1214  ;;; PROCESS-WAKEUP: Check some other process' wait function.  ;;; PROCESS-WAKEUP: Check some other process' wait function.
1215    
1216  (declaim (inline process-wakeup))  (declaim (inline process-wakeup))
1217    
1218  #-mp  #-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp))
1219  (defun process-wakeup (process)  (defun process-wakeup (process)
1220    (declare (ignore process))    (declare (ignore process))
1221    nil)    nil)
1222    
1223  #+mp  #+excl
1224    (defun process-wakeup (process)
1225      (let ((curproc mp::*current-process*))
1226        (when (and curproc process)
1227          (unless (mp::process-p curproc)
1228            (error "~s is not a process" curproc))
1229          (unless (mp::process-p process)
1230            (error "~s is not a process" process))
1231          (if (> (mp::process-priority process) (mp::process-priority curproc))
1232              (mp::process-allow-schedule process)))))
1233    
1234    #+Genera
1235    (defun process-wakeup (process)
1236      (process:wakeup process))
1237    
1238    #+Minima
1239    (defun process-wakeup (process)
1240      (when process
1241        (minima:process-wakeup process)))
1242    
1243    #+(and cmu mp)
1244  (defun process-wakeup (process)  (defun process-wakeup (process)
1245    (declare (ignore process))    (declare (ignore process))
1246    (mp:process-yield))    (mp:process-yield))
1247    
1248    #+(and sb-thread sbcl)
1249    (defun process-wakeup (process)
1250      (declare (ignore process))
1251      (yield))
1252    #+(or)
1253    (defun process-wakeup (process)
1254      (declare (ignore process))
1255      (destructuring-bind (lock . queue)
1256          (gethash (sb-thread:current-thread-id) *process-conditions*
1257                   (cons nil nil))
1258        (declare (ignore lock))
1259        (when queue
1260          (sb-thread:condition-notify queue))))
1261    
1262    
1263  ;;; CURRENT-PROCESS: Return the current process object for input locking and  ;;; CURRENT-PROCESS: Return the current process object for input locking and
1264  ;;; for calling PROCESS-WAKEUP.  ;;; for calling PROCESS-WAKEUP.
1265    
# Line 587  Line 1267 
1267    
1268  ;;; Default return NIL, which is acceptable even if there is a scheduler.  ;;; Default return NIL, which is acceptable even if there is a scheduler.
1269    
1270  #-mp  #-(or lispm excl lcl3.0 sbcl Minima (and cmu mp))
1271  (defun current-process ()  (defun current-process ()
1272    nil)    nil)
1273    
1274  #+mp  #+lispm
1275    (defun current-process ()
1276      sys:current-process)
1277    
1278    #+excl
1279    (defun current-process ()
1280      (and mp::*scheduler-stack-group*
1281           mp::*current-process*))
1282    
1283    #+lcl3.0
1284    (defun current-process ()
1285      lcl:*current-process*)
1286    
1287    #+Minima
1288    (defun current-process ()
1289      (minima:current-process))
1290    
1291    #+(and cmu mp)
1292  (defun current-process ()  (defun current-process ()
1293    mp:*current-process*)    mp:*current-process*)
1294    
1295    #+sbcl
1296    (defun current-process ()
1297      sb-thread:*current-thread*)
1298    
1299  ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.  ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
1300  ;;  
1301    #-(or lispm excl lcl3.0 Minima cmu)
1302    (defmacro without-interrupts (&body body)
1303      `(progn ,@body))
1304    
1305    #+(and lispm (not Genera))
1306  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
1307    `(sys:without-interrupts ,@body))    `(sys:without-interrupts ,@body))
1308    
1309    #+Genera
1310    (defmacro without-interrupts (&body body)
1311      `(process:with-no-other-processes ,@body))
1312    
1313    #+LCL3.0
1314    (defmacro without-interrupts (&body body)
1315      `(lcl:with-scheduling-inhibited ,@body))
1316    
1317    #+Minima
1318    (defmacro without-interrupts (&body body)
1319      `(minima:with-no-other-processes ,@body))
1320    
1321    #+cmu
1322    (defmacro without-interrupts (&body body)
1323      `(system:without-interrupts ,@body))
1324    
1325    #+sbcl
1326    (defvar *without-interrupts-sic-lock*
1327      (sb-thread:make-mutex :name "lock simulating *without-interrupts*"))
1328    #+sbcl
1329    (defmacro without-interrupts (&body body)
1330      `(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*)
1331        ,@body))
1332    
1333  ;;; CONDITIONAL-STORE:  ;;; CONDITIONAL-STORE:
1334    
1335  ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.  ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
1336  ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.  ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
1337    #-sbcl
1338  (defmacro conditional-store (place old-value new-value)  (defmacro conditional-store (place old-value new-value)
1339    `(without-interrupts    `(without-interrupts
1340       (cond ((eq ,place ,old-value)       (cond ((eq ,place ,old-value)
1341              (setf ,place ,new-value)              (setf ,place ,new-value)
1342              t))))              t))))
1343    
1344    #+sbcl
1345    (progn
1346      (defvar *conditional-store-lock*
1347        (sb-thread:make-mutex :name "conditional store"))
1348      (defmacro conditional-store (place old-value new-value)
1349        `(sb-thread:with-mutex (*conditional-store-lock*)
1350           (cond ((eq ,place ,old-value)
1351                  (setf ,place ,new-value)
1352                  t)))))
1353    
1354  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
1355  ;;; IO Error Recovery  ;;; IO Error Recovery
1356  ;;;     All I/O operations are done within a WRAP-BUF-OUTPUT macro.  ;;;     All I/O operations are done within a WRAP-BUF-OUTPUT macro.
# Line 617  Line 1358 
1358  ;;;  ;;;
1359  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
1360    
1361    #-Genera
1362  (defmacro wrap-buf-output ((buffer) &body body)  (defmacro wrap-buf-output ((buffer) &body body)
1363    ;; Error recovery wrapper    ;; Error recovery wrapper
1364    `(unless (buffer-dead ,buffer)    `(unless (buffer-dead ,buffer)
1365       ,@body))       ,@body))
1366    
1367    #+Genera
1368    (defmacro wrap-buf-output ((buffer) &body body)
1369      ;; Error recovery wrapper
1370      `(let ((.buffer. ,buffer))
1371         (unless (buffer-dead .buffer.)
1372           (scl:condition-bind
1373             (((sys:network-error)
1374               #'(lambda (error)
1375                   (scl:condition-case ()
1376                        (funcall (buffer-close-function .buffer.) .buffer. :abort t)
1377                      (sys:network-error))
1378                   (setf (buffer-dead .buffer.) error)
1379                   (setf (buffer-output-stream .buffer.) nil)
1380                   (setf (buffer-input-stream .buffer.) nil)
1381                   nil)))
1382             ,@body))))
1383    
1384    #-Genera
1385  (defmacro wrap-buf-input ((buffer) &body body)  (defmacro wrap-buf-input ((buffer) &body body)
1386    (declare (ignore buffer))    (declare (ignore buffer))
1387    ;; Error recovery wrapper    ;; Error recovery wrapper
1388    `(progn ,@body))    `(progn ,@body))
1389    
1390    #+Genera
1391    (defmacro wrap-buf-input ((buffer) &body body)
1392      ;; Error recovery wrapper
1393      `(let ((.buffer. ,buffer))
1394         (scl:condition-bind
1395           (((sys:network-error)
1396             #'(lambda (error)
1397                 (scl:condition-case ()
1398                      (funcall (buffer-close-function .buffer.) .buffer. :abort t)
1399                    (sys:network-error))
1400                 (setf (buffer-dead .buffer.) error)
1401                 (setf (buffer-output-stream .buffer.) nil)
1402                 (setf (buffer-input-stream .buffer.) nil)
1403                 nil)))
1404           ,@body)))
1405    
1406    
1407  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
1408  ;;; System dependent IO primitives  ;;; System dependent IO primitives
# Line 634  Line 1410 
1410  ;;;     the stream to the server.  ;;;     the stream to the server.
1411  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
1412    
1413  ;;; OPEN-X-STREAM - create a stream for communicating to the  ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
1414  ;;; appropriate X server.  ;;; server
1415    
1416    #-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp)
1417    (defun open-x-stream (host display protocol)
1418      host display protocol ;; unused
1419      (error "OPEN-X-STREAM not implemented yet."))
1420    
1421    #+clisp
1422    (defun open-x-stream (host display protocol)
1423      (declare (ignore protocol)
1424               (type (integer 0) display))
1425      (let ((socket
1426             ;; are we dealing with a localhost?
1427             (when (or (string= host "")
1428                       (string= host "unix"))
1429               ;; ok, try to connect to a AF_UNIX domain socket
1430               (sys::make-socket-stream "" display))))
1431        (if socket
1432            socket
1433            ;; try to connect by hand
1434            (let ((host (host-address host)))
1435              (when host
1436                ;; Fixme: get a descent ip standard in CLX: a vector!
1437                (let ((ip (format nil
1438                                  "~{~D~^.~}"
1439                                  (rest host))))
1440                  (socket:socket-connect (+ 6000 display) ip
1441                                         :element-type '(unsigned-byte 8))))))))
1442    
1443    
1444    ;;; Genera:
1445    
1446    ;;; TCP and DNA are both layered products, so try to work with either one.
1447    
1448    #+Genera
1449    (when (fboundp 'tcp:add-tcp-port-for-protocol)
1450      (tcp:add-tcp-port-for-protocol :x-window-system 6000))
1451    
1452    #+Genera
1453    (when (fboundp 'dna:add-dna-contact-id-for-protocol)
1454      (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0"))
1455    
1456    #+Genera
1457    (net:define-protocol :x-window-system (:x-window-system :byte-stream)
1458      (:invoke-with-stream ((stream :characters nil :ascii-translation nil))
1459        stream))
1460    
1461    #+Genera
1462    (eval-when (compile)
1463      (compiler:function-defined 'tcp:open-tcp-stream)
1464      (compiler:function-defined 'dna:open-dna-bidirectional-stream))
1465    
1466    #+Genera
1467    (defun open-x-stream (host display protocol)
1468      (let ((host (net:parse-host host)))
1469        (if (or protocol (plusp display))
1470            ;; The protocol was specified or the display isn't 0, so we
1471            ;; can't use the Generic Network System.  If the protocol was
1472            ;; specified, then use that protocol, otherwise, blindly use
1473            ;; TCP.
1474            (ccase protocol
1475              ((:tcp nil)
1476               (tcp:open-tcp-stream
1477                 host (+ *x-tcp-port* display) nil
1478                 :direction :io
1479                 :characters nil
1480                 :ascii-translation nil))
1481              ((:dna)
1482               (dna:open-dna-bidirectional-stream
1483                 host (format nil "X$X~D" display)
1484                 :characters nil
1485                 :ascii-translation nil)))
1486          (let ((neti:*invoke-service-automatic-retry* t))
1487            (net:invoke-service-on-host :x-window-system host)))))
1488    
1489    #+explorer
1490    (defun open-x-stream (host display protocol)
1491      (declare (ignore protocol))
1492      (net:open-connection-on-medium
1493        (net:parse-host host)                       ;Host
1494        :byte-stream                                ;Medium
1495        "X11"                                       ;Logical contact name
1496        :stream-type :character-stream
1497        :direction :bidirectional
1498        :timeout-after-open nil
1499        :remote-port (+ *x-tcp-port* display)))
1500    
1501    #+explorer
1502    (net:define-logical-contact-name
1503      "X11"
1504      `((:local "X11")
1505        (:chaos "X11")
1506        (:nsp-stream "X11")
1507        (:tcp ,*x-tcp-port*)))
1508    
1509    #+lucid
1510  (defun open-x-stream (host display protocol)  (defun open-x-stream (host display protocol)
1511    (ecase protocol    protocol ;; unused
1512      ;; establish a TCP connection to the X11 server, which is    (let ((fd (connect-to-server host display)))
1513      ;; listening on port 6000 + display-number      (when (minusp fd)
1514      ((or :tcp nil)        (error "Failed to connect to server: ~A ~D" host display))
1515       (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display))))      (user::make-lisp-stream :input-handle fd
1516         (unless (plusp fd)                              :output-handle fd
1517           (error 'connection-failure                              :element-type 'unsigned-byte
1518                  :major-version *protocol-major-version*                              #-lcl3.0 :stream-type #-lcl3.0 :ephemeral)))
                 :minor-version *protocol-minor-version*  
                 :host host  
                 :display display  
                 :reason (format nil "Cannot connect to internet socket: ~S"  
                                 (unix:get-unix-error-msg))))  
        (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8))))  
      ;; establish a connection to the X11 server over a Unix socket  
     (:unix  
      (let ((path (make-pathname :directory '(:absolute "tmp" ".X11-unix")  
                                 :name (format nil "X~D" display))))  
        (unless (probe-file path)  
          (error 'connection-failure  
                 :major-version *protocol-major-version*  
                 :minor-version *protocol-minor-version*  
                 :host host  
                 :display display  
                 :reason (format nil "Unix socket ~s does not exist" path)))  
        (let ((fd (ext:connect-to-unix-socket (namestring path))))  
          (unless (plusp fd)  
            (error 'connection-failure  
                 :major-version *protocol-major-version*  
                 :minor-version *protocol-minor-version*  
                 :host host  
                 :display display  
                 :reason (format nil "Can't connect to unix socket: ~S"  
                                 (unix:get-unix-error-msg))))  
          (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8)))))))  
1519    
1520    #+(or kcl ibcl)
1521    (defun open-x-stream (host display protocol)
1522      protocol ;; unused
1523      (let ((stream (open-socket-stream host display)))
1524        (if (streamp stream)
1525            stream
1526          (error "Cannot connect to server: ~A:~D" host display))))
1527    
1528    #+excl
1529    ;;
1530    ;; Note that since we don't use the CL i/o facilities to do i/o, the display
1531    ;; input and output "stream" is really a file descriptor (fixnum).
1532    ;;
1533    (defun open-x-stream (host display protocol)
1534      (declare (ignore protocol));; unused
1535      (let ((fd (connect-to-server (string host) display)))
1536        (when (minusp fd)
1537          (error "Failed to connect to server: ~A ~D" host display))
1538        fd))
1539    
1540    #+Minima
1541    (defun open-x-stream (host display protocol)
1542      (declare (ignore protocol));; unused
1543      (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address
1544                                                      (cdr (host-address host)))
1545                              :foreign-port (+ *x-tcp-port* display)))
1546    
1547    #+CMU
1548    (defun open-x-stream (host display protocol)
1549      (let ((stream-fd
1550             (ecase protocol
1551               ;; establish a TCP connection to the X11 server, which is
1552               ;; listening on port 6000 + display-number
1553               ((:internet :tcp nil)
1554                (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display))))
1555                  (unless (plusp fd)
1556                    (error 'connection-failure
1557                           :major-version *protocol-major-version*
1558                           :minor-version *protocol-minor-version*
1559                           :host host
1560                           :display display
1561                           :reason (format nil "Cannot connect to internet socket: ~S"
1562                                           (unix:get-unix-error-msg))))
1563                  fd))
1564               ;; establish a connection to the X11 server over a Unix
1565               ;; socket.  (:|| comes from Darwin's weird DISPLAY
1566               ;; environment variable)
1567               ((:unix :local :||)
1568                (let ((path (unix-socket-path-from-host host display)))
1569                  (unless (probe-file path)
1570                    (error 'connection-failure
1571                           :major-version *protocol-major-version*
1572                           :minor-version *protocol-minor-version*
1573                           :host host
1574                           :display display
1575                           :reason (format nil "Unix socket ~s does not exist" path)))
1576                  (let ((fd (ext:connect-to-unix-socket (namestring path))))
1577                    (unless (plusp fd)
1578                      (error 'connection-failure
1579                             :major-version *protocol-major-version*
1580                             :minor-version *protocol-minor-version*
1581                             :host host
1582                             :display display
1583                             :reason (format nil "Can't connect to unix socket: ~S"
1584                                             (unix:get-unix-error-msg))))
1585                    fd))))))
1586        (system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8))))
1587    
1588    #+sbcl
1589    (defun open-x-stream (host display protocol)
1590      (declare (ignore protocol)
1591               (type (integer 0) display))
1592      (let ((local-socket-path (unix-socket-path-from-host host display)))
1593      (socket-make-stream
1594         (if local-socket-path
1595           (let ((s (make-instance 'local-socket :type :stream)))
1596               (socket-connect s local-socket-path)
1597             s)
1598           (let ((host (car (host-ent-addresses (get-host-by-name host)))))
1599             (when host
1600               (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
1601                 (socket-connect s host (+ 6000 display))
1602                 s))))
1603       :element-type '(unsigned-byte 8)
1604         :input t :output t :buffering :none)))
1605    
1606    #+ecl
1607    (defun open-x-stream (host display protocol)
1608      (declare (ignore protocol)
1609               (type (integer 0) display))
1610      (let (socket)
1611        (if (or (string= host "") (string= host "unix")) ; AF_UNIX doamin socket
1612            (sys::open-unix-socket-stream
1613             (format nil "~A~D" +X-unix-socket-path+ display))
1614            (si::open-client-stream host (+ 6000 display)))))
1615    
1616  ;;; BUFFER-READ-DEFAULT - read data from the X stream  ;;; BUFFER-READ-DEFAULT - read data from the X stream
1617    
1618    #+(or Genera explorer)
1619    (defun buffer-read-default (display vector start end timeout)
1620      ;; returns non-NIL if EOF encountered
1621      ;; Returns :TIMEOUT when timeout exceeded
1622      (declare (type display display)
1623               (type buffer-bytes vector)
1624               (type array-index start end)
1625               (type (or null (real 0 *)) timeout))
1626      #.(declare-buffun)
1627      (let ((stream (display-input-stream display)))
1628        (or (cond ((null stream))
1629                  ((funcall stream :listen) nil)
1630                  ((and timeout (= timeout 0)) :timeout)
1631                  ((buffer-input-wait-default display timeout)))
1632            (multiple-value-bind (ignore eofp)
1633                (funcall stream :string-in nil vector start end)
1634              eofp))))
1635    
1636    
1637    #+excl
1638    ;;
1639    ;; Rewritten 10/89 to not use foreign function interface to do I/O.
1640    ;;
1641    (defun buffer-read-default (display vector start end timeout)
1642      (declare (type display display)
1643               (type buffer-bytes vector)
1644               (type array-index start end)
1645               (type (or null (real 0 *)) timeout))
1646      #.(declare-buffun)
1647    
1648      (let* ((howmany (- end start))
1649             (fd (display-input-stream display)))
1650        (declare (type array-index howmany)
1651                 (fixnum fd))
1652        (or (cond ((fd-char-avail-p fd) nil)
1653                  ((and timeout (= timeout 0)) :timeout)
1654                  ((buffer-input-wait-default display timeout)))
1655            (fd-read-bytes fd vector start howmany))))
1656    
1657    
1658    #+lcl3.0
1659    (defmacro with-underlying-stream ((variable stream display direction) &body body)
1660      `(let ((,variable
1661              (or (getf (display-plist ,display) ',direction)
1662                  (setf (getf (display-plist ,display) ',direction)
1663                        (lucid::underlying-stream
1664                          ,stream ,(if (eq direction 'input) :input :output))))))
1665         ,@body))
1666    
1667    #+lcl3.0
1668    (defun buffer-read-default (display vector start end timeout)
1669      ;;Note that LISTEN must still be done on "slow stream" or the I/O system
1670      ;;gets confused.  But reading should be done from "fast stream" for speed.
1671      ;;We used to inhibit scheduling because there were races in Lucid's
1672      ;;multitasking system.  Empirical evidence suggests they may be gone now.
1673      ;;Should you decide you need to inhibit scheduling, do it around the
1674      ;;lcl:read-array.
1675      (declare (type display display)
1676               (type buffer-bytes vector)
1677               (type array-index start end)
1678               (type (or null (real 0 *)) timeout))
1679      #.(declare-buffun)
1680      (let ((stream (display-input-stream display)))
1681        (declare (type (or null stream) stream))
1682        (or (cond ((null stream))
1683                  ((listen stream) nil)
1684                  ((and timeout (= timeout 0)) :timeout)
1685                  ((buffer-input-wait-default display timeout)))
1686            (with-underlying-stream (stream stream display input)
1687              (eq (lcl:read-array stream vector start end nil :eof) :eof)))))
1688    
1689    #+Minima
1690    (defun buffer-read-default (display vector start end timeout)
1691      ;; returns non-NIL if EOF encountered
1692      ;; Returns :TIMEOUT when timeout exceeded
1693      (declare (type display display)
1694               (type buffer-bytes vector)
1695               (type array-index start end)
1696               (type (or null (real 0 *)) timeout))
1697      #.(declare-buffun)
1698      (let ((stream (display-input-stream display)))
1699        (or (cond ((null stream))
1700                  ((listen stream) nil)
1701                  ((and timeout (= timeout 0)) :timeout)
1702                  ((buffer-input-wait-default display timeout)))
1703            (eq :eof (minima:read-vector vector stream nil start end)))))
1704    
1705    ;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
1706  ;;;  ;;;
1707  ;;;    If timeout is 0, then we call LISTEN to see if there is any input.  ;;;    If timeout is 0, then we call LISTEN to see if there is any input.
1708  ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without  ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without
1709  ;;; first calling BUFFER-INPUT-WAIT-DEFAULT.  ;;; first calling BUFFER-INPUT-WAIT-DEFAULT.
1710  ;;;  ;;;
1711  #+CMU  #+(or CMU sbcl)
1712  (defun buffer-read-default (display vector start end timeout)  (defun buffer-read-default (display vector start end timeout)
1713    (declare (type display display)    (declare (type display display)
1714             (type buffer-bytes vector)             (type buffer-bytes vector)
# Line 691  Line 1719 
1719                (not (listen (display-input-stream display))))                (not (listen (display-input-stream display))))
1720           :timeout)           :timeout)
1721          (t          (t
1722           (system:read-n-bytes (display-input-stream display)           (#+cmu system:read-n-bytes
1723                                vector start (- end start))            #+sbcl sb-sys:read-n-bytes
1724              (display-input-stream display)
1725              vector start (- end start))
1726           nil)))           nil)))
1727    
1728    #+(or ecl clisp)
1729    (defun buffer-read-default (display vector start end timeout)
1730      (declare (type display display)
1731               (type buffer-bytes vector)
1732               (type array-index start end)
1733               (type (or null fixnum) timeout))
1734      #.(declare-buffun)
1735      (cond ((and (eql timeout 0)
1736                  (not (listen (display-input-stream display))))
1737             :timeout)
1738            (t
1739             (read-sequence vector
1740                            (display-input-stream display)
1741                            :start start
1742                            :end end)
1743             nil)))
1744    
1745  ;;; WARNING:  ;;; WARNING:
1746  ;;;     CLX performance will suffer if your lisp uses read-byte for  ;;;     CLX performance will suffer if your lisp uses read-byte for
1747  ;;;     receiving all data from the X Window System server.  ;;;     receiving all data from the X Window System server.
1748  ;;;     You are encouraged to write a specialized version of  ;;;     You are encouraged to write a specialized version of
1749  ;;;     buffer-read-default that does block transfers.  ;;;     buffer-read-default that does block transfers.
1750  #-(or CMU)  #-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp)
1751  (defun buffer-read-default (display vector start end timeout)  (defun buffer-read-default (display vector start end timeout)
1752    (declare (type display display)    (declare (type display display)
1753             (type buffer-bytes vector)             (type buffer-bytes vector)
# Line 725  Line 1771 
1771    
1772  ;;; BUFFER-WRITE-DEFAULT - write data to the X stream  ;;; BUFFER-WRITE-DEFAULT - write data to the X stream
1773    
1774    #+(or Genera explorer)
1775    (defun buffer-write-default (vector display start end)
1776      ;; The default buffer write function for use with common-lisp streams
1777      (declare (type buffer-bytes vector)
1778               (type display display)
1779               (type array-index start end))
1780      #.(declare-buffun)
1781      (let ((stream (display-output-stream display)))
1782        (declare (type (or null stream) stream))
1783        (unless (null stream)
1784          (write-string vector stream :start start :end end))))
1785    
1786    #+excl
1787    (defun buffer-write-default (vector display start end)
1788      (declare (type buffer-bytes vector)
1789               (type display display)
1790               (type array-index start end))
1791      #.(declare-buffun)
1792      (excl::filesys-write-bytes (display-output-stream display) vector start
1793                                 (- end start)))
1794    
1795    #+lcl3.0
1796    (defun buffer-write-default (vector display start end)
1797      ;;We used to inhibit scheduling because there were races in Lucid's
1798      ;;multitasking system.  Empirical evidence suggests they may be gone now.
1799      ;;Should you decide you need to inhibit scheduling, do it around the
1800      ;;lcl:write-array.
1801      (declare (type display display)
1802               (type buffer-bytes vector)
1803               (type array-index start end))
1804      #.(declare-buffun)
1805      (let ((stream (display-output-stream display)))
1806        (declare (type (or null stream) stream))
1807        (unless (null stream)
1808          (with-underlying-stream (stream stream display output)
1809            (lcl:write-array stream vector start end)))))
1810    
1811    #+Minima
1812    (defun buffer-write-default (vector display start end)
1813      ;; The default buffer write function for use with common-lisp streams
1814      (declare (type buffer-bytes vector)
1815               (type display display)
1816               (type array-index start end))
1817      #.(declare-buffun)
1818      (let ((stream (display-output-stream display)))
1819        (declare (type (or null stream) stream))
1820        (unless (null stream)
1821          (minima:write-vector vector stream start end))))
1822    
1823  #+CMU  #+CMU
1824  (defun buffer-write-default (vector display start end)  (defun buffer-write-default (vector display start end)
1825    (declare (type buffer-bytes vector)    (declare (type buffer-bytes vector)
# Line 734  Line 1829 
1829    (system:output-raw-bytes (display-output-stream display) vector start end)    (system:output-raw-bytes (display-output-stream display) vector start end)
1830    nil)    nil)
1831    
1832    #+(or sbcl ecl clisp)
1833    (defun buffer-write-default (vector display start end)
1834      (declare (type buffer-bytes vector)
1835               (type display display)
1836               (type array-index start end))
1837      #.(declare-buffun)
1838      (write-sequence vector (display-output-stream display) :start start :end end)
1839      nil)
1840    
1841  ;;; WARNING:  ;;; WARNING:
1842  ;;;     CLX performance will be severely degraded if your lisp uses  ;;;     CLX performance will be severely degraded if your lisp uses
1843  ;;;     write-byte to send all data to the X Window System server.  ;;;     write-byte to send all data to the X Window System server.
1844  ;;;     You are STRONGLY encouraged to write a specialized version  ;;;     You are STRONGLY encouraged to write a specialized version
1845  ;;;     of buffer-write-default that does block transfers.  ;;;     of buffer-write-default that does block transfers.
1846    
1847  #-(or CMU)  #-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp)
1848  (defun buffer-write-default (vector display start end)  (defun buffer-write-default (vector display start end)
1849    ;; The default buffer write function for use with common-lisp streams    ;; The default buffer write function for use with common-lisp streams
1850    (declare (type buffer-bytes vector)    (declare (type buffer-bytes vector)
# Line 756  Line 1860 
1860            (declare (type array-index index))            (declare (type array-index index))
1861            (write-byte (aref vector index) stream))))))            (write-byte (aref vector index) stream))))))
1862    
 #+CMU  
 (defun buffer-write-default (vector display start end)  
   (declare (type buffer-bytes vector)  
            (type display display)  
            (type array-index start end))  
   #.(declare-buffun)  
   (system:output-raw-bytes (display-output-stream display) vector start end)  
   nil)  
   
1863  ;;; buffer-force-output-default - force output to the X stream  ;;; buffer-force-output-default - force output to the X stream
1864    
1865    #+excl
1866    (defun buffer-force-output-default (display)
1867      ;; buffer-write-default does the actual writing.
1868      (declare (ignore display)))
1869    
1870    #-(or excl)
1871  (defun buffer-force-output-default (display)  (defun buffer-force-output-default (display)
1872    ;; The default buffer force-output function for use with common-lisp streams    ;; The default buffer force-output function for use with common-lisp streams
1873    (declare (type display display))    (declare (type display display))
# Line 777  Line 1878 
1878    
1879  ;;; BUFFER-CLOSE-DEFAULT - close the X stream  ;;; BUFFER-CLOSE-DEFAULT - close the X stream
1880    
1881    #+excl
1882    (defun buffer-close-default (display &key abort)
1883      ;; The default buffer close function for use with common-lisp streams
1884      (declare (type display display)
1885               (ignore abort))
1886      #.(declare-buffun)
1887      (excl::filesys-checking-close (display-output-stream display)))
1888    
1889    #-(or excl)
1890  (defun buffer-close-default (display &key abort)  (defun buffer-close-default (display &key abort)
1891    ;; The default buffer close function for use with common-lisp streams    ;; The default buffer close function for use with common-lisp streams
1892    (declare (type display display))    (declare (type display display))
# Line 794  Line 1904 
1904  ;;; The default implementation  ;;; The default implementation
1905    
1906  ;; Poll for input every *buffer-read-polling-time* SECONDS.  ;; Poll for input every *buffer-read-polling-time* SECONDS.
1907  #-(or CMU)  #-(or Genera explorer excl lcl3.0 CMU sbcl)
1908  (defparameter *buffer-read-polling-time* 0.5)  (defparameter *buffer-read-polling-time* 0.5)
1909    
1910  #-(or CMU)  #-(or Genera explorer excl lcl3.0 CMU sbcl clisp)
1911  (defun buffer-input-wait-default (display timeout)  (defun buffer-input-wait-default (display timeout)
1912    (declare (type display display)    (declare (type display display)
1913             (type (or null (real 0 *)) timeout))             (type (or null (real 0 *)) timeout))
# Line 821  Line 1931 
1931                   (return-from buffer-input-wait-default nil)))                   (return-from buffer-input-wait-default nil)))
1932               :timeout)))))               :timeout)))))
1933    
1934  #+CMU  #+(or CMU sbcl clisp)
1935    (defun buffer-input-wait-default (display timeout)
1936      (declare (type display display)
1937               (type (or null number) timeout))
1938      (let ((stream (display-input-stream display)))
1939        (declare (type (or null stream) stream))
1940        (cond ((null stream))
1941              ((listen stream) nil)
1942              ((eql timeout 0) :timeout)
1943              (t
1944               (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream)
1945                                                       :input timeout)
1946                   #+mp (mp:process-wait-until-fd-usable
1947                         (system:fd-stream-fd stream) :input timeout)
1948                   #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
1949                             (ext:socket-status stream (and timeout sec)
1950                                                (round usec 1d-6)))
1951                   #-(or sbcl mp clisp) (system:wait-until-fd-usable
1952                                   (system:fd-stream-fd stream) :input timeout)
1953                   nil
1954                   :timeout)))))
1955    
1956    #+Genera
1957    (defun buffer-input-wait-default (display timeout)
1958      (declare (type display display)
1959               (type (or null (real 0 *)) timeout))
1960      (declare (clx-values timeout))
1961      (let ((stream (display-input-stream display)))
1962        (declare (type (or null stream) stream))
1963        (cond ((null stream))
1964              ((scl:send stream :listen) nil)
1965              ((and timeout (= timeout 0)) :timeout)
1966              ((null timeout) (si:stream-input-block stream "CLX Input"))
1967              (t
1968               (scl:condition-bind ((neti:protocol-timeout
1969                                      #'(lambda (error)
1970                                          (when (eq stream (scl:send error :stream))
1971                                            (return-from buffer-input-wait-default :timeout)))))
1972                 (neti:with-stream-timeout (stream :input timeout)
1973                   (si:stream-input-block stream "CLX Input")))))
1974        nil))
1975    
1976    #+explorer
1977    (defun buffer-input-wait-default (display timeout)
1978      (declare (type display display)
1979               (type (or null (real 0 *)) timeout))
1980      (declare (clx-values timeout))
1981      (let ((stream (display-input-stream display)))
1982        (declare (type (or null stream) stream))
1983        (cond ((null stream))
1984              ((zl:send stream :listen) nil)
1985              ((and timeout (= timeout 0)) :timeout)
1986              ((null timeout)
1987               (si:process-wait "CLX Input" stream :listen))
1988              (t
1989               (unless (si:process-wait-with-timeout
1990                           "CLX Input" (round (* timeout 60.)) stream :listen)
1991                 (return-from buffer-input-wait-default :timeout))))
1992        nil))
1993    
1994    #+excl
1995    ;;
1996    ;; This is used so an 'eq' test may be used to find out whether or not we can
1997    ;; safely throw this process out of the CLX read loop.
1998    ;;
1999    (defparameter *read-whostate* "waiting for input from X server")
2000    
2001    ;;
2002    ;; Note that this function returns nil on error if the scheduler is running,
2003    ;; t on error if not.  This is ok since buffer-read will detect the error.
2004    ;;
2005    #+excl
2006  (defun buffer-input-wait-default (display timeout)  (defun buffer-input-wait-default (display timeout)
2007    (declare (type display display)    (declare (type display display)
2008             (type (or null number) timeout))             (type (or null (real 0 *)) timeout))
2009      (declare (clx-values timeout))
2010      (let ((fd (display-input-stream display)))
2011        (declare (fixnum fd))
2012        (when (>= fd 0)
2013          (cond ((fd-char-avail-p fd)
2014                 nil)
2015    
2016                ;; Otherwise no bytes were available on the socket
2017                ((and timeout (= timeout 0))
2018                 ;; If there aren't enough and timeout == 0, timeout.
2019                 :timeout)
2020    
2021                ;; If the scheduler is running let it do timeouts.
2022                (mp::*scheduler-stack-group*
2023                 #+allegro
2024                 (if (not
2025                      (mp:wait-for-input-available fd :whostate *read-whostate*
2026                                                   :wait-function #'fd-char-avail-p
2027                                                   :timeout timeout))
2028                     (return-from buffer-input-wait-default :timeout))
2029                 #-allegro
2030                 (mp::wait-for-input-available fd :whostate *read-whostate*
2031                                               :wait-function #'fd-char-avail-p))
2032    
2033                ;; Otherwise we have to handle timeouts by hand, and call select()
2034                ;; to block until input is available.  Note we don't really handle
2035                ;; the interaction of interrupts and (numberp timeout) here.  XX
2036                (t
2037                 (let ((res 0))
2038                   (declare (fixnum res))
2039                   (with-interrupt-checking-on
2040                    (loop
2041                      (setq res (fd-wait-for-input fd (if (null timeout) 0
2042                                                        (truncate timeout))))
2043                      (cond ((plusp res)    ; success
2044                             (return nil))
2045                            ((eq res 0)     ; timeout
2046                             (return :timeout))
2047                            ((eq res -1)    ; error
2048                             (return t))
2049                            ;; Otherwise we got an interrupt -- go around again.
2050                            )))))))))
2051    
2052    
2053    #+lcl3.0
2054    (defun buffer-input-wait-default (display timeout)
2055      (declare (type display display)
2056               (type (or null (real 0 *)) timeout)
2057               (clx-values timeout))
2058      #.(declare-buffun)
2059    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
2060      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
2061      (cond ((null stream))      (cond ((null stream))
2062            ((listen stream) nil)            ((listen stream) nil)
2063            ((eql timeout 0) :timeout)            ((and timeout (= timeout 0)) :timeout)
2064            (t            ((with-underlying-stream (stream stream display input)
2065             (if #-mp (system:wait-until-fd-usable (system:fd-stream-fd stream)               (lucid::waiting-for-input-from-stream stream
2066                                                   :input timeout)                 (lucid::with-io-unlocked
2067                 #+mp (mp:process-wait-until-fd-usable                   (if (null timeout)
2068                       (system:fd-stream-fd stream) :input timeout)                       (lcl:process-wait "CLX Input" #'listen stream)
2069                 nil                     (lcl:process-wait-with-timeout
2070                 :timeout)))))                       "CLX Input" timeout #'listen stream)))))
2071               nil)
2072              (:timeout))))
2073    
2074    
2075  ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the  ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
2076  ;;; buffer. This should never block, so it can be called from the scheduler.  ;;; buffer. This should never block, so it can be called from the scheduler.
2077    
2078  ;;; The default implementation is to just use listen.  ;;; The default implementation is to just use listen.
2079    #-(or excl)
2080  (defun buffer-listen-default (display)  (defun buffer-listen-default (display)
2081    (declare (type display display))    (declare (type display display))
2082    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
# Line 852  Line 2085 
2085          t          t
2086        (listen stream))))        (listen stream))))
2087    
2088    #+excl
2089    (defun buffer-listen-default (display)
2090      (declare (type display display))
2091      (let ((fd (display-input-stream display)))
2092        (declare (type fixnum fd))
2093        (if (= fd -1)
2094            t
2095          (fd-char-avail-p fd))))
2096    
2097    
2098  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
2099  ;;; System dependent speed hacks  ;;; System dependent speed hacks
# Line 863  Line 2105 
2105  ;; consing garbage, you may want to re-write this to allocate and  ;; consing garbage, you may want to re-write this to allocate and
2106  ;; initialize lists from a resource.  ;; initialize lists from a resource.
2107  ;;  ;;
2108    #-lispm
2109  (defmacro with-stack-list ((var &rest elements) &body body)  (defmacro with-stack-list ((var &rest elements) &body body)
2110    ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)    ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
2111    ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)    ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
# Line 870  Line 2113 
2113    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
2114    `(let ((,var (list ,@elements)))    `(let ((,var (list ,@elements)))
2115       (declare (type cons ,var)       (declare (type cons ,var)
2116                (dynamic-extent ,var))                #+clx-ansi-common-lisp (dynamic-extent ,var))
2117       ,@body))       ,@body))
2118    
2119    #-lispm
2120  (defmacro with-stack-list* ((var &rest elements) &body body)  (defmacro with-stack-list* ((var &rest elements) &body body)
2121    ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)    ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
2122    ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)    ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
# Line 880  Line 2124 
2124    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
2125    `(let ((,var (list* ,@elements)))    `(let ((,var (list* ,@elements)))
2126       (declare (type cons ,var)       (declare (type cons ,var)
2127                (dynamic-extent ,var))                #+clx-ansi-common-lisp (dynamic-extent ,var))
2128       ,@body))       ,@body))
2129    
2130  (declaim (inline buffer-replace))  (declaim (inline buffer-replace))
2131    
2132  #+cmu  #+lispm
2133    (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
2134      (declare (type vector buf1 buf2)
2135               (type array-index start1 end1 start2))
2136      (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))
2137    
2138    #+excl
2139    (defun buffer-replace (target-sequence source-sequence target-start
2140                                           target-end &optional (source-start 0))
2141      (declare (type buffer-bytes target-sequence source-sequence)
2142               (type array-index target-start target-end source-start)
2143               (optimize (speed 3) (safety 0)))
2144    
2145      (let ((source-end (length source-sequence)))
2146        (declare (type array-index source-end))
2147    
2148        (excl:if* (and (eq target-sequence source-sequence)
2149                       (> target-start source-start))
2150           then (let ((nelts (min (- target-end target-start)
2151                                  (- source-end source-start))))
2152                  (do ((target-index (+ target-start nelts -1) (1- target-index))
2153                       (source-index (+ source-start nelts -1) (1- source-index)))
2154                      ((= target-index (1- target-start)) target-sequence)
2155                    (declare (type array-index target-index source-index))
2156    
2157                    (setf (aref target-sequence target-index)
2158                      (aref source-sequence source-index))))
2159           else (do ((target-index target-start (1+ target-index))
2160                     (source-index source-start (1+ source-index)))
2161                    ((or (= target-index target-end) (= source-index source-end))
2162                     target-sequence)
2163                  (declare (type array-index target-index source-index))
2164    
2165                  (setf (aref target-sequence target-index)
2166                    (aref source-sequence source-index))))))
2167    
2168    #+cmu
2169  (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))  (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
2170    (declare (type buffer-bytes buf1 buf2)    (declare (type buffer-bytes buf1 buf2)
2171             (type array-index start1 end1 start2))             (type array-index start1 end1 start2))
2172    #.(declare-buffun)    #.(declare-buffun)
2173    (kernel:bit-bash-copy    (kernel:bit-bash-copy
2174     buf2 (+ (* start2 vm:byte-bits)     buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
2175             (* vm:vector-data-offset vm:word-bits))             (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits))
2176     buf1 (+ (* start1 vm:byte-bits)     buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
2177             (* vm:vector-data-offset vm:word-bits))             (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits))
2178     (* (- end1 start1) vm:byte-bits)))     (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)))
2179    
2180    #+lucid
2181    ;;;The compiler is *supposed* to optimize calls to replace, but in actual
2182    ;;;fact it does not.
2183    (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
2184      (declare (type buffer-bytes buf1 buf2)
2185               (type array-index start1 end1 start2))
2186      #.(declare-buffun)
2187      (let ((end2 (lucid::%simple-8bit-vector-length buf2)))
2188        (declare (type array-index end2))
2189        (lucid::simple-8bit-vector-replace-internal
2190          buf1 buf2 start1 end1 start2 end2)))
2191    
2192    #+(and clx-overlapping-arrays (not (or lispm excl)))
2193    (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
2194      (declare (type vector buf1 buf2)
2195               (type array-index start1 end1 start2))
2196      (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
2197    
2198  #-CMU  #-(or lispm lucid excl CMU clx-overlapping-arrays)
2199  (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))  (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
2200    (declare (type buffer-bytes buf1 buf2)    (declare (type buffer-bytes buf1 buf2)
2201             (type array-index start1 end1 start2))             (type array-index start1 end1 start2))
2202    (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))    (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
2203    
2204    #+ti
2205    (defun with-location-bindings (sys:&quote bindings &rest body)
2206      (do ((bindings bindings (cdr bindings)))
2207          ((null bindings)
2208           (sys:eval-body-as-progn body))
2209        (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))
2210                  (sys:*eval (cadar bindings)))))
2211    
2212    #+ti
2213    (compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)
2214      (let ((bindings (cadr form))
2215            (body (cddr form)))
2216        `(let ()
2217           ,@(loop for (accessor value) in bindings
2218                   collect `(si:bind (si:locf ,accessor) ,value))
2219           ,@body)))
2220    
2221    #+ti
2222    (defun (:property with-location-bindings compiler::cw-handler) (exp)
2223      (let* ((bindlist (mapcar #'compiler::cw-clause (second exp)))
2224             (body (compiler::cw-clause (cddr exp))))
2225        (and compiler::cw-return-expansion-flag
2226             (list* (first exp) bindlist body))))
2227    
2228    #+(and lispm (not ti))
2229    (defmacro with-location-bindings (bindings &body body)
2230      `(sys:letf* ,bindings ,@body))
2231    
2232    #+lispm
2233    (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
2234                                      &body body)
2235      ;; don't use svref on LHS because Symbolics didn't define locf for it
2236      (let* ((local-state (gensym))
2237             (bindings `(((aref ,local-state ,ts-index) 0))))       ; will become zero anyway
2238        (dolist (index indexes)
2239          (push `((aref ,local-state ,index) (svref ,saved-state ,index))
2240                bindings))
2241        `(let ((,local-state (gcontext-local-state ,gc)))
2242           (declare (type gcontext-state ,local-state))
2243           (unwind-protect
2244               (with-location-bindings ,bindings
2245                 ,@body)
2246             (setf (svref ,local-state ,ts-index) 0)
2247             (when ,temp-gc
2248               (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
2249             (deallocate-gcontext-state ,saved-state)))))
2250    
2251    #-lispm
2252  (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)  (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
2253                                    &body body)                                    &body body)
2254    (let ((local-state (gensym))    (let ((local-state (gensym))
# Line 945  Line 2291 
2291  ;;; should it also check for non-negative and less than 65536?  ;;; should it also check for non-negative and less than 65536?
2292  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
2293    
2294  ;; The *TYPE-CHECK?* constant controls how much error checking is done.  ;; The +TYPE-CHECK?+ constant controls how much error checking is done.
2295  ;; Possible values are:  ;; Possible values are:
2296  ;;    NIL      - Don't do any error checking  ;;    NIL      - Don't do any error checking
2297  ;;    t        - Do the equivalent of checktype on every argument  ;;    t        - Do the equivalent of checktype on every argument
# Line 954  Line 2300 
2300  ;;; This controls macro expansion, and isn't changable at run-time You will  ;;; This controls macro expansion, and isn't changable at run-time You will
2301  ;;; probably want to set this to nil if you want good performance at  ;;; probably want to set this to nil if you want good performance at
2302  ;;; production time.  ;;; production time.
2303  (defconstant *type-check?* #+clx-debugging t #-clx-debugging nil)  (defconstant +type-check?+
2304      #+(or Genera Minima CMU sbcl) nil
2305      #-(or Genera Minima CMU sbcl) t)
2306    
2307  ;; TYPE? is used to allow the code to do error checking at a different level from  ;; TYPE? is used to allow the code to do error checking at a different level from
2308  ;; the declarations.  It also does some optimizations for systems that don't have  ;; the declarations.  It also does some optimizations for systems that don't have
# Line 967  Line 2315 
2315  ;; dispatching, not just type checking.  -- Ram.  ;; dispatching, not just type checking.  -- Ram.
2316    
2317  (defmacro type? (object type)  (defmacro type? (object type)
2318    `(typep ,object ,type))    #+(or cmu sbcl clisp)
2319      `(typep ,object ,type)
2320      #-(or cmu sbcl clisp)
2321      (if (not (constantp type))
2322          `(typep ,object ,type)
2323        (progn
2324          (setq type (eval type))
2325          #+(or Genera explorer Minima)
2326          (if +type-check?+
2327              `(locally (declare (optimize safety)) (typep ,object ',type))
2328            `(typep ,object ',type))
2329          #-(or Genera explorer Minima)
2330          (let ((predicate (assoc type
2331                                  '((drawable drawable-p) (window window-p)
2332                                    (pixmap pixmap-p) (cursor cursor-p)
2333                                    (font font-p) (gcontext gcontext-p)
2334                                    (colormap colormap-p) (null null)
2335                                    (integer integerp)))))
2336            (cond (predicate
2337                   `(,(second predicate) ,object))
2338                  ((eq type 'generalized-boolean)
2339                   't)                      ; Everything is a generalized-boolean.
2340                  (+type-check?+
2341                   `(locally (declare (optimize safety)) (typep ,object ',type)))
2342                  (t
2343                   `(typep ,object ',type)))))))
2344    
2345  ;; X-TYPE-ERROR is the function called for type errors.  ;; X-TYPE-ERROR is the function called for type errors.
2346  ;; If you want lots of checking, but are concerned about code size,  ;; If you want lots of checking, but are concerned about code size,
# Line 996  Line 2369 
2369        (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)        (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)
2370        (apply #'x-error error-key :display display :error-key error-key key-vals)))        (apply #'x-error error-key :display display :error-key error-key key-vals)))
2371    
2372    #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2373    (defun x-error (condition &rest keyargs)
2374      (apply #'sys:signal condition keyargs))
2375    
2376    #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2377    (defun x-cerror (proceed-format-string condition &rest keyargs)
2378      (sys:signal (apply #'zl:make-condition condition keyargs)
2379                  :proceed-types proceed-format-string))
2380    
2381    #+(and Genera (not clx-ansi-common-lisp))
2382    (defun x-error (condition &rest keyargs)
2383      (declare (dbg:error-reporter))
2384      (apply #'sys:signal condition keyargs))
2385    
2386    #+(and Genera (not clx-ansi-common-lisp))
2387    (defun x-cerror (proceed-format-string condition &rest keyargs)
2388      (declare (dbg:error-reporter))
2389      (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))
2390    
2391    #+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp))
2392  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2393    (declare (dynamic-extent keyargs))    (declare (dynamic-extent keyargs))
2394    (apply #'error condition keyargs))    (apply #'error condition keyargs))
2395    
2396    #+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp)
2397  (defun x-cerror (proceed-format-string condition &rest keyargs)  (defun x-cerror (proceed-format-string condition &rest keyargs)
2398    (declare (dynamic-extent keyargs))    (declare (dynamic-extent keyargs))
2399    (apply #'cerror proceed-format-string condition keyargs))    (apply #'cerror proceed-format-string condition keyargs))
# Line 1013  Line 2407 
2407  ;;; descriptors, Mach messages, etc.) to come through one routine anyone can  ;;; descriptors, Mach messages, etc.) to come through one routine anyone can
2408  ;;; use to wait for input.  ;;; use to wait for input.
2409  ;;;  ;;;
2410  #+(and CMU (not mp))  #+(and CMU (not mp))
2411  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2412    (let ((condx (apply #'make-condition condition keyargs)))    (let ((condx (apply #'make-condition condition keyargs)))
2413      (when (eq condition 'closed-display)      (when (eq condition 'closed-display)
# Line 1022  Line 2416 
2416          (ext::disable-clx-event-handling disp)))          (ext::disable-clx-event-handling disp)))
2417      (error condx)))      (error condx)))
2418    
2419    #-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2420    (defun x-error (condition &rest keyargs)
2421      (error "X-Error: ~a"
2422             (princ-to-string (apply #'make-condition condition keyargs))))
2423    
2424    #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2425    (defun x-cerror (proceed-format-string condition &rest keyargs)
2426      (cerror proceed-format-string "X-Error: ~a"
2427             (princ-to-string (apply #'make-condition condition keyargs))))
2428    
2429    ;; version 15 of Pitman error handling defines the syntax for define-condition to be:
2430    ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]
2431    ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
2432    ;; or (:report exp)
2433    
2434    #+lcl3.0
2435    (defmacro define-condition (name parent-types &optional slots &rest args)
2436      `(lcl:define-condition
2437         ,name (,(first parent-types))
2438         ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2439                  slots)
2440         ,@args))
2441    
2442    #+(and excl (not clx-ansi-common-lisp))
2443    (defmacro define-condition (name parent-types &optional slots &rest args)
2444      `(excl::define-condition
2445         ,name (,(first parent-types))
2446         ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2447                  slots)
2448         ,@args))
2449    
2450    #+(and CMU (not clx-ansi-common-lisp))
2451    (defmacro define-condition (name parent-types &optional slots &rest args)
2452      `(common-lisp:define-condition
2453         ,name (,(first parent-types))
2454         ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2455                  slots)
2456         ,@args))
2457    
2458    #+(and lispm (not clx-ansi-common-lisp))
2459    (defmacro define-condition (name parent-types &body options)
2460      (let ((slot-names
2461              (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2462                      (pop options)))
2463            (documentation nil)
2464            (conc-name (concatenate 'string (string name) "-"))
2465            (reporter nil))
2466        (dolist (item options)
2467          (ecase (first item)
2468            (:documentation (setq documentation (second item)))
2469            (:conc-name (setq conc-name (string (second item))))
2470            (:report (setq reporter (second item)))))
2471        `(within-definition (,name define-condition)
2472           (zl:defflavor ,name ,slot-names ,parent-types
2473             :initable-instance-variables
2474             #-Genera
2475             (:accessor-prefix ,conc-name)
2476             #+Genera
2477             (:conc-name ,conc-name)
2478             #-Genera
2479             (:outside-accessible-instance-variables ,@slot-names)
2480             #+Genera
2481             (:readable-instance-variables ,@slot-names))
2482           ,(when reporter ;; when no reporter, parent's is inherited
2483              `(zl:defmethod #-Genera (,name :report)
2484                             #+Genera (dbg:report ,name) (stream)
2485                  ,(if (stringp reporter)
2486                       `(write-string ,reporter stream)
2487                     `(,reporter global:self stream))
2488                  global:self))
2489           (zl:compile-flavor-methods ,name)
2490           ,(when documentation
2491              `(setf (documentation name 'type) ,documentation))
2492           ',name)))
2493    
2494    #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2495    (zl:defflavor x-error () (global:error))
2496    
2497    #+(and Genera (not clx-ansi-common-lisp))
2498    (scl:defflavor x-error
2499            ((dbg:proceed-types '(:continue))       ;
2500             continue-format-string)
2501            (sys:error)
2502      (:initable-instance-variables continue-format-string))
2503    
2504    #+(and Genera (not clx-ansi-common-lisp))
2505    (scl:defmethod (scl:make-instance x-error) (&rest ignore)
2506      (when (not (sys:variable-boundp continue-format-string))
2507        (setf dbg:proceed-types (remove :continue dbg:proceed-types))))
2508    
2509    #+(and Genera (not clx-ansi-common-lisp))
2510    (scl:defmethod (dbg:proceed x-error :continue) ()
2511      :continue)
2512    
2513    #+(and Genera (not clx-ansi-common-lisp))
2514    (sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
2515      (format stream continue-format-string))
2516    
2517    #+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2518  (define-condition x-error (error) ())  (define-condition x-error (error) ())
2519    
2520    #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
2521    (defstruct x-error
2522      report-function)
2523    
2524    #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
2525    (defmacro define-condition (name parent-types &body options)
2526      ;; Define a structure that when printed displays an error message
2527      (flet ((reporter-for-condition (name)
2528               (xintern "." name '-reporter.)))
2529        (let ((slot-names
2530                (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2531                        (pop options)))
2532              (documentation nil)
2533              (conc-name (concatenate 'string (string name) "-"))
2534              (reporter nil)
2535              (condition (gensym))
2536              (stream (gensym))
2537              (report-function (reporter-for-condition name)))
2538          (dolist (item options)
2539            (ecase (first item)
2540              (:documentation (setq documentation (second item)))
2541              (:conc-name (setq conc-name (string (second item))))
2542              (:report (setq reporter (second item)))))
2543          (unless reporter
2544            (setq report-function (reporter-for-condition (first parent-types))))
2545          `(within-definition (,name define-condition)
2546             (defstruct (,name (:conc-name ,(intern conc-name))
2547                         (:print-function condition-print)
2548                         (:include ,(first parent-types)
2549                          (report-function ',report-function)))
2550               ,@slot-names)
2551             ,(when documentation
2552                `(setf (documentation name 'type) ,documentation))
2553             ,(when reporter
2554                `(defun ,report-function (,condition ,stream)
2555                   ,(if (stringp reporter)
2556                        `(write-string ,reporter ,stream)
2557                      `(,reporter ,condition ,stream))
2558                   ,condition))
2559             ',name))))
2560    
2561    #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2562    (defun condition-print (condition stream depth)
2563      (declare (type x-error condition)
2564               (type stream stream)
2565               (ignore depth))
2566      (if *print-escape*
2567          (print-unreadable-object (condition stream :type t))
2568        (funcall (x-error-report-function condition) condition stream))
2569      condition)
2570    
2571    #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2572    (defun make-condition (type &rest slot-initializations)
2573      (declare (dynamic-extent slot-initializations))
2574      (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
2575                                   (symbol-package type))))
2576        (apply make-function slot-initializations)))
2577    
2578    #-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2579    (define-condition type-error (x-error)
2580      ((datum :reader type-error-datum :initarg :datum)
2581       (expected-type :reader type-error-expected-type :initarg :expected-type))
2582      (:report
2583        (lambda (condition stream)
2584          (format stream "~s isn't a ~a"
2585                  (type-error-datum condition)
2586                  (type-error-expected-type condition)))))
2587    
2588    
2589  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2590  ;;  HOST hacking  ;;  HOST hacking
2591  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2592    
2593    #-(or explorer Genera Minima Allegro CMU sbcl ecl clisp)
2594    (defun host-address (host &optional (family :internet))
2595      ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2596      ;; and cdr is a list of network address bytes.
2597      (declare (type stringable host)
2598               (type (or null (member :internet :decnet :chaos) card8) family))
2599      (declare (clx-values list))
2600      host family
2601      (error "HOST-ADDRESS not implemented yet."))
2602    
2603    #+clisp
2604    (defun host-address (host &optional (family :internet))
2605      "Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2606      and cdr is a list of network address bytes."
2607      (declare (type stringable host)
2608               (type (or null (member :internet :decnet :chaos) card8) family))
2609      (declare (clx-values list))
2610      (labels ((no-host-error ()
2611                 (error "Unknown host ~S" host))
2612               (no-address-error ()
2613                 (error "Host ~S has no ~S address" host family)))
2614    
2615        (let ((hostent (posix::resolve-host-ipaddr (string host))))
2616          (when (not (posix::hostent-addr-list hostent))
2617            (no-host-error))
2618          (ecase family
2619            ((:internet nil 0)
2620             (unless (= (posix::hostent-addrtype hostent) 2)
2621               (no-address-error))
2622             (let ((addr (first (posix::hostent-addr-list hostent))))
2623               (etypecase addr
2624                 (integer
2625                  (list :internet
2626                        (ldb (byte 8 24) addr)
2627                        (ldb (byte 8 16) addr)
2628                        (ldb (byte 8  8) addr)
2629                        (ldb (byte 8  0) addr)))
2630                 (string
2631                  (let ((parts (read-from-string
2632                                (nsubstitute #\Space #\. (ext:string-concat
2633                                                          "(" addr ")")))))
2634                    (check-type parts (cons (unsigned-byte 8)
2635                                            (cons (unsigned-byte 8)
2636                                                  (cons (unsigned-byte 8)
2637                                                        (cons (unsigned-byte 8)
2638                                                              NULL)))))
2639                    (cons :internet parts))))))))))
2640    
2641    
2642    #+explorer
2643    (defun host-address (host &optional (family :internet))
2644      ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2645      ;; and cdr is a list of network address bytes.
2646      (declare (type stringable host)
2647               (type (or null (member :internet :decnet :chaos) card8) family))
2648      (declare (clx-values list))
2649      (ecase family
2650        ((:internet nil 0)
2651         (let ((addr (ip:get-ip-address host)))
2652           (unless addr (error "~s isn't an internet host name" host))
2653           (list :internet
2654                 (ldb (byte 8 24) addr)
2655                 (ldb (byte 8 16) addr)
2656                 (ldb (byte 8 8) addr)
2657                 (ldb (byte 8 0) addr))))
2658        ((:chaos 2)
2659         (let ((addr (first (chaos:chaos-addresses host))))
2660           (unless addr (error "~s isn't a chaos host name" host))
2661           (list :chaos
2662                 (ldb (byte 8 0) addr)
2663                 (ldb (byte 8 8) addr))))))
2664    
2665    #+Genera
2666    (defun host-address (host &optional (family :internet))
2667      ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2668      ;; and cdr is a list of network address bytes.
2669      (declare (type stringable host)
2670               (type (or null (member :internet :decnet :chaos) card8) family))
2671      (declare (clx-values list))
2672      (setf host (string host))
2673      (let ((net-type (ecase family
2674                        ((:internet nil 0) :internet)
2675                        ((:DECnet 1) :dna)
2676                        ((:chaos 2) :chaos))))
2677        (dolist (addr
2678                  (sys:send (net:parse-host host) :network-addresses)
2679                  (error "~S isn't a valid ~(~A~) host name" host family))
2680          (let ((network (car addr))
2681                (address (cadr addr)))
2682            (when (sys:send network :network-typep net-type)
2683              (return (ecase family
2684                        ((:internet nil 0)
2685                         (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
2686                           (list :internet a b c d)))
2687                        ((:DECnet 1)
2688                         (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address)))
2689                        ((:chaos 2)
2690                         (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))
2691    
2692    #+Minima
2693    (defun host-address (host &optional (family :internet))
2694      ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2695      ;; and cdr is a list of network address bytes.
2696      (declare (type stringable host)
2697               (type (or null (member :internet :decnet :chaos) card8) family))
2698      (declare (clx-values list))
2699      (etypecase family
2700        ((:internet nil 0)
2701          (list* :internet
2702                 (multiple-value-list
2703                   (minima:ip-address-components (minima:parse-ip-address (string host))))))))
2704    
2705    #+Allegro
2706    (defun host-address (host &optional (family :internet))
2707      ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2708      ;; and cdr is a list of network address bytes.
2709      (declare (type stringable host)
2710               (type (or null (member :internet :decnet :chaos) card8) family))
2711      (declare (clx-values list))
2712      (labels ((no-host-error ()
2713                 (error "Unknown host ~S" host))
2714               (no-address-error ()
2715                 (error "Host ~S has no ~S address" host family)))
2716        (let ((hostent 0))
2717          (unwind-protect
2718               (progn
2719                 (setf hostent (ipc::gethostbyname (string host)))
2720                 (when (zerop hostent)
2721                   (no-host-error))
2722                 (ecase family
2723                   ((:internet nil 0)
2724                    (unless (= (ipc::hostent-addrtype hostent) 2)
2725                      (no-address-error))
2726                    (assert (= (ipc::hostent-length hostent) 4))
2727                    (let ((addr (ipc::hostent-addr hostent)))
2728                       (when (or (member comp::.target.
2729                                         '(:hp :sgi4d :sony :dec3100)
2730                                         :test #'eq)
2731                                 (probe-file "/lib/ld.so"))
2732                         ;; BSD 4.3 based systems require an extra indirection
2733                         (setq addr (si:memref-int addr 0 0 :unsigned-long)))
2734                      (list :internet
2735                            (si:memref-int addr 0 0 :unsigned-byte)
2736                            (si:memref-int addr 1 0 :unsigned-byte)
2737                            (si:memref-int addr 2 0 :unsigned-byte)
2738                            (si:memref-int addr 3 0 :unsigned-byte))))))
2739            (ff:free-cstruct hostent)))))
2740    
2741    #+CMU
2742  (defun host-address (host &optional (family :internet))  (defun host-address (host &optional (family :internet))
2743    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2744    ;; and cdr is a list of network address bytes.    ;; and cdr is a list of network address bytes.
# Line 1048  Line 2756 
2756          ((:internet nil 0)          ((:internet nil 0)
2757           (unless (= (ext::host-entry-addr-type hostent) 2)           (unless (= (ext::host-entry-addr-type hostent) 2)
2758             (no-address-error))             (no-address-error))
2759           (let ((addr (first (ext::host-entry-addr-list hostent))))           (append (list :internet)
2760             (list :internet                   (let ((addr (first (ext::host-entry-addr-list hostent))))
2761                   (ldb (byte 8 24) addr)                          (list (ldb (byte 8 24) addr)
2762                   (ldb (byte 8 16) addr)                                (ldb (byte 8 16) addr)
2763                   (ldb (byte 8  8) addr)                                (ldb (byte 8  8) addr)
2764                   (ldb (byte 8  0) addr))))))))                                (ldb (byte 8  0) addr)))))))))
2765    
2766    ;#+sbcl
2767    ;(require :sockets)
2768    
2769    
2770    
2771    #+sbcl
2772    (defun host-address (host &optional (family :internet))
2773      ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2774      ;; and cdr is a list of network address bytes.
2775      (declare (type stringable host)
2776               (type (or null (member :internet :decnet :chaos) card8) family))
2777      (declare (clx-values list))
2778      (let ((hostent (get-host-by-name (string host))))
2779        (ecase family
2780          ((:internet nil 0)
2781           (cons :internet (coerce (host-ent-address hostent) 'list))))))
2782    
2783    #+ecl
2784    (defun host-address (host &optional (family :internet))
2785      ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2786      ;; and cdr is a list of network address bytes.
2787      (declare (type stringable host)
2788               (type (or null (member :internet :decnet :chaos) card8) family))
2789      (declare (clx-values list))
2790      (labels ((no-host-error ()
2791                 (error "Unknown host ~S" host)))
2792        (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host))))))
2793          (unless addr
2794            (no-host-error))
2795          (list :internet
2796                (ldb (byte 8 24) addr)
2797                (ldb (byte 8 16) addr)
2798                (ldb (byte 8  8) addr)
2799                (ldb (byte 8  0) addr)))))
2800    
2801    #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts
2802    (defun get-host (host-object)
2803      ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
2804      ;; and cdr is a list of network address bytes.
2805      (declare (type list host-object))
2806      (declare (clx-values string family))
2807      (let* ((family (first host-object))
2808             (address (ecase family
2809                        (:internet
2810                         (dpb (second host-object)
2811                              (byte 8 24)
2812                              (dpb (third host-object)
2813                                   (byte 8 16)
2814                                   (dpb (fourth host-object)
2815                                        (byte 8 8)
2816                                        (fifth host-object)))))
2817                        (:chaos
2818                         (dpb (third host-object) (byte 8 8) (second host-object))))))
2819        (when (eq family :internet) (setq family :ip))
2820        (let ((host (si:get-host-from-address address family)))
2821          (values (and host (funcall host :name)) family))))
2822    
2823    ;;; This isn't required, but it helps make sense of the results from access-hosts
2824    #+Genera
2825    (defun get-host (host-object)
2826      ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
2827      ;; and cdr is a list of network address bytes.
2828      (declare (type list host-object))
2829      (declare (clx-values string family))
2830      (let ((family (first host-object)))
2831        (values (sys:send (net:get-host-from-address
2832                            (ecase family
2833                              (:internet
2834                                (apply #'tcp:build-internet-address (rest host-object)))
2835                              ((:chaos :DECnet)
2836                               (dpb (third host-object) (byte 8 8) (second host-object))))
2837                            (net:local-network-of-type (if (eq family :DECnet)
2838                                                           :DNA
2839                                                           family)))
2840                          :name)
2841                family)))
2842    
2843    ;;; This isn't required, but it helps make sense of the results from access-hosts
2844    #+Minima
2845    (defun get-host (host-object)
2846      ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
2847      ;; and cdr is a list of network address bytes.
2848      (declare (type list host-object))
2849      (declare (clx-values string family))
2850      (let ((family (first host-object)))
2851        (values (ecase family
2852                  (:internet
2853                    (minima:ip-address-string
2854                      (apply #'minima:make-ip-address (rest host-object)))))
2855                family)))
2856    
2857    
2858  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
# Line 1067  Line 2866 
2866  ;;; want to make this expand to T, as it makes the code more compact.  ;;; want to make this expand to T, as it makes the code more compact.
2867    
2868  (defmacro use-closures ()  (defmacro use-closures ()
2869    t) ;; emarsden2003-06-04 was NIL    #+(or lispm Minima) t
2870      #-(or lispm Minima) nil)
2871    
2872    #+(or Genera Minima)
2873    (defun clx-macroexpand (form env)
2874      (declare (ignore env))
2875      form)
2876    
2877    #-(or Genera Minima)
2878  (defun clx-macroexpand (form env)  (defun clx-macroexpand (form env)
2879    (macroexpand form env))    (macroexpand form env))
2880    
# Line 1081  Line 2887 
2887  ;;; Utilities  ;;; Utilities
2888    
2889  (defun getenv (name)  (defun getenv (name)
2890    (cdr (assoc name ext:*environment-list* :test #'string=)))    #+excl (sys:getenv name)
2891      #+lcl3.0 (lcl:environment-variable name)
2892      #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
2893      #+sbcl (sb-ext:posix-getenv name)
2894      #+ecl (si:getenv name)
2895      #+clisp (ext:getenv name)
2896      #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil))
2897    
2898    (defun get-host-name ()
2899      "Return the same hostname as gethostname(3) would"
2900      ;; machine-instance probably works on a lot of lisps, but clisp is not
2901      ;; one of them
2902      #+(or cmu sbcl) (machine-instance)
2903      ;; resources-pathname was using short-site-name for this purpose
2904      #+excl (short-site-name)
2905      #+ecl (si:getenv "HOST")
2906      #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s)))
2907      #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented"))
2908    
2909  (defun homedir-file-pathname (name)  (defun homedir-file-pathname (name)
2910    (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)    (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
# Line 1100  Line 2923 
2923    (or (let ((string (getenv "XENVIRONMENT")))    (or (let ((string (getenv "XENVIRONMENT")))
2924          (and string          (and string
2925               (pathname string)))               (pathname string)))
2926        (homedir-file-pathname (concatenate 'string ".Xdefaults-" (machine-instance)))))        (homedir-file-pathname
2927           (concatenate 'string ".Xdefaults-" (get-host-name)))))
2928    
2929  ;;; AUTHORITY-PATHNAME - The pathname of the authority file.  ;;; AUTHORITY-PATHNAME - The pathname of the authority file.
2930    
# Line 1110  Line 2934 
2934               (pathname xauthority)))               (pathname xauthority)))
2935        (homedir-file-pathname ".Xauthority")))        (homedir-file-pathname ".Xauthority")))
2936    
2937    ;;; this particular defaulting behaviour is typical to most Unices, I think
2938    #+unix
2939    (defun get-default-display (&optional display-name)
2940      "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY
2941    if it is NIL.  Display names have the format
2942    
2943      [protocol/] [hostname] : [:] displaynumber [.screennumber]
2944    
2945    There are two special cases in parsing, to match that done in the Xlib
2946    C language bindings
2947    
2948     - If the hostname is ``unix'' or the empty string, any supplied
2949       protocol is ignored and a connection is made using the :local
2950       transport.
2951    
2952     - If a double colon separates hostname from displaynumber, the
2953       protocol is assumed to be decnet.
2954    
2955    Returns a list of (host display-number screen protocol)."
2956      (let* ((name (or display-name
2957                       (getenv "DISPLAY")
2958                       (error "DISPLAY environment variable is not set")))
2959             (slash-i (or (position #\/ name) -1))
2960             (colon-i (position #\: name :start (1+ slash-i)))
2961             (decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
2962             (host (subseq name (1+ slash-i) colon-i))
2963             (dot-i (and colon-i (position #\. name :start colon-i)))
2964             (display (when colon-i
2965                        (parse-integer name
2966                                       :start (if decnet-colon-p
2967                                                  (+ colon-i 2)
2968                                                  (1+ colon-i))
2969                                       :end dot-i)))
2970             (screen (when dot-i
2971                       (parse-integer name :start (1+ dot-i))))
2972             (protocol
2973              (cond ((or (string= host "") (string-equal host "unix")) :local)
2974                    (decnet-colon-p :decnet)
2975                    ((> slash-i -1) (intern
2976                                     (string-upcase (subseq name 0 slash-i))
2977                                     :keyword))
2978                    (t :internet))))
2979        (list host (or display 0) (or screen 0) protocol)))
2980    
2981    
2982  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2983  ;; GC stuff  ;; GC stuff
# Line 1129  Line 2997 
2997    (setq *temp-gcontext-cache* nil)    (setq *temp-gcontext-cache* nil)
2998    nil)    nil)
2999    
3000    #+Genera
3001    (si:define-gc-cleanup clx-cleanup ("CLX Cleanup")
3002      (gc-cleanup))
3003    
3004    
3005    ;;-----------------------------------------------------------------------------
3006    ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)
3007    ;;-----------------------------------------------------------------------------
3008    
3009    #-(or clx-ansi-common-lisp Genera CMU sbcl)
3010    (defun with-standard-io-syntax-function (function)
3011      (declare #+lispm
3012               (sys:downward-funarg function))
3013      (let ((*package* (find-package :user))
3014            (*print-array* t)
3015            (*print-base* 10)
3016            (*print-case* :upcase)
3017            (*print-circle* nil)
3018            (*print-escape* t)
3019            (*print-gensym* t)
3020            (*print-length* nil)
3021            (*print-level* nil)
3022            (*print-pretty* nil)
3023            (*print-radix* nil)
3024            (*read-base* 10)
3025            (*read-default-float-format* 'single-float)
3026            (*read-suppress* nil)
3027            #+ticl (ticl:*print-structure* t)
3028            #+lucid (lucid::*print-structure* t))
3029        (funcall function)))
3030    
3031    #-(or clx-ansi-common-lisp Genera CMU sbcl)
3032    (defmacro with-standard-io-syntax (&body body)
3033      `(flet ((.with-standard-io-syntax-body. () ,@body))
3034         (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))
3035    
3036    
3037  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
# Line 1146  Line 3049 
3049  ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.  ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
3050  ;;; In ambiguous cases, the most specific translation is used.  ;;; In ambiguous cases, the most specific translation is used.
3051    
3052    #-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl)
3053    (defun default-keysym-translate (display state object)
3054      (declare (type display display)
3055               (type card16 state)
3056               (type t object)
3057               (clx-values t)
3058               (special left-meta-keysym right-meta-keysym
3059                        left-super-keysym right-super-keysym
3060                        left-hyper-keysym right-hyper-keysym))
3061      (when (characterp object)
3062        (when (logbitp (position :control +state-mask-vector+) state)
3063          (setf (char-bit object :control) 1))
3064        (when (or (state-keysymp display state left-meta-keysym)
3065                  (state-keysymp display state right-meta-keysym))
3066          (setf (char-bit object :meta) 1))
3067        (when (or (state-keysymp display state left-super-keysym)
3068                  (state-keysymp display state right-super-keysym))
3069          (setf (char-bit object :super) 1))
3070        (when (or (state-keysymp display state left-hyper-keysym)
3071                  (state-keysymp display state right-hyper-keysym))
3072          (setf (char-bit object :hyper) 1)))
3073      object)
3074    
3075    #+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp)
3076  (defun default-keysym-translate (display state object)  (defun default-keysym-translate (display state object)
3077    (declare (type display display)    (declare (type display display)
3078             (type card16 state)             (type card16 state)
# Line 1178  Line 3104 
3104    '(unsigned-byte 24))    '(unsigned-byte 24))
3105    
3106  (deftype pixarray-32-element-type ()  (deftype pixarray-32-element-type ()
3107   '(unsigned-byte 32))    #-(or Genera Minima) '(unsigned-byte 32)
3108      #+(or Genera Minima) 'fixnum)
3109    
3110  (deftype pixarray-1  ()  (deftype pixarray-1  ()
3111    '(simple-array pixarray-1-element-type (* *)))    '(#+(or cmu sbcl) simple-array
3112        #-(or cmu sbcl) array pixarray-1-element-type (* *)))
3113    
3114  (deftype pixarray-4  ()  (deftype pixarray-4  ()
3115    '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))    '(#+(or cmu sbcl) simple-array
3116        #-(or cmu sbcl) array pixarray-4-element-type (* *)))
3117    
3118  (deftype pixarray-8  ()  (deftype pixarray-8  ()
3119    '(simple-array pixarray-8-element-type (* *)))    '(#+(or cmu sbcl) simple-array
3120        #-(or cmu sbcl) array pixarray-8-element-type (* *)))
3121    
3122  (deftype pixarray-16 ()  (deftype pixarray-16 ()
3123    '(simple-array pixarray-16-element-type (* *)))    '(#+(or cmu sbcl) simple-array
3124        #-(or cmu sbcl) array pixarray-16-element-type (* *)))
3125    
3126  (deftype pixarray-24 ()  (deftype pixarray-24 ()
3127    '(simple-array pixarray-24-element-type (* *)))    '(#+(or cmu sbcl) simple-array
3128        #-(or cmu sbcl) array pixarray-24-element-type (* *)))
3129    
3130  (deftype pixarray-32 ()  (deftype pixarray-32 ()
3131    '(simple-array pixarray-32-element-type (* *)))    '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *)))
3132    
3133  (deftype pixarray ()  (deftype pixarray ()
3134    '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))    '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
# Line 1206  Line 3138 
3138    
3139  ;;; WITH-UNDERLYING-SIMPLE-VECTOR  ;;; WITH-UNDERLYING-SIMPLE-VECTOR
3140    
3141  #+CMU  #+Genera
3142    (defmacro with-underlying-simple-vector
3143              ((variable element-type pixarray) &body body)
3144      (let ((bits-per-element
3145              (sys:array-bits-per-element
3146                (symbol-value (sys:type-array-element-type element-type)))))
3147        `(scl:stack-let ((,variable
3148                          (make-array
3149                            (index-ceiling
3150                              (index* (array-total-size ,pixarray)
3151                                      (sys:array-element-size ,pixarray))
3152                              ,bits-per-element)
3153                            :element-type ',element-type
3154                            :displaced-to ,pixarray)))
3155           (declare (type (vector ,element-type) ,variable))
3156           ,@body)))
3157    
3158    #+lcl3.0
3159    (defmacro with-underlying-simple-vector
3160              ((variable element-type pixarray) &body body)
3161      `(let ((,variable (sys:underlying-simple-vector ,pixarray)))
3162         (declare (type (simple-array ,element-type (*)) ,variable))
3163         ,@body))
3164    
3165    #+excl
3166    (defmacro with-underlying-simple-vector
3167              ((variable element-type pixarray) &body body)
3168      `(let ((,variable (cdr (excl::ah_data ,pixarray))))
3169         (declare (type (simple-array ,element-type (*)) ,variable))
3170         ,@body))
3171    
3172    #+(or CMU sbcl)
3173  ;;; We do *NOT* support viewing an array as having a different element type.  ;;; We do *NOT* support viewing an array as having a different element type.
3174  ;;; Element-type is ignored.  ;;; Element-type is ignored.
3175  ;;;  ;;;
3176  (defmacro with-underlying-simple-vector  (defmacro with-underlying-simple-vector
3177            ((variable element-type pixarray) &body body)      ((variable element-type pixarray) &body body)
3178    (declare (ignore element-type))    (declare (ignore element-type))
3179    `(lisp::with-array-data ((,variable ,pixarray)    `(#+cmu lisp::with-array-data #+sbcl sb-kernel:with-array-data
3180                             (start)      ((,variable ,pixarray) (start) (end))
3181                             (end))      (declare (ignore start end))
3182        (declare (ignore start end))      ,@body))
       ,@body))  
3183    
3184  ;;; These are used to read and write pixels from and to CARD8s.  ;;; These are used to read and write pixels from and to CARD8s.
3185    
3186  ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.  ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
3187    
3188  (defmacro read-image-load-byte (size position integer)  (defmacro read-image-load-byte (size position integer)
3189    (unless *image-bit-lsb-first-p* (setq position (- 7 position)))    (unless +image-bit-lsb-first-p+ (setq position (- 7 position)))
3190    `(the (unsigned-byte ,size)    `(the (unsigned-byte ,size)
3191          (ldb (byte ,size ,position)(the card8 ,integer))))          (#-Genera ldb #+Genera sys:%logldb
3192             (byte ,size ,position)
3193             (the card8 ,integer))))
3194    
3195  ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from  ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from
3196  ;;; the appropriate number of CARD8s.  ;;; the appropriate number of CARD8s.
3197    
3198  (defmacro read-image-assemble-bytes (&rest bytes)  (defmacro read-image-assemble-bytes (&rest bytes)
3199    (unless *image-byte-lsb-first-p* (setq bytes (reverse bytes)))    (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes)))
3200    (let ((it (first bytes))    (let ((it (first bytes))
3201          (count 0))          (count 0))
3202      (dolist (byte (rest bytes))      (dolist (byte (rest bytes))
3203        (setq it        (setq it
3204              `(dpb              `(#-Genera dpb #+Genera sys:%logdpb
3205                (the card8 ,byte)                (the card8 ,byte)
3206                (byte 8 ,(incf count 8))                (byte 8 ,(incf count 8))
3207                (the (unsigned-byte ,count) ,it))))                (the (unsigned-byte ,count) ,it))))
3208      `(the (unsigned-byte ,(* (length bytes) 8)) ,it)))      #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it)
3209        #+Genera it))
3210    
3211  ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit  ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
3212  ;;; pixel.  ;;; pixel.
3213    
3214  (defmacro write-image-load-byte (position integer integer-size)  (defmacro write-image-load-byte (position integer integer-size)
3215    integer-size    integer-size
3216    (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position)))    (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position)))
3217    `(the card8    `(the card8
3218          (ldb          (#-Genera ldb #+Genera sys:%logldb
3219           (byte 8 ,position)           (byte 8 ,position)
3220           (the (unsigned-byte ,integer-size) ,integer))))           #-Genera (the (unsigned-byte ,integer-size) ,integer)
3221             #+Genera ,integer
3222             )))
3223    
3224  ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit  ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
3225  ;;; pixels.  ;;; pixels.
3226    
3227  (defmacro write-image-assemble-bytes (&rest bytes)  (defmacro write-image-assemble-bytes (&rest bytes)
3228    (unless *image-bit-lsb-first-p* (setq bytes (reverse bytes)))    (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes)))
3229    (let ((size (floor 8 (length bytes)))    (let ((size (floor 8 (length bytes)))
3230          (it (first bytes))          (it (first bytes))
3231          (count 0))          (count 0))
3232      (dolist (byte (rest bytes))      (dolist (byte (rest bytes))
3233        (setq it `(dpb        (setq it `(#-Genera dpb #+Genera sys:%logdpb
3234                   (the (unsigned-byte ,size) ,byte)                   (the (unsigned-byte ,size) ,byte)
3235                   (byte ,size ,(incf count size))                   (byte ,size ,(incf count size))
3236                   (the (unsigned-byte ,count) ,it))))                   (the (unsigned-byte ,count) ,it))))
3237      `(the card8 ,it)))      `(the card8 ,it)))
3238    
3239    #+(or Genera lcl3.0 excl)
3240    (defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+)
3241    
3242    #+(or Genera lcl3.0 excl)
3243    (defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+)
3244    
3245  ;;; The following table gives the bit ordering within bytes (when accessed  ;;; The following table gives the bit ordering within bytes (when accessed
3246  ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to  ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
3247  ;;; 31, where bit 0 should be leftmost on the display.  For a given byte  ;;; 31, where bit 0 should be leftmost on the display.  For a given byte
# Line 1301  Line 3273 
3273  ;;; 2Ll 07-00 15-08 23-16 31-24  ;;; 2Ll 07-00 15-08 23-16 31-24
3274  ;;; 4Ll 07-00 15-08 23-16 31-24  ;;; 4Ll 07-00 15-08 23-16 31-24
3275    
3276    #+(or Genera lcl3.0 excl)
3277    (defconstant
3278      *image-bit-ordering-table*
3279      '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil))
3280        ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil))
3281        ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil))
3282        ((1 (07 00) (15 08) (23 16) (31 24)) (nil t))
3283        ((2 (15 08) (07 00) (31 24) (23 16)) (nil t))
3284        ((4 (31 24) (23 16) (15 08) (07 00)) (nil t))
3285        ((1 (00 07) (08 15) (16 23) (24 31)) (t   nil))
3286        ((2 (08 15) (00 07) (24 31) (16 23)) (t   nil))
3287        ((4 (24 31) (16 23) (08 15) (00 07)) (t   nil))
3288        ((1 (07 00) (15 08) (23 16) (31 24)) (t   t))
3289        ((2 (07 00) (15 08) (23 16) (31 24)) (t   t))
3290        ((4 (07 00) (15 08) (23 16) (31 24)) (t   t))))
3291    
3292    #+(or Genera lcl3.0 excl)
3293    (defun compute-image-byte-and-bit-ordering ()
3294      (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p))
3295      ;; First compute the ordering
3296      (let ((ordering nil)
3297            (a (make-array '(1 32) :element-type 'bit :initial-element 0)))
3298        (dotimes (i 4)
3299          (push (flet ((bitpos (a i n)
3300                         (declare (optimize (speed 3) (safety 0) (space 0)))
3301                         (declare (type (simple-array bit (* *)) a)
3302                                  (type fixnum i n))
3303                         (with-underlying-simple-vector (v (unsigned-byte 8) a)
3304                           (prog2
3305                             (setf (aref v i) n)
3306                             (dotimes (i 32)
3307                               (unless (zerop (aref a 0 i))
3308                                 (return i)))
3309                             (setf (aref v i) 0)))))
3310                  (list (bitpos a i #b10000000)
3311                        (bitpos a i #b00000001)))
3312                ordering))
3313        (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering)))
3314        ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p
3315        (let ((byte-and-bit-ordering
3316                (second (assoc ordering *image-bit-ordering-table*
3317                               :test #'equal))))
3318          (unless byte-and-bit-ordering
3319            (error "Couldn't determine image byte and bit ordering~@
3320                    measured image ordering = ~A"
3321                   ordering))
3322          (values-list byte-and-bit-ordering))))
3323    
3324    #+(or Genera lcl3.0 excl)
3325    (multiple-value-setq
3326      (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
3327      (compute-image-byte-and-bit-ordering))
3328    
3329  ;;; If you can write fast routines that can read and write pixarrays out of a  ;;; If you can write fast routines that can read and write pixarrays out of a
3330  ;;; buffer-bytes, do it!  It makes the image code a lot faster.  The  ;;; buffer-bytes, do it!  It makes the image code a lot faster.  The
3331  ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines  ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines
3332  ;;; return T if they can do it, NIL if they can't.  ;;; return T if they can do it, NIL if they can't.
3333    
3334    ;;; FIXME: though we have some #+sbcl -conditionalized routines in
3335    ;;; here, they would appear not to work, and so are commented out in
3336    ;;; the the FAST-xxx-PIXARRAY routines themseleves.  Investigate
3337    ;;; whether the unoptimized routines are often used, and also whether
3338    ;;; speeding them up while maintaining correctness is possible.
3339    
3340  ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s  ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
3341    
3342  #+(or CMU)  #+(or lcl3.0 excl)
3343    (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height
3344                                 padded-bytes-per-line bits-per-pixel)
3345      (declare (type buffer-bytes buffer-bbuf)
3346               (type pixarray-1 array)
3347               (type card16 x y width height)
3348               (type array-index index padded-bytes-per-line)
3349               (type (member 1 4 8 16 24 32) bits-per-pixel)
3350               (ignore bits-per-pixel))
3351      #.(declare-buffun)
3352      (with-vector (buffer-bbuf buffer-bytes)
3353        (with-underlying-simple-vector (vector pixarray-1-element-type array)
3354          (do* ((start (index+ index
3355                               (index* y padded-bytes-per-line)
3356                               (index-ceiling x 8))
3357                       (index+ start padded-bytes-per-line))
3358                (y 0 (index1+ y))
3359                (left-bits (the array-index (mod (the fixnum (- x)) 8)))
3360                (right-bits (index-mod (index- width left-bits) 8))
3361                (middle-bits (the fixnum (- (the fixnum (- width left-bits))
3362                                            right-bits)))
3363                (middle-bytes (index-floor middle-bits 8)))
3364               ((index>= y height))
3365            (declare (type array-index start y
3366                           left-bits right-bits middle-bytes)
3367                     (fixnum middle-bits))
3368            (cond ((< middle-bits 0)
3369                   (let ((byte (aref buffer-bbuf (index1- start)))
3370                         (x (array-row-major-index array y left-bits)))
3371                     (declare (type card8 byte)
3372                              (type array-index x))
3373                     (when (index> right-bits 6)
3374                       (setf (aref vector (index- x 1))
3375                             (read-image-load-byte 1 7 byte)))
3376                     (when (and (index> left-bits 1)
3377                                (index> right-bits 5))
3378                       (setf (aref vector (index- x 2))
3379                             (read-image-load-byte 1 6 byte)))
3380                     (when (and (index> left-bits 2)
3381                                (index> right-bits 4))
3382                       (setf (aref vector (index- x 3))
3383                             (read-image-load-byte 1 5 byte)))
3384                     (when (and (index> left-bits 3)
3385                                (index> right-bits 3))
3386                       (setf (aref vector (index- x 4))
3387                             (read-image-load-byte 1 4 byte)))
3388                     (when (and (index> left-bits 4)
3389                                (index> right-bits 2))
3390                       (setf (aref vector (index- x 5))
3391                             (read-image-load-byte 1 3 byte)))
3392                     (when (and (index> left-bits 5)
3393                                (index> right-bits 1))
3394                       (setf (aref vector (index- x 6))
3395                             (read-image-load-byte 1 2 byte)))
3396                     (when (index> left-bits 6)
3397                       (setf (aref vector (index- x 7))
3398                             (read-image-load-byte 1 1 byte)))))
3399                  (t
3400                   (unless (index-zerop left-bits)
3401                     (let ((byte (aref buffer-bbuf (index1- start)))
3402                           (x (array-row-major-index array y left-bits)))
3403                       (declare (type card8 byte)
3404                                (type array-index x))
3405                       (setf (aref vector (index- x 1))
3406                             (read-image-load-byte 1 7 byte))
3407                       (when (index> left-bits 1)
3408                         (setf (aref vector (index- x 2))
3409                               (read-image-load-byte 1 6 byte))
3410                         (when (index> left-bits 2)
3411                           (setf (aref vector (index- x 3))
3412                                 (read-image-load-byte 1 5 byte))
3413                           (when (index> left-bits 3)
3414                             (setf (aref vector (index- x 4))
3415                                   (read-image-load-byte 1 4 byte))
3416                             (when (index> left-bits 4)
3417                               (setf (aref vector (index- x 5))
3418                                     (read-image-load-byte 1 3 byte))
3419                               (when (index> left-bits 5)
3420                                 (setf (aref vector (index- x 6))
3421                                       (read-image-load-byte 1 2 byte))
3422                                 (when (index> left-bits 6)
3423                                   (setf (aref vector (index- x 7))
3424                                         (read-image-load-byte 1 1 byte))
3425                                   ))))))))
3426                   (do* ((end (index+ start middle-bytes))
3427                         (i start (index1+ i))
3428                         (x (array-row-major-index array y left-bits) (index+ x 8)))
3429                        ((index>= i end)
3430                         (unless (index-zerop right-bits)
3431                           (let ((byte (aref buffer-bbuf end))
3432                                 (x (array-row-major-index
3433                                     array y (index+ left-bits middle-bits))))
3434                             (declare (type card8 byte)
3435                                      (type array-index x))
3436                             (setf (aref vector (index+ x 0))
3437                                   (read-image-load-byte 1 0 byte))
3438                             (when (index> right-bits 1)
3439                               (setf (aref vector (index+ x 1))
3440                                     (read-image-load-byte 1 1 byte))
3441                               (when (index> right-bits 2)
3442                                 (setf (aref vector (index+ x 2))
3443                                       (read-image-load-byte 1 2 byte))
3444                                 (when (index> right-bits 3)
3445                                   (setf (aref vector (index+ x 3))
3446                                         (read-image-load-byte 1 3 byte))
3447                                   (when (index> right-bits 4)
3448                                     (setf (aref vector (index+ x 4))
3449                                           (read-image-load-byte 1 4 byte))
3450                                     (when (index> right-bits 5)
3451                                       (setf (aref vector (index+ x 5))
3452                                             (read-image-load-byte 1 5 byte))
3453                                       (when (index> right-bits 6)
3454                                         (setf (aref vector (index+ x 6))
3455                                               (read-image-load-byte 1 6 byte))
3456                                         )))))))))
3457                     (declare (type array-index end i x))
3458                     (let ((byte (aref buffer-bbuf i)))
3459                       (declare (type card8 byte))
3460                       (setf (aref vector (index+ x 0))
3461                             (read-image-load-byte 1 0 byte))
3462                       (setf (aref vector (index+ x 1))
3463                             (read-image-load-byte 1 1 byte))
3464                       (setf (aref vector (index+ x 2))
3465                             (read-image-load-byte 1 2 byte))
3466                       (setf (aref vector (index+ x 3))
3467                             (read-image-load-byte 1 3 byte))
3468                       (setf (aref vector (index+ x 4))
3469                             (read-image-load-byte 1 4 byte))
3470                       (setf (aref vector (index+ x 5))
3471                             (read-image-load-byte 1 5 byte))
3472                       (setf (aref vector (index+ x 6))
3473                             (read-image-load-byte 1 6 byte))
3474                       (setf (aref vector (index+ x 7))
3475                             (read-image-load-byte 1 7 byte))))
3476                   )))))
3477        t)
3478    
3479    #+(or lcl3.0 excl)
3480    (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height
3481                                 padded-bytes-per-line bits-per-pixel)
3482      (declare (type buffer-bytes buffer-bbuf)
3483               (type pixarray-4 array)
3484               (type card16 x y width height)
3485               (type array-index index padded-bytes-per-line)
3486               (type (member 1 4 8 16 24 32) bits-per-pixel)
3487               (ignore bits-per-pixel))
3488      #.(declare-buffun)
3489      (with-vector (buffer-bbuf buffer-bytes)
3490        (with-underlying-simple-vector (vector pixarray-4-element-type array)
3491          (do* ((start (index+ index
3492                               (index* y padded-bytes-per-line)
3493                               (index-ceiling x 2))
3494                       (index+ start padded-bytes-per-line))
3495                (y 0 (index1+ y))
3496                (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x)))
3497                                                    2)))
3498                (right-nibbles (index-mod (index- width left-nibbles) 2))
3499                (middle-nibbles (index- width left-nibbles right-nibbles))
3500                (middle-bytes (index-floor middle-nibbles 2)))
3501               ((index>= y height))
3502            (declare (type array-index start y
3503                           left-nibbles right-nibbles middle-nibbles middle-bytes))
3504            (unless (index-zerop left-nibbles)
3505              (setf (aref array y 0)
3506                    (read-image-load-byte
3507                      4 4 (aref buffer-bbuf (index1- start)))))
3508            (do* ((end (index+ start middle-bytes))
3509                  (i start (index1+ i))
3510                  (x (array-row-major-index array y left-nibbles) (index+ x 2)))
3511                 ((index>= i end)
3512                  (unless (index-zerop right-nibbles)
3513                    (setf (aref array y (index+ left-nibbles middle-nibbles))
3514                          (read-image-load-byte 4 0 (aref buffer-bbuf end)))))
3515              (declare (type array-index end i x))
3516              (let ((byte (aref buffer-bbuf i)))
3517                (declare (type card8 byte))
3518                (setf (aref vector (index+ x 0))
3519                      (read-image-load-byte 4 0 byte))
3520                (setf (aref vector (index+ x 1))
3521                      (read-image-load-byte 4 4 byte))))
3522            )))
3523      t)
3524    
3525    #+(or Genera lcl3.0 excl CMU sbcl)
3526  (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height  (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height
3527                                padded-bytes-per-line bits-per-pixel)                                padded-bytes-per-line bits-per-pixel)
3528    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
# Line 1340  Line 3553 
3553                    (aref buffer-bbuf (index+ i 2))))))))                    (aref buffer-bbuf (index+ i 2))))))))
3554    t)    t)
3555    
3556  #+CMU  #+lispm
3557    (defun fast-read-pixarray-using-bitblt
3558           (bbuf boffset pixarray x y width height padded-bytes-per-line
3559            bits-per-pixel)
3560      (#+Genera sys:stack-let* #-Genera let*
3561       ((dimensions (list (+ y height)
3562                          (floor (* padded-bytes-per-line 8) bits-per-pixel)))
3563        (a (make-array
3564             dimensions
3565             :element-type (array-element-type pixarray)
3566             :displaced-to bbuf
3567             :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
3568       (sys:bitblt boole-1 width height a x y pixarray 0 0))
3569      t)
3570    
3571    #+(or CMU sbcl)
3572  (defun pixarray-element-size (pixarray)  (defun pixarray-element-size (pixarray)
3573    (let ((eltype (array-element-type pixarray)))    (let ((eltype (array-element-type pixarray)))
3574      (cond ((eq eltype 'bit) 1)      (cond ((eq eltype 'bit) 1)
# Line 1360  Line 3588 
3588  (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy  (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
3589                               height width)                               height width)
3590    (declare (type array-index source-width sx sy dest-width dx dy height width))    (declare (type array-index source-width sx sy dest-width dx dy height width))
3591     #.(declare-buffun)    #.(declare-buffun)
3592     (lisp::with-array-data ((sdata source)    (lisp::with-array-data ((sdata source)
3593                             (sstart)                                   (sstart)
3594                             (send))                                   (send))
3595       (declare (ignore send))      (declare (ignore send))
3596       (lisp::with-array-data ((ddata dest)      (lisp::with-array-data ((ddata dest)
3597                               (dstart)                                     (dstart)
3598                               (dend))                                     (dend))
3599         (declare (ignore dend))        (declare (ignore dend))
3600         (assert (and (zerop sstart) (zerop dstart)))        (assert (and (zerop sstart) (zerop dstart)))
3601         (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits)        (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)
3602                               sx (index* sy source-width))                              sx (index* sy source-width))
3603                       (index+ src-idx source-width))                      (index+ src-idx source-width))
3604              (dest-idx (index+ (* vm:vector-data-offset vm:word-bits)             (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)
3605                                dx (index* dy dest-width))                               dx (index* dy dest-width))
3606                        (index+ dest-idx dest-width))                       (index+ dest-idx dest-width))
3607              (count height (1- count)))             (count height (1- count)))
3608             ((zerop count))            ((zerop count))
3609           (declare (type array-index src-idx dest-idx count))          (declare (type array-index src-idx dest-idx count))
3610           (kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))          (kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
3611    
3612    
3613    #+sbcl
3614    (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
3615                                 height width)
3616      (declare (type array-index source-width sx sy dest-width dx dy height width))
3617      #.(declare-buffun)
3618      (sb-kernel:with-array-data ((sdata source) (sstart) (send))
3619        (declare (ignore send))
3620        (sb-kernel:with-array-data ((ddata dest) (dstart) (dend))
3621          (declare (ignore dend))
3622          (assert (and (zerop sstart) (zerop dstart)))
3623          (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
3624                                sx (index* sy source-width))
3625                        (index+ src-idx source-width))
3626               (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
3627                                 dx (index* dy dest-width))
3628                         (index+ dest-idx dest-width))
3629               (count height (1- count)))
3630              ((zerop count))
3631            (declare (type array-index src-idx dest-idx count))
3632            (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width)))))
3633    
3634  #+CMU  #+(or CMU sbcl)
3635  (defun fast-read-pixarray-using-bitblt  (defun fast-read-pixarray-using-bitblt
3636         (bbuf boffset pixarray x y width height padded-bytes-per-line         (bbuf boffset pixarray x y width height padded-bytes-per-line
3637          bits-per-pixel)          bits-per-pixel)
3638    (declare (type (array * 2) pixarray))    (declare (type (array * 2) pixarray))
3639    #.(declare-buffun)    #.(declare-buffun)
3640    (copy-bit-rect bbuf    (copy-bit-rect bbuf
3641                   (index* padded-bytes-per-line vm:byte-bits)                   (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
3642                   (index* boffset vm:byte-bits) 0                   (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0
3643                   pixarray                   pixarray
3644                   (index* (array-dimension pixarray 1) bits-per-pixel)                   (index* (array-dimension pixarray 1) bits-per-pixel)
3645                   x y                   x y
# Line 1397  Line 3647 
3647                   (index* width bits-per-pixel))                   (index* width bits-per-pixel))
3648    t)    t)
3649    
3650    #+(or Genera lcl3.0 excl)
3651    (defun fast-read-pixarray-with-swap
3652           (bbuf boffset pixarray x y width height padded-bytes-per-line
3653            bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3654      (declare (type buffer-bytes bbuf)
3655               (type array-index boffset
3656                     padded-bytes-per-line)
3657               (type pixarray pixarray)
3658               (type card16 x y width height)
3659               (type (member 1 4 8 16 24 32) bits-per-pixel)
3660               (type (member 8 16 32) unit)
3661               (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
3662      (unless (index= bits-per-pixel 24)
3663        (let ((pixarray-padded-bits-per-line
3664                (if (index= height 1) 0
3665                  (index* (index- (array-row-major-index pixarray 1 0)
3666                                  (array-row-major-index pixarray 0 0))
3667                          bits-per-pixel)))
3668              (x-bits (index* x bits-per-pixel)))
3669          (declare (type array-index pixarray-padded-bits-per-line x-bits))
3670          (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
3671                    (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
3672                         (index-zerop (index-mod x-bits 8)))
3673                  (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
3674                       (index-zerop (index-mod x-bits +image-unit+))))
3675            (multiple-value-bind (image-swap-function image-swap-lsb-first-p)
3676                (image-swap-function
3677                  bits-per-pixel
3678                  unit byte-lsb-first-p bit-lsb-first-p
3679                  +image-unit+ *computed-image-byte-lsb-first-p*
3680                  *computed-image-bit-lsb-first-p*)
3681              (declare (type symbol image-swap-function)
3682                       (type generalized-boolean image-swap-lsb-first-p))
3683              (with-underlying-simple-vector (dst card8 pixarray)
3684                (funcall
3685                  (symbol-function image-swap-function) bbuf dst
3686                  (index+ boffset
3687                          (index* y padded-bytes-per-line)
3688                          (index-floor x-bits 8))
3689                  0 (index-ceiling (index* width bits-per-pixel) 8)
3690                  padded-bytes-per-line
3691                  (index-floor pixarray-padded-bits-per-line 8)
3692                  height image-swap-lsb-first-p)))
3693            t))))
3694    
3695  (defun fast-read-pixarray (bbuf boffset pixarray  (defun fast-read-pixarray (bbuf boffset pixarray
3696                             x y width height padded-bytes-per-line                             x y width height padded-bytes-per-line
3697                             bits-per-pixel                             bits-per-pixel
# Line 1412  Line 3707 
3707    (progn bbuf boffset pixarray x y width height padded-bytes-per-line    (progn bbuf boffset pixarray x y width height padded-bytes-per-line
3708           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3709    (or    (or
3710        #+(or Genera lcl3.0 excl)
3711        (fast-read-pixarray-with-swap
3712          bbuf boffset pixarray x y width height padded-bytes-per-line
3713          bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3714      (let ((function      (let ((function
3715              (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)              (or #+lispm
3716                    (and (= (sys:array-element-size pixarray) bits-per-pixel)
3717                         (zerop (index-mod padded-bytes-per-line 4))
3718                         (zerop (index-mod
3719                                  (* #+Genera (sys:array-row-span pixarray)
3720                                     #-Genera (array-dimension pixarray 1)
3721                                     bits-per-pixel)
3722                                  32))
3723                         #'fast-read-pixarray-using-bitblt)
3724                    #+(or CMU)
3725                    (and (index= (pixarray-element-size pixarray) bits-per-pixel)
3726                       #'fast-read-pixarray-using-bitblt)                       #'fast-read-pixarray-using-bitblt)
3727                    #+(or lcl3.0 excl)
3728                    (and (index= bits-per-pixel 1)
3729                         #'fast-read-pixarray-1)
3730                    #+(or lcl3.0 excl)
3731                    (and (index= bits-per-pixel 4)
3732                         #'fast-read-pixarray-4)
3733                    #+(or Genera lcl3.0 excl CMU)
3734                  (and (index= bits-per-pixel 24)                  (and (index= bits-per-pixel 24)
3735                       #'fast-read-pixarray-24))))                       #'fast-read-pixarray-24))))
3736        (when function        (when function
# Line 1422  Line 3738 
3738            bbuf boffset pixarray x y width height padded-bytes-per-line            bbuf boffset pixarray x y width height padded-bytes-per-line
3739            bits-per-pixel function            bits-per-pixel function
3740            unit byte-lsb-first-p bit-lsb-first-p            unit byte-lsb-first-p bit-lsb-first-p
3741            *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)))))            +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)))))
3742    
3743  ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s  ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
3744    
3745  #+(or CMU)  #+(or lcl3.0 excl)
3746    (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height
3747                                  padded-bytes-per-line bits-per-pixel)
3748      (declare (type buffer-bytes buffer-bbuf)
3749               (type pixarray-1 array)
3750               (type card16 x y width height)
3751               (type array-index index padded-bytes-per-line)
3752               (type (member 1 4 8 16 24 32) bits-per-pixel)
3753               (ignore bits-per-pixel))
3754      #.(declare-buffun)
3755      (with-vector (buffer-bbuf buffer-bytes)
3756        (with-underlying-simple-vector (vector pixarray-1-element-type array)
3757          (do* ((h 0 (index1+ h))
3758                (y y (index1+ y))
3759                (right-bits (index-mod width 8))
3760                (middle-bits (index- width right-bits))
3761                (middle-bytes (index-ceiling middle-bits 8))
3762                (start index (index+ start padded-bytes-per-line)))
3763               ((index>= h height))
3764            (declare (type array-index h y right-bits middle-bits
3765                           middle-bytes start))
3766            (do* ((end (index+ start middle-bytes))
3767                  (i start (index1+ i))
3768                  (start-x x)
3769                  (x (array-row-major-index array y start-x) (index+ x 8)))
3770                 ((index>= i end)
3771                  (unless (index-zerop right-bits)
3772                    (let ((x (array-row-major-index
3773                               array y (index+ start-x middle-bits))))
3774                      (declare (type array-index x))
3775                      (setf (aref buffer-bbuf end)
3776                            (write-image-assemble-bytes
3777                              (aref vector (index+ x 0))
3778                              (if (index> right-bits 1)
3779                                  (aref vector (index+ x 1))
3780                                0)
3781                              (if (index> right-bits 2)
3782                                  (aref vector (index+ x 2))
3783                                0)
3784                              (if (index> right-bits 3)
3785                                  (aref vector (index+ x 3))
3786                                0)
3787                              (if (index> right-bits 4)
3788                                  (aref vector (index+ x 4))
3789                                0)
3790                              (if (index> right-bits 5)
3791                                  (aref vector (index+ x 5))
3792                                0)
3793                              (if (index> right-bits 6)
3794                                  (aref vector (index+ x 6))
3795                                0)
3796                              0)))))
3797              (declare (type array-index end i start-x x))
3798              (setf (aref buffer-bbuf i)
3799                    (write-image-assemble-bytes
3800                      (aref vector (index+ x 0))
3801                      (aref vector (index+ x 1))
3802                      (aref vector (index+ x 2))
3803                      (aref vector (index+ x 3))
3804                      (aref vector (index+ x 4))
3805                      (aref vector (index+ x 5))
3806                      (aref vector (index+ x 6))
3807                      (aref vector (index+ x 7))))))))
3808      t)
3809    
3810    #+(or lcl3.0 excl)
3811    (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height
3812                                  padded-bytes-per-line bits-per-pixel)
3813      (declare (type buffer-bytes buffer-bbuf)
3814               (type pixarray-4 array)
3815               (type int16 x y)
3816               (type card16 width height)
3817               (type array-index index padded-bytes-per-line)
3818               (type (member 1 4 8 16 24 32) bits-per-pixel)
3819               (ignore bits-per-pixel))
3820      #.(declare-buffun)
3821      (with-vector (buffer-bbuf buffer-bytes)
3822        (with-underlying-simple-vector (vector pixarray-4-element-type array)
3823          (do* ((h 0 (index1+ h))
3824                (y y (index1+ y))
3825                (right-nibbles (index-mod width 2))
3826                (middle-nibbles (index- width right-nibbles))
3827                (middle-bytes (index-ceiling middle-nibbles 2))
3828                (start index (index+ start padded-bytes-per-line)))
3829               ((index>= h height))
3830            (declare (type array-index h y right-nibbles middle-nibbles
3831                           middle-bytes start))
3832            (do* ((end (index+ start middle-bytes))
3833                  (i start (index1+ i))
3834                  (start-x x)
3835                  (x (array-row-major-index array y start-x) (index+ x 2)))
3836                 ((index>= i end)
3837                  (unless (index-zerop right-nibbles)
3838                    (setf (aref buffer-bbuf end)
3839                          (write-image-assemble-bytes
3840                            (aref array y (index+ start-x middle-nibbles))
3841                            0))))
3842              (declare (type array-index end i start-x x))
3843              (setf (aref buffer-bbuf i)
3844                    (write-image-assemble-bytes
3845                      (aref vector (index+ x 0))
3846                      (aref vector (index+ x 1))))))))
3847      t)
3848    
3849    #+(or Genera lcl3.0 excl CMU sbcl)
3850  (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height  (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
3851                                 padded-bytes-per-line bits-per-pixel)                                 padded-bytes-per-line bits-per-pixel)
3852    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
# Line 1459  Line 3879 
3879                    (write-image-load-byte 16 pixel 24)))))))                    (write-image-load-byte 16 pixel 24)))))))
3880    t)    t)
3881    
3882  #+CMU  #+lispm
3883    (defun fast-write-pixarray-using-bitblt
3884           (bbuf boffset pixarray x y width height padded-bytes-per-line
3885            bits-per-pixel)
3886      (#+Genera sys:stack-let* #-Genera let*
3887       ((dimensions (list (+ y height)
3888                          (floor (* padded-bytes-per-line 8) bits-per-pixel)))
3889        (a (make-array
3890             dimensions
3891             :element-type (array-element-type pixarray)
3892             :displaced-to bbuf
3893             :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
3894       (sys:bitblt boole-1 width height pixarray x y a 0 0))
3895      t)
3896    
3897    #+(or CMU sbcl)
3898  (defun fast-write-pixarray-using-bitblt  (defun fast-write-pixarray-using-bitblt
3899         (bbuf boffset pixarray x y width height padded-bytes-per-line         (bbuf boffset pixarray x y width height padded-bytes-per-line
3900          bits-per-pixel)          bits-per-pixel)
# Line 1468  Line 3903 
3903                   (index* (array-dimension pixarray 1) bits-per-pixel)                   (index* (array-dimension pixarray 1) bits-per-pixel)
3904                   x y                   x y
3905                   bbuf                   bbuf
3906                   (index* padded-bytes-per-line vm:byte-bits)                   (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
3907                   (index* boffset vm:byte-bits) 0                   (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0
3908                   height                   height
3909                   (index* width bits-per-pixel))                   (index* width bits-per-pixel))
3910    t)    t)
3911    
3912    #+(or Genera lcl3.0 excl)
3913    (defun fast-write-pixarray-with-swap
3914           (bbuf boffset pixarray x y width height padded-bytes-per-line
3915            bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3916      (declare (type buffer-bytes bbuf)
3917               (type pixarray pixarray)
3918               (type card16 x y width height)
3919               (type array-index boffset padded-bytes-per-line)
3920               (type (member 1 4 8 16 24 32) bits-per-pixel)
3921               (type (member 8 16 32) unit)
3922               (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
3923      (unless (index= bits-per-pixel 24)
3924        (let ((pixarray-padded-bits-per-line
3925                (if (index= height 1) 0
3926                  (index* (index- (array-row-major-index pixarray 1 0)
3927                                  (array-row-major-index pixarray 0 0))
3928                          bits-per-pixel)))
3929              (pixarray-start-bit-offset
3930                (index* (array-row-major-index pixarray y x)
3931                        bits-per-pixel)))
3932          (declare (type array-index pixarray-padded-bits-per-line
3933                         pixarray-start-bit-offset))
3934          (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
3935                    (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
3936                         (index-zerop (index-mod pixarray-start-bit-offset 8)))
3937                  (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
3938                       (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
3939            (multiple-value-bind (image-swap-function image-swap-lsb-first-p)
3940                (image-swap-function
3941                  bits-per-pixel
3942                  +image-unit+ *computed-image-byte-lsb-first-p*
3943                  *computed-image-bit-lsb-first-p*
3944                  unit byte-lsb-first-p bit-lsb-first-p)
3945              (declare (type symbol image-swap-function)
3946                       (type generalized-boolean image-swap-lsb-first-p))
3947              (with-underlying-simple-vector (src card8 pixarray)
3948                (funcall
3949                  (symbol-function image-swap-function)
3950                  src bbuf (index-floor pixarray-start-bit-offset 8) boffset
3951                  (index-ceiling (index* width bits-per-pixel) 8)
3952                  (index-floor pixarray-padded-bits-per-line 8)
3953                  padded-bytes-per-line height image-swap-lsb-first-p))
3954              t)))))
3955    
3956  (defun fast-write-pixarray (bbuf boffset pixarray x y width height  (defun fast-write-pixarray (bbuf boffset pixarray x y width height
3957                              padded-bytes-per-line bits-per-pixel                              padded-bytes-per-line bits-per-pixel
3958                              unit byte-lsb-first-p bit-lsb-first-p)                              unit byte-lsb-first-p bit-lsb-first-p)
# Line 1487  Line 3966 
3966    (progn bbuf boffset pixarray x y width height padded-bytes-per-line    (progn bbuf boffset pixarray x y width height padded-bytes-per-line
3967           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3968    (or    (or
3969        #+(or Genera lcl3.0 excl)
3970        (fast-write-pixarray-with-swap
3971          bbuf boffset pixarray x y width height padded-bytes-per-line
3972          bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3973      (let ((function      (let ((function
3974              (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)              (or #+lispm
3975                    (and (= (sys:array-element-size pixarray) bits-per-pixel)
3976                         (zerop (index-mod padded-bytes-per-line 4))
3977                         (zerop (index-mod
3978                                  (* #+Genera (sys:array-row-span pixarray)
3979                                     #-Genera (array-dimension pixarray 1)
3980                                     bits-per-pixel)
3981                                  32))
3982                       #'fast-write-pixarray-using-bitblt)                       #'fast-write-pixarray-using-bitblt)
3983                    #+(or CMU)
3984                    (and (index= (pixarray-element-size pixarray) bits-per-pixel)
3985                         #'fast-write-pixarray-using-bitblt)
3986                    #+(or lcl3.0 excl)
3987                    (and (index= bits-per-pixel 1)
3988                         #'fast-write-pixarray-1)
3989                    #+(or lcl3.0 excl)
3990                    (and (index= bits-per-pixel 4)
3991                         #'fast-write-pixarray-4)
3992                    #+(or Genera lcl3.0 excl CMU)
3993                  (and (index= bits-per-pixel 24)                  (and (index= bits-per-pixel 24)
3994                       #'fast-write-pixarray-24))))                       #'fast-write-pixarray-24))))
3995        (when function        (when function
3996          (write-pixarray-internal          (write-pixarray-internal
3997            bbuf boffset pixarray x y width height padded-bytes-per-line            bbuf boffset pixarray x y width height padded-bytes-per-line
3998            bits-per-pixel function            bits-per-pixel function
3999            *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*            +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+
4000            unit byte-lsb-first-p bit-lsb-first-p)))))            unit byte-lsb-first-p bit-lsb-first-p)))))
4001    
4002  ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another  ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
# Line 1506  Line 4006 
4006             (type card16 x y width height)             (type card16 x y width height)
4007             (type (member 1 4 8 16 24 32) bits-per-pixel))             (type (member 1 4 8 16 24 32) bits-per-pixel))
4008    (progn pixarray copy x y width height bits-per-pixel nil)    (progn pixarray copy x y width height bits-per-pixel nil)
4009    (let* ((pixarray-padded-pixels-per-line    (or
4010            (array-dimension pixarray 1))      #+(or lispm CMU)
4011           (pixarray-padded-bits-per-line      (let* ((pixarray-padded-pixels-per-line
4012            (* pixarray-padded-pixels-per-line bits-per-pixel))               #+Genera (sys:array-row-span pixarray)
4013           (copy-padded-pixels-per-line               #-Genera (array-dimension pixarray 1))
4014            (array-dimension copy 1))             (pixarray-padded-bits-per-line
4015           (copy-padded-bits-per-line               (* pixarray-padded-pixels-per-line bits-per-pixel))
4016            (* copy-padded-pixels-per-line bits-per-pixel)))             (copy-padded-pixels-per-line
4017      (when (index= (pixarray-element-size pixarray)               #+Genera (sys:array-row-span copy)
4018                    (pixarray-element-size copy)               #-Genera (array-dimension copy 1))
4019                    bits-per-pixel)             (copy-padded-bits-per-line
4020        (copy-bit-rect pixarray pixarray-padded-bits-per-line x y               (* copy-padded-pixels-per-line bits-per-pixel)))
4021                       copy copy-padded-bits-per-line 0 0        #-(or CMU)
4022                       height        (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
4023                       (index* width bits-per-pixel))                   (zerop (index-mod pixarray-padded-bits-per-line 32))
4024                     (zerop (index-mod copy-padded-bits-per-line 32)))
4025            (sys:bitblt boole-1 width height pixarray x y copy 0 0)
4026            t)
4027          #+(or CMU)
4028          (when (index= (pixarray-element-size pixarray)
4029                        (pixarray-element-size copy)
4030                        bits-per-pixel)
4031            (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
4032                           copy copy-padded-bits-per-line 0 0
4033                           height
4034                           (index* width bits-per-pixel))
4035            t))
4036    
4037        #+(or lcl3.0 excl)
4038        (unless (index= bits-per-pixel 24)
4039          (let ((pixarray-padded-bits-per-line
4040                  (if (index= height 1) 0
4041                    (index* (index- (array-row-major-index pixarray 1 0)
4042                                    (array-row-major-index pixarray 0 0))
4043                            bits-per-pixel)))
4044                (copy-padded-bits-per-line
4045                  (if (index= height 1) 0
4046                    (index* (index- (array-row-major-index copy 1 0)
4047                                    (array-row-major-index copy 0 0))
4048                            bits-per-pixel)))
4049                (pixarray-start-bit-offset
4050                  (index* (array-row-major-index pixarray y x)
4051                          bits-per-pixel)))
4052            (declare (type array-index pixarray-padded-bits-per-line
4053                           copy-padded-bits-per-line pixarray-start-bit-offset))
4054            (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
4055                      (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
4056                           (index-zerop (index-mod copy-padded-bits-per-line 8))
4057                           (index-zerop (index-mod pixarray-start-bit-offset 8)))
4058                    (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
4059                         (index-zerop (index-mod copy-padded-bits-per-line +image-unit+))
4060                         (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
4061              (with-underlying-simple-vector (src card8 pixarray)
4062                (with-underlying-simple-vector (dst card8 copy)
4063                  (image-noswap
4064                    src dst
4065                    (index-floor pixarray-start-bit-offset 8) 0
4066                    (index-ceiling (index* width bits-per-pixel) 8)
4067                    (index-floor pixarray-padded-bits-per-line 8)
4068                    (index-floor copy-padded-bits-per-line 8)
4069                    height nil)))
4070              t)))
4071        #+(or lcl3.0 excl)
4072        (macrolet
4073          ((copy (type element-type)
4074             `(let ((pixarray pixarray)
4075                    (copy copy))
4076                (declare (type ,type pixarray copy))
4077                #.(declare-buffun)
4078                (with-underlying-simple-vector (src ,element-type pixarray)
4079                  (with-underlying-simple-vector (dst ,element-type copy)
4080                    (do* ((dst-y 0 (index1+ dst-y))
4081                          (src-y y (index1+ src-y)))
4082                         ((index>= dst-y height))
4083                      (declare (type card16 dst-y src-y))
4084                      (do* ((dst-idx (array-row-major-index copy dst-y 0)
4085                                     (index1+ dst-idx))
4086                            (dst-end (index+ dst-idx width))
4087                            (src-idx (array-row-major-index pixarray src-y x)
4088                                     (index1+ src-idx)))
4089                           ((index>= dst-idx dst-end))
4090                        (declare (type array-index dst-idx src-idx dst-end))
4091                        (setf (aref dst dst-idx)
4092                              (the ,element-type (aref src src-idx))))))))))
4093          (ecase bits-per-pixel
4094            (1  (copy pixarray-1  pixarray-1-element-type))
4095            (4  (copy pixarray-4  pixarray-4-element-type))
4096            (8  (copy pixarray-8  pixarray-8-element-type))
4097            (16 (copy pixarray-16 pixarray-16-element-type))
4098            (24 (copy pixarray-24 pixarray-24-element-type))
4099            (32 (copy pixarray-32 pixarray-32-element-type)))
4100        t)))        t)))

Legend:
Removed from v.1.11.2.1  
changed lines