/[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.1.1.6 by ram, Tue Feb 25 13:18:31 1992 UTC revision 1.18 by rtoy, Wed Jun 17 18:28:11 2009 UTC
# Line 18  Line 18 
18  ;;; express or implied warranty.  ;;; express or implied warranty.
19  ;;;  ;;;
20    
21    #+cmu
22    (ext:file-comment "$Id$")
23    
24  (in-package :xlib)  (in-package :xlib)
25    
26  #+lcl3.0  (proclaim '(declaration array-register))
27  (import '(  
28            lcl:define-condition  #+cmu
29            lcl:type-error  (setf (getf ext:*herald-items* :xlib)
30            lucid::type-error-datum        `("    CLX X Library " ,*version*))
31            lucid::type-error-expected-type  
32            sys:underlying-simple-vector))  
33    ;;; The size of the output buffer.  Must be a multiple of 4.
34  (export '(  (defparameter *output-buffer-size* 8192)
           char->card8  
           card8->char  
           default-error-handler  
           #-(or ansi-common-lisp CMU) define-condition))  
35    
36  #+explorer  #+explorer
37  (zwei:define-indentation event-case (1 1))  (zwei:define-indentation event-case (1 1))
# Line 42  Line 41 
41    
42  #-(or clx-overlapping-arrays (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-overlapping-arrays 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 (eval compile load)  (eval-when (:compile-toplevel :load-toplevel :execute)
65      (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3
66  (defconstant *buffer-speed* 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    #+(and cmu 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    #-(and cmu 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
# Line 94  Line 94 
94    
95  (defun card8->int8 (x)  (defun card8->int8 (x)
96    (declare (type card8 x))    (declare (type card8 x))
97    (declare (values int8))    (declare (clx-values int8))
98    #.(declare-buffun)    #.(declare-buffun)
99    (the int8 (if (logbitp 7 x)    (the int8 (if (logbitp 7 x)
100                  (the int8 (- x #x100))                  (the int8 (- x #x100))
# Line 102  Line 102 
102    
103  (defun int8->card8 (x)  (defun int8->card8 (x)
104    (declare (type int8 x))    (declare (type int8 x))
105    (declare (values card8))    (declare (clx-values card8))
106    #.(declare-buffun)    #.(declare-buffun)
107    (the card8 (ldb (byte 8 0) x)))    (the card8 (ldb (byte 8 0) x)))
108    
109  (defun card16->int16 (x)  (defun card16->int16 (x)
110    (declare (type card16 x))    (declare (type card16 x))
111    (declare (values int16))    (declare (clx-values int16))
112    #.(declare-buffun)    #.(declare-buffun)
113    (the int16 (if (logbitp 15 x)    (the int16 (if (logbitp 15 x)
114                   (the int16 (- x #x10000))                   (the int16 (- x #x10000))
# Line 116  Line 116 
116    
117  (defun int16->card16 (x)  (defun int16->card16 (x)
118    (declare (type int16 x))    (declare (type int16 x))
119    (declare (values card16))    (declare (clx-values card16))
120    #.(declare-buffun)    #.(declare-buffun)
121    (the card16 (ldb (byte 16 0) x)))    (the card16 (ldb (byte 16 0) x)))
122    
123  (defun card32->int32 (x)  (defun card32->int32 (x)
124    (declare (type card32 x))    (declare (type card32 x))
125    (declare (values int32))    (declare (clx-values int32))
126    #.(declare-buffun)    #.(declare-buffun)
127    (the int32 (if (logbitp 31 x)    (the int32 (if (logbitp 31 x)
128                   (the int32 (- x #x100000000))                   (the int32 (- x #x100000000))
# Line 130  Line 130 
130    
131  (defun int32->card32 (x)  (defun int32->card32 (x)
132    (declare (type int32 x))    (declare (type int32 x))
133    (declare (values card32))    (declare (clx-values card32))
134    #.(declare-buffun)    #.(declare-buffun)
135    (the card32 (ldb (byte 32 0) x)))    (the card32 (ldb (byte 32 0) x)))
136    
# Line 167  Line 167 
167    
168  (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))  (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
169    
170  #-(or Genera lcl3.0)  #-(or Genera lcl3.0 excl)
171  (progn  (progn
172    
173  (defun aref-card8 (a i)  (defun aref-card8 (a i)
174    (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
175             (type array-index i))             (type array-index i))
176    (declare (values card8))    (declare (clx-values card8))
177    #.(declare-buffun)    #.(declare-buffun)
178    (the card8 (aref a i)))    (the card8 (aref a i)))
179    
# Line 187  Line 187 
187  (defun aref-int8 (a i)  (defun aref-int8 (a i)
188    (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
189             (type array-index i))             (type array-index i))
190    (declare (values int8))    (declare (clx-values int8))
191    #.(declare-buffun)    #.(declare-buffun)
192    (card8->int8 (aref a i)))    (card8->int8 (aref a i)))
193    
# Line 217  Line 217 
217    
218  )  )
219    
220  #+lcl3.0 ;in lcl2.1 these symbols are in different packages and making too  #+(or excl lcl3.0 clx-overlapping-arrays)
          ;many conditionalizations makes my brain hurt.  
 (progn  
   
 (defun aref-card8 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (values card8))  
   #.(declare-buffun)  
   (the card8 (sys:svref-8bit a i)))  
   
 (defun aset-card8 (v a i)  
   (declare (type card8 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (sys:svref-8bit a i) v))  
   
 (defun aref-int8 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (values int8))  
   #.(declare-buffun)  
   (the int8 (sys:svref-signed-8bit a i)))  
   
 (defun aset-int8 (v a i)  
   (declare (type int8 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (sys:svref-signed-8bit a i) v))  
   
 )  
   
 #+clx-overlapping-arrays  
221  (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29  (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
222                   aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))                   aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
223    
# Line 330  Line 296 
296  #+excl  #+excl
297  (progn  (progn
298    
299    (defun aref-card16 (a i)  (defun aref-card8 (a i)
300      (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
301               (type array-index i))             (type array-index i))
302      (declare (values card16))    (declare (clx-values card8))
303      #.(declare-buffun)    #.(declare-buffun)
304      (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i    (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
305                              :unsigned-word)))                           :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)  (defun aset-card16 (v a i)
340      (declare (type card16 v)    (declare (type card16 v)
341               (type buffer-bytes a)             (type buffer-bytes a)
342               (type array-index i))             (type array-index i))
343      #.(declare-buffun)    #.(declare-buffun)
344      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
345                        :unsigned-word) v))                      :unsigned-word) v))
346    
347    (defun aref-int16 (a i)  (defun aref-int16 (a i)
348      (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
349               (type array-index i))             (type array-index i))
350      (declare (values int16))    (declare (clx-values int16))
351      #.(declare-buffun)    #.(declare-buffun)
352      (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i    (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
353                             :signed-word)))                           :signed-word)))
354    
355    (defun aset-int16 (v a i)  (defun aset-int16 (v a i)
356      (declare (type int16 v)    (declare (type int16 v)
357               (type buffer-bytes a)             (type buffer-bytes a)
358               (type array-index i))             (type array-index i))
359      #.(declare-buffun)    #.(declare-buffun)
360      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
361                        :signed-word) v))                      :signed-word) v))
362    
363    (defun aref-card32 (a i)  (defun aref-card32 (a i)
364      (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
365               (type array-index i))             (type array-index i))
366      (declare (values card32))    (declare (clx-values card32))
367      #.(declare-buffun)    #.(declare-buffun)
368      (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i    (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
369                              :unsigned-long)))                            :unsigned-long)))
370    
371    (defun aset-card32 (v a i)  (defun aset-card32 (v a i)
372      (declare (type card32 v)    (declare (type card32 v)
373               (type buffer-bytes a)             (type buffer-bytes a)
374               (type array-index i))             (type array-index i))
375      #.(declare-buffun)    #.(declare-buffun)
376      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
377                        :unsigned-long) v))                      :unsigned-long) v))
378    
379    (defun aref-int32 (a i)  (defun aref-int32 (a i)
380      (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
381               (type array-index i))             (type array-index i))
382      (declare (values int32))    (declare (clx-values int32))
383      #.(declare-buffun)    #.(declare-buffun)
384      (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i    (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
385                             :signed-long)))                           :signed-long)))
386    
387    (defun aset-int32 (v a i)  (defun aset-int32 (v a i)
388      (declare (type int32 v)    (declare (type int32 v)
389               (type buffer-bytes a)             (type buffer-bytes a)
390               (type array-index i))             (type array-index i))
391      #.(declare-buffun)    #.(declare-buffun)
392      (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
393                        :signed-long) v))                      :signed-long) v))
   
   (defun aref-card29 (a i)  
     ;; Do I need to mask off a few bits here?  XXX  
     (declare (type buffer-bytes a)  
              (type array-index i))  
     (declare (values card29))  
     #.(declare-buffun)  
     (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                             :unsigned-long)))  
   
   (defun aset-card29 (v a i)  
     (declare (type card29 v)  
              (type buffer-bytes a)  
              (type array-index i))  
     #.(declare-buffun)  
     (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                       :unsigned-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  #+lcl3.0
414  (progn ;; all these lucid optimizations need to be compiled to work.  (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)  (defun aref-card16 (a i)
445      (declare (type buffer-bytes a)
446               (type array-index i)
447               (clx-values card16))
448    #.(declare-buffun)    #.(declare-buffun)
449    (the card16 (sys:svref-16bit (the buffer-bytes a)    (the card16 (lucid::%svref-16bit a (index-ash i -1))))
                                (lucid:ash& (the array-index i) -1))))  
450    
451  (defun aset-card16 (v a i)  (defun aset-card16 (v a i)
452      (declare (type card16 v)
453               (type buffer-bytes a)
454               (type array-index i))
455    #.(declare-buffun)    #.(declare-buffun)
456    (setf (sys:svref-16bit (the buffer-bytes a)    (setf (lucid::%svref-16bit a (index-ash i -1)) v))
                          (lucid:ash& (the array-index i) -1))  
         (the card16 v)))  
457    
458  (defun aref-int16 (a i)  (defun aref-int16 (a i)
459      (declare (type buffer-bytes a)
460               (type array-index i)
461               (clx-values int16))
462    #.(declare-buffun)    #.(declare-buffun)
463    (the int16    (the int16 (lucid::%svref-signed-16bit a (index-ash i -1))))
        (sys:svref-signed-16bit (the buffer-bytes a)  
                                (lucid:ash& (the array-index i) -1))))  
464    
465  (defun aset-int16 (v a i)  (defun aset-int16 (v a i)
466      (declare (type int16 v)
467               (type buffer-bytes a)
468               (type array-index i))
469    #.(declare-buffun)    #.(declare-buffun)
470    (setf (sys:svref-signed-16bit (the buffer-bytes a)    (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v))
                                 (lucid:ash& (the array-index i) -1))  
         (the int16 v)))  
471    
472  (defun aref-card32 (a i)  (defun aref-card32 (a i)
473      (declare (type buffer-bytes a)
474               (type array-index i)
475               (clx-values card32))
476    #.(declare-buffun)    #.(declare-buffun)
477    (the card32    (the card32 (lucid::%svref-32bit a (index-ash i -2))))
        (sys:svref-32bit (the buffer-bytes a)  
                         (lucid:ash& (the array-index i) -2))))  
478    
479  (defun aset-card32 (v a i)  (defun aset-card32 (v a i)
480      (declare (type card32 v)
481               (type buffer-bytes a)
482               (type array-index i))
483    #.(declare-buffun)    #.(declare-buffun)
484    (setf (sys:svref-32bit (the buffer-bytes a)    (setf (lucid::%svref-32bit a (index-ash i -2)) v))
                          (lucid:ash& (the array-index i) -2))  
         (the card32 v)))  
485    
486  (defun aref-int32 (a i)  (defun aref-int32 (a i)
487      (declare (type buffer-bytes a)
488               (type array-index i)
489               (clx-values int32))
490    #.(declare-buffun)    #.(declare-buffun)
491    (the int32    (the int32 (lucid::%svref-signed-32bit a (index-ash i -2))))
        (sys:svref-signed-32bit (the buffer-bytes a)  
                                (lucid:ash& (the array-index i) -2))))  
492    
493  (defun aset-int32 (v a i)  (defun aset-int32 (v a i)
494      (declare (type int32 v)
495               (type buffer-bytes a)
496               (type array-index i))
497    #.(declare-buffun)    #.(declare-buffun)
498    (setf (sys:svref-signed-32bit (the buffer-bytes a)    (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v))
                                 (lucid:ash& (the array-index i) -2))  
         (the int32 v)))  
499    
500  (defun aref-card29 (a i)  (defun aref-card29 (a i)
501    ;; Don't need to mask bits here since X protocol guarantees top bits zero    (declare (type buffer-bytes a)
502               (type array-index i)
503               (clx-values card29))
504    #.(declare-buffun)    #.(declare-buffun)
505    (the card29    (the card29 (lucid::%svref-32bit a (index-ash i -2))))
        (sys:svref-32bit (the buffer-bytes a)  
                         (lucid:ash& (the array-index i) -2))))  
506    
507  (defun aset-card29 (v a i)  (defun aset-card29 (v a i)
508    ;; I also assume here Lisp is passing a number that fits in 29 bits.    (declare (type card29 v)
509               (type buffer-bytes a)
510               (type array-index i))
511    #.(declare-buffun)    #.(declare-buffun)
512    (setf (sys:svref-32bit (the buffer-bytes a)    (setf (lucid::%svref-32bit a (index-ash i -2)) v))
513                           (lucid:ash& (the array-index i) -2))  
         (the card29 v)))  
514  )  )
515    
516    
# Line 487  Line 521 
521  (defun aref-card16 (a i)  (defun aref-card16 (a i)
522    (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
523             (type array-index i))             (type array-index i))
524    (declare (values card16))    (declare (clx-values card16))
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)
542    (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
543             (type array-index i))             (type array-index i))
544    (declare (values int16))    (declare (clx-values int16))
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)
562    (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
563             (type array-index i))             (type array-index i))
564    (declare (values card32))    (declare (clx-values card32))
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)
588    (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
589             (type array-index i))             (type array-index i))
590    (declare (values int32))    (declare (clx-values int32))
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)
614    (declare (type buffer-bytes a)    (declare (type buffer-bytes a)
615             (type array-index i))             (type array-index i))
616    (declare (values card29))    (declare (clx-values card29))
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 630  Line 664 
664  (defun rgb-val->card16 (value)  (defun rgb-val->card16 (value)
665    ;; Short floats are good enough    ;; Short floats are good enough
666    (declare (type rgb-val value))    (declare (type rgb-val value))
667    (declare (values card16))    (declare (clx-values card16))
668    #.(declare-buffun)    #.(declare-buffun)
669    ;; Convert VALUE from float to card16    ;; Convert VALUE from float to card16
670    (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))    (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
# Line 638  Line 672 
672  (defun card16->rgb-val (value)  (defun card16->rgb-val (value)
673    ;; Short floats are good enough    ;; Short floats are good enough
674    (declare (type card16 value))    (declare (type card16 value))
675    (declare (values short-float))    (declare (clx-values short-float))
676    #.(declare-buffun)    #.(declare-buffun)
677    ;; Convert VALUE from card16 to float    ;; Convert VALUE from card16 to float
678    (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))    (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
# Line 646  Line 680 
680  (defun radians->int16 (value)  (defun radians->int16 (value)
681    ;; Short floats are good enough    ;; Short floats are good enough
682    (declare (type angle value))    (declare (type angle value))
683    (declare (values int16))    (declare (clx-values int16))
684    #.(declare-buffun)    #.(declare-buffun)
685    (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))    (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
686    
687  (defun int16->radians (value)  (defun int16->radians (value)
688    ;; Short floats are good enough    ;; Short floats are good enough
689    (declare (type int16 value))    (declare (type int16 value))
690    (declare (values short-float))    (declare (clx-values short-float))
691    #.(declare-buffun)    #.(declare-buffun)
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    #+(or cmu sbcl clisp) (progn
696    
697    ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
698    ;;; is irrational, there can't be a precise rational representation.  In
699    ;;; particular, the different float approximations will always be /=.  This
700    ;;; causes problems with type checking, because people might compute an
701    ;;; argument in any precision.  What we do is discard all the excess precision
702    ;;; in the value, and see if the protocol encoding falls in the desired range
703    ;;; (64'ths of a degree.)
704    ;;;
705    (deftype angle () '(satisfies anglep))
706    
707    (defun anglep (x)
708      (and (typep x 'real)
709           (<= (* -360 64) (radians->int16 x) (* 360 64))))
710    
711    )
712    
713    
714  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
715  ;; Character transformation  ;; Character transformation
# Line 741  Line 794 
794                                                    (cdr pair)))                                                    (cdr pair)))
795                                            array))                                            array))
796                           (defconstant *card8-to-char-translation-table*                           (defconstant *card8-to-char-translation-table*
797                                        ',(let ((array (make-string 256)))                                        ',(let ((array (make-array 256)))
798                                            (dotimes (i (length array))                                            (dotimes (i (length array))
799                                              (setf (aref array i) (code-char i)))                                              (setf (aref array i) (code-char i)))
800                                            (dolist (pair alist)                                            (dolist (pair alist)
# Line 750  Line 803 
803                           #-Genera                           #-Genera
804                           (progn                           (progn
805                             (defun char->card8 (char)                             (defun char->card8 (char)
806                               (declare (type string-char char))                               (declare (type base-char char))
807                               #.(declare-buffun)                               #.(declare-buffun)
808                               (the card8 (aref (the (simple-array card8 (*))                               (the card8 (aref (the (simple-array card8 (*))
809                                                     *char-to-card8-translation-table*)                                                     *char-to-card8-translation-table*)
# Line 758  Line 811 
811                             (defun card8->char (card8)                             (defun card8->char (card8)
812                               (declare (type card8 card8))                               (declare (type card8 card8))
813                               #.(declare-buffun)                               #.(declare-buffun)
814                               (the string-char                               (the base-char
815                                    (aref (the simple-string *card8-to-char-translation-table*)                                    (or (aref (the simple-vector *card8-to-char-translation-table*)
816                                          card8)))                                              card8)
817                                          (error "Invalid CHAR code ~D." card8))))
818                             )                             )
819                           #+Genera                           #+Genera
820                           (progn                           (progn
# Line 771  Line 825 
825                               (declare lt:(side-effects reader reducible))                               (declare lt:(side-effects reader reducible))
826                               (aref *card8-to-char-translation-table* card8))                               (aref *card8-to-char-translation-table* card8))
827                             )                             )
828                             #-Minima
829                           (dotimes (i 256)                           (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"
# Line 778  Line 833 
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 789  Line 845 
845                       (t                       (t
846                        `(progn                        `(progn
847                           (defun char->card8 (char)                           (defun char->card8 (char)
848                             (declare (type string-char char))                             (declare (type base-char char))
849                             #.(declare-buffun)                             #.(declare-buffun)
850                             (the card8 (char-code char)))                             (the card8 (char-code char)))
851                           (defun card8->char (card8)                           (defun card8->char (card8)
852                             (declare (type card8 card8))                             (declare (type card8 card8))
853                             #.(declare-buffun)                             #.(declare-buffun)
854                             (the string-char (code-char card8)))                             (the base-char (code-char card8)))
855                           ))))))                           ))))))
856    (char-translators))    (char-translators))
857    
# Line 810  Line 866 
866    
867  ;;; MAKE-PROCESS-LOCK: Creating a process lock.  ;;; MAKE-PROCESS-LOCK: Creating a process lock.
868    
869  #-(or LispM excl)  #-(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)
# Line 827  Line 883 
883  (defun make-process-lock (name)  (defun make-process-lock (name)
884    (process:make-lock name :flavor 'clx-lock))    (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)
892      (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 835  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  #-(or lispm excl lcl3.0 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 846  Line 914 
914  ;;; against re-entering request functions.  This can happen if an interrupt  ;;; against re-entering request functions.  This can happen if an interrupt
915  ;;; occurs and the handler attempts to use X over the same display connection.  ;;; occurs and the handler attempts to use X over the same display connection.
916  ;;; This can happen if the GC hooks are used to notify the user over the same  ;;; This can happen if the GC hooks are used to notify the user over the same
917  ;;; display connection.  We lock out GC's just as a dummy check for our users.  ;;; display connection.  We inhibit GC notifications since display of them
918  ;;; Locking out interrupts has the problem that CLX always waits for replies  ;;; could cause recursive entry into CLX.
 ;;; within this dynamic scope, so if the server cannot reply for some reason,  
 ;;; we potentially dead-lock without interrupts.  
919  ;;;  ;;;
920  #+CMU  #+(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    (declare (ignore locator display whostate timeout))    `(let #+cmu((ext:*gc-verbose* nil)
924    `(lisp::without-gcing (system:without-interrupts (progn ,@body))))                (ext:*gc-inhibit-hook* nil)
925                  (ext:*before-gc-hooks* nil)
926                  (ext:*after-gc-hooks* nil))
927            #+sbcl()
928         ,locator ,display ,whostate ,timeout
929         (system:without-interrupts (progn ,@body))))
930    
931    ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
932    ;;;
933    #+(and cmu mp)
934    (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
935                                  &key timeout)
936                            &body body)
937      (declare (ignore display))
938      `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
939        ,@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  #+Genera
972  (defmacro holding-lock ((locator display &optional whostate &key timeout)  (defmacro holding-lock ((locator display &optional whostate &key timeout)
# Line 914  Line 1025 
1025                            t)                            t)
1026                           ((lcl:process-wait-with-timeout ,whostate .timeout.                           ((lcl:process-wait-with-timeout ,whostate .timeout.
1027                              #'(lambda ()                              #'(lambda ()
1028                                  (conditional-store ,locator nil lcl:*current-process*)))))                                  (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)                 ,@body)
1034             (unless .have-lock.             (unless .have-lock.
1035               (lcl:process-unlock ,locator))))               (lcl:process-unlock ,locator))))
# Line 942  Line 1057 
1057                           (return-from .hl-doit. nil))                           (return-from .hl-doit. nil))
1058                    `(mp::process-lock .hl-lock. .hl-curproc.                    `(mp::process-lock .hl-lock. .hl-curproc.
1059                                       ,@(when whostate `(,whostate))))                                       ,@(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)))                 (setq .hl-obtained-lock. t)))
1066             ,@body)             ,@body)
1067         (if (and .hl-obtained-lock.         (if (and .hl-obtained-lock.
# Line 952  Line 1072 
1072                  (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))                  (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))
1073             (mp::process-unlock .hl-lock. .hl-curproc.)))))             (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 981  Line 1113 
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    
1116  #-(or lispm excl lcl3.0)  #-(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)
# Line 990  Line 1122 
1122  #+Genera  #+Genera
1123  (defun process-block (whostate predicate &rest predicate-args)  (defun process-block (whostate predicate &rest predicate-args)
1124    (declare (type function predicate)    (declare (type function predicate)
1125             (downward-funarg predicate))             #+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))    (apply #'process:block-process whostate predicate predicate-args))
1130    
1131  #+(and lispm (not Genera))  #+(and lispm (not Genera))
1132  (defun process-block (whostate predicate &rest predicate-args)  (defun process-block (whostate predicate &rest predicate-args)
1133    (declare (type function predicate)    (declare (type function predicate)
1134             (downward-funarg predicate))             #+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))    (apply #'global:process-wait whostate predicate predicate-args))
1139    
1140  #+excl  #+excl
# Line 1011  Line 1149 
1149    (declare (dynamic-extent predicate-args))    (declare (dynamic-extent predicate-args))
1150    (apply #'lcl:process-wait whostate predicate predicate-args))    (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)
1160      (declare (type function predicate))
1161      (mp:process-wait whostate #'(lambda ()
1162                                    (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  #-(or excl Genera)  #-(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)
# Line 1035  Line 1235 
1235  (defun process-wakeup (process)  (defun process-wakeup (process)
1236    (process:wakeup process))    (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)
1245      (declare (ignore process))
1246      (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 1042  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  #-(or lispm excl lcl3.0)  #-(or lispm excl lcl3.0 sbcl Minima (and cmu mp))
1271  (defun current-process ()  (defun current-process ()
1272    nil)    nil)
1273    
# Line 1059  Line 1284 
1284  (defun current-process ()  (defun current-process ()
1285    lcl:*current-process*)    lcl:*current-process*)
1286    
1287    #+Minima
1288    (defun current-process ()
1289      (minima:current-process))
1290    
1291    #+(and cmu mp)
1292    (defun current-process ()
1293      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)  #-(or lispm excl lcl3.0 Minima cmu)
1302  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
1303    `(progn ,@body))    `(progn ,@body))
1304    
# Line 1077  Line 1314 
1314  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
1315    `(lcl:with-scheduling-inhibited ,@body))    `(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 1149  Line 1413 
1413  ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X  ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
1414  ;;; server  ;;; server
1415    
1416  #-(or explorer Genera lucid kcl ibcl excl CMU)  #-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp)
1417  (defun open-x-stream (host display protocol)  (defun open-x-stream (host display protocol)
1418    host display protocol ;; unused    host display protocol ;; unused
1419    (error "OPEN-X-STREAM not implemented yet."))    (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:  ;;; Genera:
1445    
1446  ;;; TCP and DNA are both layered products, so try to work with either one.  ;;; TCP and DNA are both layered products, so try to work with either one.
# Line 1250  Line 1537 
1537        (error "Failed to connect to server: ~A ~D" host display))        (error "Failed to connect to server: ~A ~D" host display))
1538      fd))      fd))
1539    
1540  ;;; OPEN-X-STREAM -- for CMU Common Lisp.  #+Minima
1541  ;;;  (defun open-x-stream (host display protocol)
1542  ;;; The file descriptor here just gets tossed into the stream slot of the    (declare (ignore protocol));; unused
1543  ;;; display object instead of a stream.    (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  #+CMU
1548  (defun open-x-stream (host display protocol)  (defun open-x-stream (host display protocol)
1549    (declare (ignore protocol))    (let ((stream-fd
1550    (let ((server-fd (connect-to-server host display)))           (ecase protocol
1551      (unless (plusp server-fd)             ;; establish a TCP connection to the X11 server, which is
1552        (error "Failed to connect to X11 server: ~A (display ~D)" host display))             ;; listening on port 6000 + display-number
1553      (system:make-fd-stream server-fd :input t :output t             ((:internet :tcp nil)
1554                             :element-type '(unsigned-byte 8))))              (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    
# Line 1274  Line 1622 
1622    (declare (type display display)    (declare (type display display)
1623             (type buffer-bytes vector)             (type buffer-bytes vector)
1624             (type array-index start end)             (type array-index start end)
1625             (type (or null number) timeout))             (type (or null (real 0 *)) timeout))
1626    #.(declare-buffun)    #.(declare-buffun)
1627    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
1628      (or (cond ((null stream))      (or (cond ((null stream))
1629                ((funcall stream :listen) nil)                ((funcall stream :listen) nil)
1630                ((eql timeout 0) :timeout)                ((and timeout (= timeout 0)) :timeout)
1631                ((buffer-input-wait-default display timeout)))                ((buffer-input-wait-default display timeout)))
1632          (multiple-value-bind (ignore eofp)          (multiple-value-bind (ignore eofp)
1633              (funcall stream :string-in nil vector start end)              (funcall stream :string-in nil vector start end)
# Line 1294  Line 1642 
1642    (declare (type display display)    (declare (type display display)
1643             (type buffer-bytes vector)             (type buffer-bytes vector)
1644             (type array-index start end)             (type array-index start end)
1645             (type (or null number) timeout))             (type (or null (real 0 *)) timeout))
1646    #.(declare-buffun)    #.(declare-buffun)
1647    
1648    (let* ((howmany (- end start))    (let* ((howmany (- end start))
1649           (fd (display-input-stream display)))           (fd (display-input-stream display)))
1650      (declare (type array-index howmany)      (declare (type array-index howmany)
1651               (fixnum fd))               (fixnum fd))
   
1652      (or (cond ((fd-char-avail-p fd) nil)      (or (cond ((fd-char-avail-p fd) nil)
1653                ((eql timeout 0) :timeout)                ((and timeout (= timeout 0)) :timeout)
1654                ((buffer-input-wait-default display timeout)))                ((buffer-input-wait-default display timeout)))
1655          (fd-read-bytes fd vector start howmany))))          (fd-read-bytes fd vector start howmany))))
1656    
1657    
1658  #+lcl3.0  #+lcl3.0
1659  (defmacro extract-underlying-stream (stream display direction)  (defmacro with-underlying-stream ((variable stream display direction) &body body)
1660    ;;;Our job is to quickly get at the underlying stream for this display's    `(let ((,variable
1661    ;;;input stream structure.            (or (getf (display-plist ,display) ',direction)
1662    `(or (getf (display-plist ,display) ,direction)                (setf (getf (display-plist ,display) ',direction)
1663         (setf (getf (display-plist ,display) ,direction)                      (lucid::underlying-stream
1664               (lucid::underlying-stream                        ,stream ,(if (eq direction 'input) :input :output))))))
1665                 ,stream (if (eq ,direction 'input) :input :output)))))       ,@body))
1666    
1667  #+lcl3.0  #+lcl3.0
1668  (defun buffer-read-default (display vector start end timeout)  (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    ;;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.    ;;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    ;;We used to inhibit scheduling because there were races in Lucid's
1672    ;;multitasking system.  Empirical evidence suggests they may be gone now.    ;;multitasking system.  Empirical evidence suggests they may be gone now.
1673    ;;Should you decide you need to inhibit scheduling, do it around the do*.    ;;Should you decide you need to inhibit scheduling, do it around the
1674      ;;lcl:read-array.
1675    (declare (type display display)    (declare (type display display)
1676             (type buffer-bytes vector)             (type buffer-bytes vector)
1677             (type array-index start end)             (type array-index start end)
1678             (type (or null number) timeout)             (type (or null (real 0 *)) timeout))
1679             (optimize (speed 3)    #.(declare-buffun)
                      (safety 0)))  
1680    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
1681      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
1682      (or (cond ((null stream))      (or (cond ((null stream))
1683                ((listen stream) nil)                ((listen stream) nil)
1684                ((eql timeout 0) :timeout)                ((and timeout (= timeout 0)) :timeout)
1685                ((buffer-input-wait-default display timeout)))                ((buffer-input-wait-default display timeout)))
1686          (let ((stream (extract-underlying-stream stream display 'input)))          (with-underlying-stream (stream stream display input)
1687            (do* ((index start (index1+ index)))            (eq (lcl:read-array stream vector start end nil :eof) :eof)))))
                ((index>= index end) nil)  
             (declare (type array-index index))  
             (let ((c (lcl:fast-read-byte stream (unsigned-byte 8) nil nil)))  
               (declare (type (or null card8) c))  
               (if (null c)  
                   (return t)  
                   (setf (aref vector index) (the card8 c)))))))))  
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.  ;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
1706  ;;;  ;;;
# Line 1353  Line 1708 
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 1364  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 Genera explorer excl lcl3.0 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)
1754             (type array-index start end)             (type array-index start end)
1755             (type (or null (rational 0 *) (float 0.0 *)) timeout))             (type (or null (real 0 *)) timeout))
1756    #.(declare-buffun)    #.(declare-buffun)
1757    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
1758      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
1759      (or (cond ((null stream))      (or (cond ((null stream))
1760                ((listen stream) nil)                ((listen stream) nil)
1761                ((eql timeout 0) :timeout)                ((and timeout (= timeout 0)) :timeout)
1762                ((buffer-input-wait-default display timeout)))                ((buffer-input-wait-default display timeout)))
1763          (do* ((index start (index1+ index)))          (do* ((index start (index1+ index)))
1764               ((index>= index end) nil)               ((index>= index end) nil)
# Line 1421  Line 1794 
1794    
1795  #+lcl3.0  #+lcl3.0
1796  (defun buffer-write-default (vector display start end)  (defun buffer-write-default (vector display start end)
1797    ;;We inhibit scheduling here because there seem to be races in Lucid's    ;;We used to inhibit scheduling because there were races in Lucid's
1798    ;;multitasking implementation.  Anyway, when we take it out we get bugs!    ;;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)    (declare (type display display)
1802             (type buffer-bytes vector)             (type buffer-bytes vector)
1803             (type array-index start end)             (type array-index start end))
1804             (optimize (:tail-merge nil)    #.(declare-buffun)
1805                       (speed 3)    (let ((stream (display-output-stream display)))
1806                       (safety 0)))      (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)))    (let ((stream (display-output-stream display)))
1819      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
1820      (unless (null stream)      (unless (null stream)
1821        (let ((stream (extract-underlying-stream stream display 'output)))        (minima:write-vector vector stream start end))))
1822          (lcl:with-scheduling-inhibited  
1823            (lcl:write-array stream vector start end))))))  #+CMU
1824    (defun buffer-write-default (vector display start end)
1825      (declare (type buffer-bytes vector)
1826               (type display display)
1827               (type array-index start end))
1828      #.(declare-buffun)
1829      (system:output-raw-bytes (display-output-stream display) vector start end)
1830      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
# Line 1442  Line 1844 
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 Genera explorer excl lcl3.0 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 1458  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  #+excl
# Line 1511  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 Genera explorer excl lcl3.0 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 Genera explorer excl lcl3.0 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 number) timeout))             (type (or null (real 0 *)) timeout))
1914    (declare (values timeout))    (declare (clx-values timeout))
1915    
1916    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
1917      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
1918      (cond ((null stream))      (cond ((null stream))
1919            ((listen stream) nil)            ((listen stream) nil)
1920            ((eql timeout 0) :timeout)            ((and timeout (= timeout 0)) :timeout)
1921            ((not (null timeout))            ((not (null timeout))
1922             (multiple-value-bind (npoll fraction)             (multiple-value-bind (npoll fraction)
1923                 (truncate timeout *buffer-read-polling-time*)                 (truncate timeout *buffer-read-polling-time*)
# Line 1538  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)  (defun buffer-input-wait-default (display timeout)
1936    (declare (type display display)    (declare (type display display)
1937             (type (or null number) timeout))             (type (or null number) timeout))
# Line 1548  Line 1941 
1941            ((listen stream) nil)            ((listen stream) nil)
1942            ((eql timeout 0) :timeout)            ((eql timeout 0) :timeout)
1943            (t            (t
1944             (if (system:wait-until-fd-usable (system:fd-stream-fd stream)             (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream)
1945                                              :input timeout)                                                     :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                 nil
1954                 :timeout)))))                 :timeout)))))
1955    
1956  #+Genera  #+Genera
1957  (defun buffer-input-wait-default (display timeout)  (defun buffer-input-wait-default (display timeout)
1958    (declare (type display display)    (declare (type display display)
1959             (type (or null number) timeout))             (type (or null (real 0 *)) timeout))
1960    (declare (values timeout))    (declare (clx-values timeout))
1961    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
1962      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
1963      (cond ((null stream))      (cond ((null stream))
1964            ((scl:send stream :listen) nil)            ((scl:send stream :listen) nil)
1965            ((eql timeout 0) :timeout)            ((and timeout (= timeout 0)) :timeout)
1966            ((null timeout) (si:stream-input-block stream "CLX Input"))            ((null timeout) (si:stream-input-block stream "CLX Input"))
1967            (t            (t
1968             (scl:condition-bind ((neti:protocol-timeout             (scl:condition-bind ((neti:protocol-timeout
# Line 1576  Line 1976 
1976  #+explorer  #+explorer
1977  (defun buffer-input-wait-default (display timeout)  (defun buffer-input-wait-default (display timeout)
1978    (declare (type display display)    (declare (type display display)
1979             (type (or null number) timeout))             (type (or null (real 0 *)) timeout))
1980    (declare (values timeout))    (declare (clx-values timeout))
1981    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
1982      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
1983      (cond ((null stream))      (cond ((null stream))
1984            ((zl:send stream :listen) nil)            ((zl:send stream :listen) nil)
1985            ((eql timeout 0) :timeout)            ((and timeout (= timeout 0)) :timeout)
1986            ((null timeout)            ((null timeout)
1987             (si:process-wait "CLX Input" stream :listen))             (si:process-wait "CLX Input" stream :listen))
1988            (t            (t
# Line 1596  Line 1996 
1996  ;; This is used so an 'eq' test may be used to find out whether or not we can  ;; 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.  ;; safely throw this process out of the CLX read loop.
1998  ;;  ;;
1999  (defparameter *read-whostate* "blocked on read from X server")  (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,  ;; Note that this function returns nil on error if the scheduler is running,
# Line 1605  Line 2005 
2005  #+excl  #+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 (values timeout))    (declare (clx-values timeout))
2010    (let ((fd (display-input-stream display)))    (let ((fd (display-input-stream display)))
2011      (declare (fixnum fd))      (declare (fixnum fd))
2012      (when (>= fd 0)      (when (>= fd 0)
# Line 1614  Line 2014 
2014               nil)               nil)
2015    
2016              ;; Otherwise no bytes were available on the socket              ;; Otherwise no bytes were available on the socket
2017              ((and timeout (zerop timeout))              ((and timeout (= timeout 0))
2018               ;; If there aren't enough and timeout == 0, timeout.               ;; If there aren't enough and timeout == 0, timeout.
2019               :timeout)               :timeout)
2020    
# Line 1653  Line 2053 
2053  #+lcl3.0  #+lcl3.0
2054  (defun buffer-input-wait-default (display timeout)  (defun buffer-input-wait-default (display timeout)
2055    (declare (type display display)    (declare (type display display)
2056             (type (or null number) timeout)             (type (or null (real 0 *)) timeout)
2057             (optimize (speed 3) (safety 0)))             (clx-values timeout))
2058    (declare (values timeout))    #.(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            ((let ((stream (extract-underlying-stream stream display 'input)))            ((with-underlying-stream (stream stream display input)
2065               (lucid::waiting-for-input-from-stream stream               (lucid::waiting-for-input-from-stream stream
2066                 (lucid::with-io-unlocked                 (lucid::with-io-unlocked
2067                   (if (null timeout)                   (if (null timeout)
# Line 1705  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  ;;  ;;
 #+lispm  
 (defmacro with-stack-list ((var &rest elements) &body body)  
   `(sys:with-stack-list (,var ,@elements) ,@body))  
   
 #+lispm  
 (defmacro with-stack-list* ((var &rest elements) &body body)  
   `(sys:with-stack-list* (,var ,@elements) ,@body))  
   
2108  #-lispm  #-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)
2112    ;; except that the list produced by MAPCAR resides on the stack and    ;; except that the list produced by MAPCAR resides on the stack and
2113    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
2114    `(let ((,var (list ,@elements))) ,@body))    `(let ((,var (list ,@elements)))
2115         (declare (type cons ,var)
2116                  #+clx-ansi-common-lisp (dynamic-extent ,var))
2117         ,@body))
2118    
2119  #-lispm  #-lispm
2120  (defmacro with-stack-list* ((var &rest elements) &body body)  (defmacro with-stack-list* ((var &rest elements) &body body)
# Line 1727  Line 2122 
2122    ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)    ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
2123    ;; except that the list produced by MAPCAR resides on the stack and    ;; except that the list produced by MAPCAR resides on the stack and
2124    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
2125    `(let ((,var (list* ,@elements))) ,@body))    `(let ((,var (list* ,@elements)))
2126         (declare (type cons ,var)
2127                  #+clx-ansi-common-lisp (dynamic-extent ,var))
2128         ,@body))
2129    
2130  (declaim (inline buffer-replace))  (declaim (inline buffer-replace))
2131    
# Line 1747  Line 2145 
2145    (let ((source-end (length source-sequence)))    (let ((source-end (length source-sequence)))
2146      (declare (type array-index source-end))      (declare (type array-index source-end))
2147    
2148      (if* (and (eq target-sequence source-sequence)      (excl:if* (and (eq target-sequence source-sequence)
2149                (> target-start source-start))                     (> target-start source-start))
2150         then (let ((nelts (min (- target-end target-start)         then (let ((nelts (min (- target-end target-start)
2151                                (- source-end source-start))))                                (- source-end source-start))))
2152                (do ((target-index (+ target-start nelts -1) (1- target-index))                (do ((target-index (+ target-start nelts -1) (1- target-index))
# Line 1767  Line 2165 
2165                (setf (aref target-sequence target-index)                (setf (aref target-sequence target-index)
2166                  (aref source-sequence source-index))))))                  (aref source-sequence source-index))))))
2167    
2168  #+cmu  #+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  #+lucid
2181  ;;;The compiler is *supposed* to optimize calls to replace, but in actual  ;;;The compiler is *supposed* to optimize calls to replace, but in actual
# Line 1797  Line 2195 
2195             (type array-index start1 end1 start2))             (type array-index start1 end1 start2))
2196    (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))    (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
2197    
2198  #-(or lispm lucid excl cmu clx-overlapping-arrays)  #-(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))
# Line 1870  Line 2268 
2268         (deallocate-gcontext-state ,saved-state))))         (deallocate-gcontext-state ,saved-state))))
2269    
2270  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
2271  ;;; How error detection should CLX do?  ;;; How much error detection should CLX do?
2272  ;;; Several levels are possible:  ;;; Several levels are possible:
2273  ;;;  ;;;
2274  ;;; 1. Do the equivalent of check-type on every argument.  ;;; 1. Do the equivalent of check-type on every argument.
# Line 1893  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 1902  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?* #+(or cmu Genera) nil #-(or cmu Genera) t)  (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 1915  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    #+cmu    #+(or cmu sbcl clisp)
2319    `(typep ,object ,type)    `(typep ,object ,type)
2320    #-cmu    #-(or cmu sbcl clisp)
2321    (if (not (constantp type))    (if (not (constantp type))
2322        `(typep ,object ,type)        `(typep ,object ,type)
2323      (progn      (progn
2324        (setq type (eval type))        (setq type (eval type))
2325        #+(or Genera explorer)        #+(or Genera explorer Minima)
2326        (if *type-check?*        (if +type-check?+
2327            `(locally (declare (optimize safety)) (typep ,object ',type))            `(locally (declare (optimize safety)) (typep ,object ',type))
2328          `(typep ,object ',type))          `(typep ,object ',type))
2329        #-(or Genera explorer)        #-(or Genera explorer Minima)
2330        (let ((predicate (assoc type        (let ((predicate (assoc type
2331                                '((drawable drawable-p) (window window-p)                                '((drawable drawable-p) (window window-p)
2332                                  (pixmap pixmap-p) (cursor cursor-p)                                  (pixmap pixmap-p) (cursor cursor-p)
# Line 1935  Line 2335 
2335                                  (integer integerp)))))                                  (integer integerp)))))
2336          (cond (predicate          (cond (predicate
2337                 `(,(second predicate) ,object))                 `(,(second predicate) ,object))
2338                ((eq type 'boolean)                ((eq type 'generalized-boolean)
2339                 't)                      ; Everything is a boolean.                 't)                      ; Everything is a generalized-boolean.
2340                (*type-check?*                (+type-check?+
2341                 `(locally (declare (optimize safety)) (typep ,object ',type)))                 `(locally (declare (optimize safety)) (typep ,object ',type)))
2342                (t                (t
2343                 `(typep ,object ',type)))))))                 `(typep ,object ',type)))))))
# Line 1950  Line 2350 
2350    (x-error 'x-type-error    (x-error 'x-type-error
2351             :datum object             :datum object
2352             :expected-type type             :expected-type type
2353             #-CMU :error-string #+CMU :type-string error-string))             :type-string error-string))
2354    
2355    
2356  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
# Line 1961  Line 2361 
2361    
2362  (defun default-error-handler (display error-key &rest key-vals  (defun default-error-handler (display error-key &rest key-vals
2363                                &key asynchronous &allow-other-keys)                                &key asynchronous &allow-other-keys)
2364    (declare (type boolean asynchronous)    (declare (type generalized-boolean asynchronous)
2365             (dynamic-extent key-vals))             (dynamic-extent key-vals))
2366    ;; The default display-error-handler.    ;; The default display-error-handler.
2367    ;; It signals the conditions listed in the DISPLAY file.    ;; It signals the conditions listed in the DISPLAY file.
# Line 1969  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 ansi-common-lisp))  #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2373  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2374    (apply #'sys:signal condition keyargs))    (apply #'sys:signal condition keyargs))
2375    
2376  #+(and lispm (not Genera) (not ansi-common-lisp))  #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2377  (defun x-cerror (proceed-format-string condition &rest keyargs)  (defun x-cerror (proceed-format-string condition &rest keyargs)
2378    (sys:signal (apply #'zl:make-condition condition keyargs)    (sys:signal (apply #'zl:make-condition condition keyargs)
2379                :proceed-types proceed-format-string))                :proceed-types proceed-format-string))
2380    
2381  #+(and Genera (not ansi-common-lisp))  #+(and Genera (not clx-ansi-common-lisp))
2382  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2383    (declare (dbg:error-reporter))    (declare (dbg:error-reporter))
2384    (apply #'sys:signal condition keyargs))    (apply #'sys:signal condition keyargs))
2385    
2386  #+(and Genera (not ansi-common-lisp))  #+(and Genera (not clx-ansi-common-lisp))
2387  (defun x-cerror (proceed-format-string condition &rest keyargs)  (defun x-cerror (proceed-format-string condition &rest keyargs)
2388    (declare (dbg:error-reporter))    (declare (dbg:error-reporter))
2389    (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))    (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))
2390    
2391  #+(or ansi-common-lisp excl lcl3.0)  #+(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 ansi-common-lisp excl lcl3.0)  #+(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 2007  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  #+CMU  #+(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)))
     #|This condition no longer exists.  
     (when (eq condition 'server-disconnect)  
       (let ((disp (server-disconnect-display condx)))  
         (warn "Disabled event handling on ~S." disp)  
         (ext::disable-clx-event-handling disp)))|#  
2413      (when (eq condition 'closed-display)      (when (eq condition 'closed-display)
2414        (let ((disp (closed-display-display condx)))        (let ((disp (closed-display-display condx)))
2415          (warn "Disabled event handling on ~S." disp)          (warn "Disabled event handling on ~S." disp)
2416          (ext::disable-clx-event-handling disp)))          (ext::disable-clx-event-handling disp)))
2417      (error condx)))      (error condx)))
2418    
2419  #+CMU  #-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
 (defun x-cerror (proceed-format-string condition &rest keyargs)  
   (apply #'cerror proceed-format-string condition keyargs))  
   
   
 #-(or lispm ansi-common-lisp excl lcl3.0 CMU)  
2420  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2421    (error "X-Error: ~a"    (error "X-Error: ~a"
2422           (princ-to-string (apply #'make-condition condition keyargs))))           (princ-to-string (apply #'make-condition condition keyargs))))
2423    
2424  #-(or lispm ansi-common-lisp excl lcl3.0 CMU)  #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2425  (defun x-cerror (proceed-format-string condition &rest keyargs)  (defun x-cerror (proceed-format-string condition &rest keyargs)
2426    (cerror proceed-format-string "X-Error: ~a"    (cerror proceed-format-string "X-Error: ~a"
2427           (princ-to-string (apply #'make-condition condition keyargs))))           (princ-to-string (apply #'make-condition condition keyargs))))
# Line 2041  Line 2431 
2431  ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)  ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
2432  ;; or (:report exp)  ;; or (:report exp)
2433    
2434  #+(and lispm (not ansi-common-lisp))  #+lcl3.0
2435  (defmacro define-condition (name parents &body options)  (defmacro define-condition (name parent-types &optional slots &rest args)
2436    (let ((slots (pop options))    `(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)          (documentation nil)
2464          (conc-name (concatenate 'string (string name) "-"))          (conc-name (concatenate 'string (string name) "-"))
2465          (reporter nil))          (reporter nil))
# Line 2053  Line 2469 
2469          (:conc-name (setq conc-name (string (second item))))          (:conc-name (setq conc-name (string (second item))))
2470          (:report (setq reporter (second item)))))          (:report (setq reporter (second item)))))
2471      `(within-definition (,name define-condition)      `(within-definition (,name define-condition)
2472         (zl:defflavor ,name ,slots ,parents         (zl:defflavor ,name ,slot-names ,parent-types
2473           :initable-instance-variables           :initable-instance-variables
2474           #-Genera           #-Genera
2475           (:accessor-prefix ,conc-name)           (:accessor-prefix ,conc-name)
2476           #+Genera           #+Genera
2477           (:conc-name ,conc-name)           (:conc-name ,conc-name)
2478           #-Genera           #-Genera
2479           (:outside-accessible-instance-variables ,@slots)           (:outside-accessible-instance-variables ,@slot-names)
2480           #+Genera           #+Genera
2481           (:readable-instance-variables ,@slots))           (:readable-instance-variables ,@slot-names))
2482         ,(when reporter ;; when no reporter, parent's is inherited         ,(when reporter ;; when no reporter, parent's is inherited
2483            `(zl:defmethod #-Genera (,name :report)            `(zl:defmethod #-Genera (,name :report)
2484                           #+Genera (dbg:report ,name) (stream)                           #+Genera (dbg:report ,name) (stream)
# Line 2075  Line 2491 
2491            `(setf (documentation name 'type) ,documentation))            `(setf (documentation name 'type) ,documentation))
2492         ',name)))         ',name)))
2493    
2494  #+(and lispm (not Genera) (not ansi-common-lisp))  #+(and lispm (not Genera) (not clx-ansi-common-lisp))
2495  (zl:defflavor x-error () (global:error))  (zl:defflavor x-error () (global:error))
2496    
2497  #+(and Genera (not ansi-common-lisp))  #+(and Genera (not clx-ansi-common-lisp))
2498  (scl:defflavor x-error  (scl:defflavor x-error
2499          ((dbg:proceed-types '(:continue))       ;          ((dbg:proceed-types '(:continue))       ;
2500           continue-format-string)           continue-format-string)
2501          (sys:error)          (sys:error)
2502    (:initable-instance-variables continue-format-string))    (:initable-instance-variables continue-format-string))
2503    
2504  #+(and Genera (not ansi-common-lisp))  #+(and Genera (not clx-ansi-common-lisp))
2505  (scl:defmethod (scl:make-instance x-error) (&rest ignore)  (scl:defmethod (scl:make-instance x-error) (&rest ignore)
2506    (when (not (sys:variable-boundp continue-format-string))    (when (not (sys:variable-boundp continue-format-string))
2507      (setf dbg:proceed-types (remove :continue dbg:proceed-types))))      (setf dbg:proceed-types (remove :continue dbg:proceed-types))))
2508    
2509  #+(and Genera (not ansi-common-lisp))  #+(and Genera (not clx-ansi-common-lisp))
2510  (scl:defmethod (dbg:proceed x-error :continue) ()  (scl:defmethod (dbg:proceed x-error :continue) ()
2511    :continue)    :continue)
2512    
2513  #+(and Genera (not ansi-common-lisp))  #+(and Genera (not clx-ansi-common-lisp))
2514  (sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)  (sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
2515    (format stream continue-format-string))    (format stream continue-format-string))
2516    
2517  #+(or ansi-common-lisp excl lcl3.0 CMU)  #+(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 ansi-common-lisp excl lcl3.0 CMU)  #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
2521  (defstruct x-error  (defstruct x-error
2522    report-function)    report-function)
2523    
2524  #-(or lispm ansi-common-lisp excl lcl3.0 CMU)  #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
2525  (defun reporter-for-condition (name)  (defmacro define-condition (name parent-types &body options)
   (xintern "." name '-reporter.))  
   
 #-(or lispm ansi-common-lisp excl lcl3.0 CMU)  
 (defmacro define-condition (name parents &body options)  
2526    ;; Define a structure that when printed displays an error message    ;; Define a structure that when printed displays an error message
2527    (let ((slots (pop options))    (flet ((reporter-for-condition (name)
2528          (documentation nil)             (xintern "." name '-reporter.)))
2529          (conc-name (concatenate 'string (string name) "-"))      (let ((slot-names
2530          (reporter nil)              (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
2531          (condition (gensym))                      (pop options)))
2532          (stream (gensym))            (documentation nil)
2533          (report-function (reporter-for-condition name)))            (conc-name (concatenate 'string (string name) "-"))
2534      (dolist (item options)            (reporter nil)
2535        (ecase (first item)            (condition (gensym))
2536          (:documentation (setq documentation (second item)))            (stream (gensym))
2537          (:conc-name (setq conc-name (string (second item))))            (report-function (reporter-for-condition name)))
2538          (:report (setq reporter (second item)))))        (dolist (item options)
2539      (unless reporter (setq report-function (reporter-for-condition (car parents))))          (ecase (first item)
2540      `(within-definition (,name define-condition)            (:documentation (setq documentation (second item)))
2541         (defstruct (,name (:conc-name ,(intern conc-name))            (:conc-name (setq conc-name (string (second item))))
2542                           (:print-function condition-print)            (:report (setq reporter (second item)))))
2543                           (:include ,(car parents) (report-function ',report-function)))        (unless reporter
2544           ,@slots)          (setq report-function (reporter-for-condition (first parent-types))))
2545         ,(when documentation        `(within-definition (,name define-condition)
2546            `(setf (documentation name 'type) ,documentation))           (defstruct (,name (:conc-name ,(intern conc-name))
2547         ,(when reporter                       (:print-function condition-print)
2548            `(defun ,report-function (,condition ,stream)                       (:include ,(first parent-types)
2549               ,(if (stringp reporter)                        (report-function ',report-function)))
2550                    `(write-string ,reporter ,stream)             ,@slot-names)
2551                  `(,reporter ,condition ,stream))           ,(when documentation
2552               ,condition))              `(setf (documentation name 'type) ,documentation))
2553         ',name)))           ,(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 ansi-common-lisp excl lcl3.0 CMU)  #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2562  (defun condition-print (condition stream depth)  (defun condition-print (condition stream depth)
2563    (declare (type x-error condition)    (declare (type x-error condition)
2564             (type stream stream)             (type stream stream)
# Line 2150  Line 2568 
2568      (funcall (x-error-report-function condition) condition stream))      (funcall (x-error-report-function condition) condition stream))
2569    condition)    condition)
2570    
2571  #-(or lispm ansi-common-lisp excl lcl3.0 CMU)  #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2572  (defun make-condition (type &rest slot-initializations)  (defun make-condition (type &rest slot-initializations)
2573    (declare (dynamic-extent slot-initializations))    (declare (dynamic-extent slot-initializations))
2574    (let ((make-function (intern (concatenate 'string (string 'make-) (string type))    (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
2575                                 (symbol-package type))))                                 (symbol-package type))))
2576      (apply make-function slot-initializations)))      (apply make-function slot-initializations)))
2577    
2578  #-(or ansi-common-lisp excl lcl3.0 CMU)  #-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
2579  (define-condition type-error (x-error)  (define-condition type-error (x-error)
2580    (datum    ((datum :reader type-error-datum :initarg :datum)
2581     expected-type)     (expected-type :reader type-error-expected-type :initarg :expected-type))
2582    (:report (lambda (condition stream)    (:report
2583               (format stream "~s isn't a ~a"      (lambda (condition stream)
2584                       (type-error-datum condition)        (format stream "~s isn't a ~a"
2585                       (type-error-expected-type condition)))))                (type-error-datum condition)
2586                  (type-error-expected-type condition)))))
2587    
2588    
2589  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2590  ;;  HOST hacking  ;;  HOST hacking
2591  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2592    
2593  #-(or explorer Genera)  #-(or explorer Genera Minima Allegro CMU sbcl ecl clisp)
2594  (defun host-address (host &optional (family :internet))  (defun host-address (host &optional (family :internet))
2595    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2596    ;; and cdr is a list of network address bytes.    ;; and cdr is a list of network address bytes.
2597    (declare (type (or stringable list) host)    (declare (type stringable host)
2598             (type (or null (member :internet :decnet :chaos) card8) family))             (type (or null (member :internet :decnet :chaos) card8) family))
2599    (declare (values list))    (declare (clx-values list))
2600    host family    host family
2601    (error "HOST-ADDRESS not implemented yet."))    (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  #+explorer
2643  (defun host-address (host &optional (family :internet))  (defun host-address (host &optional (family :internet))
2644    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2645    ;; and cdr is a list of network address bytes.    ;; and cdr is a list of network address bytes.
2646    (declare (type (or stringable list) host)    (declare (type stringable host)
2647             (type (or null (member :internet :decnet :chaos) card8) family))             (type (or null (member :internet :decnet :chaos) card8) family))
2648    (declare (values list))    (declare (clx-values list))
2649    (ecase family    (ecase family
2650      (:internet      ((:internet nil 0)
2651       (let ((addr (ip:get-ip-address host)))       (let ((addr (ip:get-ip-address host)))
2652         (unless addr (error "~s isn't an internet host name" host))         (unless addr (error "~s isn't an internet host name" host))
2653         (list :internet         (list :internet
# Line 2197  Line 2655 
2655               (ldb (byte 8 16) addr)               (ldb (byte 8 16) addr)
2656               (ldb (byte 8 8) addr)               (ldb (byte 8 8) addr)
2657               (ldb (byte 8 0) addr))))               (ldb (byte 8 0) addr))))
2658      (:chaos      ((:chaos 2)
2659       (let ((addr (first (chaos:chaos-addresses host))))       (let ((addr (first (chaos:chaos-addresses host))))
2660         (unless addr (error "~s isn't a chaos host name" host))         (unless addr (error "~s isn't a chaos host name" host))
2661         (list :chaos         (list :chaos
# Line 2208  Line 2666 
2666  (defun host-address (host &optional (family :internet))  (defun host-address (host &optional (family :internet))
2667    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2668    ;; and cdr is a list of network address bytes.    ;; and cdr is a list of network address bytes.
2669    (declare (type (or stringable list) host)    (declare (type stringable host)
2670             (type (or null (member :internet :decnet :chaos) card8) family))             (type (or null (member :internet :decnet :chaos) card8) family))
2671    (declare (values list))    (declare (clx-values list))
2672    (let ((net-type (if (eq family :DECnet)    (setf host (string host))
2673                        :DNA    (let ((net-type (ecase family
2674                        family)))                      ((:internet nil 0) :internet)
2675                        ((:DECnet 1) :dna)
2676                        ((:chaos 2) :chaos))))
2677      (dolist (addr      (dolist (addr
2678                (sys:send (net:parse-host host) :network-addresses)                (sys:send (net:parse-host host) :network-addresses)
2679                (error "~s isn't a valid ~(~A~) host name" host family))                (error "~S isn't a valid ~(~A~) host name" host family))
2680        (let ((network (car addr))        (let ((network (car addr))
2681              (address (cadr addr)))              (address (cadr addr)))
2682          (when (sys:send network :network-typep net-type)          (when (sys:send network :network-typep net-type)
2683            (return (ecase family            (return (ecase family
2684                      (:internet                      ((:internet nil 0)
2685                        (multiple-value-bind (a b c d) (tcp:explode-internet-address address)                       (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
2686                          (list :internet a b c d)))                         (list :internet a b c d)))
2687                      ((:chaos :DECnet)                      ((:DECnet 1)
2688                       (list family (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))                       (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))
2743      ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
2744      ;; and cdr is a list of network address bytes.
2745      (declare (type stringable host)
2746               (type (or null (member :internet :decnet :chaos) card8) family))
2747      (declare (clx-values list))
2748      (labels ((no-host-error ()
2749                 (error "Unknown host ~S" host))
2750               (no-address-error ()
2751                 (error "Host ~S has no ~S address" host family)))
2752        (let ((hostent (ext:lookup-host-entry (string host))))
2753          (when (not hostent)
2754            (no-host-error))
2755          (ecase family
2756            ((:internet nil 0)
2757             (unless (= (ext::host-entry-addr-type hostent) 2)
2758               (no-address-error))
2759             (append (list :internet)
2760                     (let ((addr (first (ext::host-entry-addr-list hostent))))
2761                            (list (ldb (byte 8 24) addr)
2762                                  (ldb (byte 8 16) addr)
2763                                  (ldb (byte 8  8) addr)
2764                                  (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  #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts
2802  (defun get-host (host-object)  (defun get-host (host-object)
2803    ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)    ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
2804    ;; and cdr is a list of network address bytes.    ;; and cdr is a list of network address bytes.
2805    (declare (type list host-object))    (declare (type list host-object))
2806    (declare (values string family))    (declare (clx-values string family))
2807    (let* ((family (first host-object))    (let* ((family (first host-object))
2808           (address (ecase family           (address (ecase family
2809                      (:internet                      (:internet
# Line 2255  Line 2826 
2826    ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)    ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
2827    ;; and cdr is a list of network address bytes.    ;; and cdr is a list of network address bytes.
2828    (declare (type list host-object))    (declare (type list host-object))
2829    (declare (values string family))    (declare (clx-values string family))
2830    (let ((family (first host-object)))    (let ((family (first host-object)))
2831      (values (sys:send (net:get-host-from-address      (values (sys:send (net:get-host-from-address
2832                          (ecase family                          (ecase family
# Line 2269  Line 2840 
2840                        :name)                        :name)
2841              family)))              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  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2859  ;; Whether to use closures for requests or not.  ;; Whether to use closures for requests or not.
# Line 2281  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    #+lispm t #-lispm 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)
2879      (macroexpand form env))
2880    
2881    
2882  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
# Line 2289  Line 2884 
2884  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2885    
2886    
2887    ;;; Utilities
2888    
2889    (defun getenv (name)
2890      #+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)
2910      (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
2911           (merge-pathnames (user-homedir-pathname) (pathname name))))
2912    
2913  ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if  ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
2914  ;;; a resource manager isn't running.  ;;; a resource manager isn't running.
2915    
2916  (defun default-resources-pathname ()  (defun default-resources-pathname ()
2917    (when #+(or unix mach) t    (homedir-file-pathname ".Xdefaults"))
         #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)  
     (merge-pathnames (user-homedir-pathname) (pathname ".Xdefaults"))))  
   
   
2918    
2919  ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the  ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
2920  ;;; defaults have been loaded.  ;;; defaults have been loaded.
2921    
2922  (defun resources-pathname ()  (defun resources-pathname ()
2923    (when #+(or unix mach) t    (or (let ((string (getenv "XENVIRONMENT")))
2924          #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)          (and string
2925      (or #+(or excl lcl3.0 CMU)               (pathname string)))
2926          (let ((string #-CMU (#+excl sys:getenv        (homedir-file-pathname
2927                                      #+lcl3.0 lcl:environment-variable         (concatenate 'string ".Xdefaults-" (get-host-name)))))
2928                                      "XENVIRONMENT")  
2929                        #+CMU (cdr (assoc :xenvironment ext:*environment-list*))))  ;;; AUTHORITY-PATHNAME - The pathname of the authority file.
2930            (when string  
2931              (pathname string)))  (defun authority-pathname ()
2932          (merge-pathnames    (or (let ((xauthority (getenv "XAUTHORITY")))
2933            (user-homedir-pathname)          (and xauthority
2934            (pathname               (pathname xauthority)))
2935              (concatenate 'simple-string ".Xdefaults-"        (homedir-file-pathname ".Xauthority")))
2936                           #+excl (short-site-name)  
2937                           #-excl (machine-instance)))))))  ;;; 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
2984  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2985    
2986  #+Genera  (defun gc-cleanup ()
 (si:define-gc-cleanup clx-cleanup ("CLX Cleanup")  
2987    (declare (special *event-free-list*    (declare (special *event-free-list*
2988                      *pending-command-free-list*                      *pending-command-free-list*
2989                      *reply-buffer-free-lists*                      *reply-buffer-free-lists*
# Line 2333  Line 2991 
2991                      *temp-gcontext-cache*))                      *temp-gcontext-cache*))
2992    (setq *event-free-list* nil)    (setq *event-free-list* nil)
2993    (setq *pending-command-free-list* nil)    (setq *pending-command-free-list* nil)
2994    (fill *reply-buffer-free-lists* nil)    (when (boundp '*reply-buffer-free-lists*)
2995        (fill *reply-buffer-free-lists* nil))
2996    (setq *gcontext-local-state-cache* nil)    (setq *gcontext-local-state-cache* nil)
2997    (setq *temp-gcontext-cache* nil))    (setq *temp-gcontext-cache* nil)
2998      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    ;;-----------------------------------------------------------------------------
3038    ;; DEFAULT-KEYSYM-TRANSLATE
3039    ;;-----------------------------------------------------------------------------
3040    
3041    ;;; If object is a character, char-bits are set from state.
3042    ;;;
3043    ;;; [the following isn't implemented (should it be?)]
3044    ;;; If object is a list, it is an alist with entries:
3045    ;;; (base-char [modifiers] [mask-modifiers])
3046    ;;; When MODIFIERS are specified, this character translation
3047    ;;; will only take effect when the specified modifiers are pressed.
3048    ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
3049    ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
3050    ;;; 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)
3077      (declare (type display display)
3078               (type card16 state)
3079               (type t object)
3080               (ignore display state)
3081               (clx-values t))
3082      object)
3083    
3084    
3085  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
3086  ;; Image stuff  ;; Image stuff
3087  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
3088    
3089    ;;; Types
3090    
3091  (deftype pixarray-1-element-type ()  (deftype pixarray-1-element-type ()
3092    'bit)    'bit)
3093    
3094  (deftype pixarray-4-element-type ()  (deftype pixarray-4-element-type ()
3095    'card4)    '(unsigned-byte 4))
3096    
3097  (deftype pixarray-8-element-type ()  (deftype pixarray-8-element-type ()
3098    'card8)    '(unsigned-byte 8))
3099    
3100  (deftype pixarray-16-element-type ()  (deftype pixarray-16-element-type ()
3101    'card16)    '(unsigned-byte 16))
3102    
3103  (deftype pixarray-24-element-type ()  (deftype pixarray-24-element-type ()
3104    #-Genera 'card24 #+Genera 'int32)    '(unsigned-byte 24))
3105    
3106  (deftype pixarray-32-element-type ()  (deftype pixarray-32-element-type ()
3107    #-Genera 'card32 #+Genera 'int32)    #-(or Genera Minima) '(unsigned-byte 32)
3108      #+(or Genera Minima) 'fixnum)
3109    
3110  (deftype pixarray-1  ()  (deftype pixarray-1  ()
3111    '(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    '(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    '(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    '(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    '(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    '(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 2384  Line 3136 
3136  (deftype bitmap ()  (deftype bitmap ()
3137    'pixarray-1)    'pixarray-1)
3138    
3139    ;;; WITH-UNDERLYING-SIMPLE-VECTOR
3140    
3141    #+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.
3174    ;;; Element-type is ignored.
3175    ;;;
3176    (defmacro with-underlying-simple-vector
3177        ((variable element-type pixarray) &body body)
3178      (declare (ignore element-type))
3179      `(#+cmu lisp::with-array-data #+sbcl sb-kernel:with-array-data
3180        ((,variable ,pixarray) (start) (end))
3181        (declare (ignore start end))
3182        ,@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)))
3190    `(the (unsigned-byte ,size)    `(the (unsigned-byte ,size)
3191          (#-Genera ldb #+Genera sys:%logldb          (#-Genera ldb #+Genera sys:%logldb
3192           (byte ,size ,(if *image-bit-lsb-first-p* position (- 7 position)))           (byte ,size ,position)
3193           (the card8 ,integer))))           (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    (let* ((bytes (if *image-byte-lsb-first-p* bytes (reverse bytes)))    (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes)))
3200           (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              `(#-Genera dpb #+Genera sys:%logdpb              `(#-Genera dpb #+Genera sys:%logdpb
# Line 2416  Line 3213 
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)))
3217    `(the card8    `(the card8
3218          (#-Genera ldb #+Genera sys:%logldb          (#-Genera ldb #+Genera sys:%logldb
3219            (byte 8 ,(if *image-byte-lsb-first-p*           (byte 8 ,position)
3220                         position           #-Genera (the (unsigned-byte ,integer-size) ,integer)
3221                       (- integer-size 8 position)))           #+Genera ,integer
3222            #-Genera (the (unsigned-byte ,integer-size) ,integer)           )))
           #+Genera ,integer  
           )))  
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    (let* ((bytes (if *image-bit-lsb-first-p* bytes (reverse bytes)))    (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes)))
3229           (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 `(#-Genera dpb #+Genera sys:%logdpb        (setq it `(#-Genera dpb #+Genera sys:%logdpb
3234                   (the (unsigned-byte ,size) ,byte)                   (the (unsigned-byte ,size) ,byte)
# Line 2440  Line 3236 
3236                   (the (unsigned-byte ,count) ,it))))                   (the (unsigned-byte ,count) ,it))))
3237      `(the card8 ,it)))      `(the card8 ,it)))
3238    
3239  #+cmu  #+(or Genera lcl3.0 excl)
3240  (progn  (defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+)
3241    (declaim (inline underlying-simple-vector))  
3242    (defun underlying-simple-vector (x)  #+(or Genera lcl3.0 excl)
3243      (lisp::with-array-data ((res x)  (defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+)
3244                              (start)  
3245                              (end))  ;;; The following table gives the bit ordering within bytes (when accessed
3246        (declare (ignore start end))  ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
3247        res)))  ;;; 31, where bit 0 should be leftmost on the display.  For a given byte
3248    ;;; labelled A-B, A is for the most significant bit of the byte, and B is
3249    ;;; for the least significant bit.
3250    ;;;
3251    ;;; legend:
3252    ;;;     1   scanline-unit = 8
3253    ;;;     2   scanline-unit = 16
3254    ;;;     4   scanline-unit = 32
3255    ;;;     M   byte-order = MostSignificant
3256    ;;;     L   byte-order = LeastSignificant
3257    ;;;     m   bit-order = MostSignificant
3258    ;;;     l   bit-order = LeastSignificant
3259    ;;;
3260    ;;;
3261    ;;; format      ordering
3262    ;;;
3263    ;;; 1Mm 00-07 08-15 16-23 24-31
3264    ;;; 2Mm 00-07 08-15 16-23 24-31
3265    ;;; 4Mm 00-07 08-15 16-23 24-31
3266    ;;; 1Ml 07-00 15-08 23-16 31-24
3267    ;;; 2Ml 15-08 07-00 31-24 23-16
3268    ;;; 4Ml 31-24 23-16 15-08 07-00
3269    ;;; 1Lm 00-07 08-15 16-23 24-31
3270    ;;; 2Lm 08-15 00-07 24-31 16-23
3271    ;;; 4Lm 24-31 16-23 08-15 00-07
3272    ;;; 1Ll 07-00 15-08 23-16 31-24
3273    ;;; 2Ll 07-00 15-08 23-16 31-24
3274    ;;; 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 lcl3.0 excl cmu)  #+(or lcl3.0 excl)
3343  (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height  (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height
3344                               padded-bytes-per-line)                               padded-bytes-per-line bits-per-pixel)
3345    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
3346             (type pixarray-1 array)             (type pixarray-1 array)
3347             (type card16 x y width height)             (type card16 x y width height)
3348             (type array-index index padded-bytes-per-line))             (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)    #.(declare-buffun)
3352    (with-vector (buffer-bbuf buffer-bytes)    (with-vector (buffer-bbuf buffer-bytes)
3353      (do* ((vector (underlying-simple-vector array))      (with-underlying-simple-vector (vector pixarray-1-element-type array)
3354            (start (index+ index        (do* ((start (index+ index
3355                           (index* y padded-bytes-per-line)                             (index* y padded-bytes-per-line)
3356                           (index-ceiling x 8))                             (index-ceiling x 8))
3357                   (index+ start padded-bytes-per-line))                     (index+ start padded-bytes-per-line))
3358            (y 0 (index1+ y))              (y 0 (index1+ y))
3359            (left-bits (the array-index (mod (the fixnum (- x)) 8)))              (left-bits (the array-index (mod (the fixnum (- x)) 8)))
3360            (right-bits (index-mod (index- width left-bits) 8))              (right-bits (index-mod (index- width left-bits) 8))
3361            (middle-bits (the fixnum (- (the fixnum (- width left-bits))              (middle-bits (the fixnum (- (the fixnum (- width left-bits))
3362                                        right-bits)))                                          right-bits)))
3363            (middle-bytes (index-floor middle-bits 8)))              (middle-bytes (index-floor middle-bits 8)))
3364           ((index>= y height))             ((index>= y height))
3365        (declare (type (simple-array pixarray-1-element-type (*)) vector)          (declare (type array-index start y
3366                 (fixnum middle-bits)                         left-bits right-bits middle-bytes)
3367                 (type array-index start y                   (fixnum middle-bits))
3368                       left-bits right-bits middle-bytes))          (cond ((< middle-bits 0)
       (cond ((< middle-bits 0)  
              (let ((byte (aref buffer-bbuf (index1- start)))  
                    (x (array-row-major-index array y left-bits)))  
                (declare (type card8 byte)  
                         (type array-index x))  
                (when (index> right-bits 6)  
                  (setf (aref vector (index- x 1))  
                        (read-image-load-byte 1 7 byte)))  
                (when (and (index> left-bits 1)  
                           (index> right-bits 5))  
                  (setf (aref vector (index- x 2))  
                        (read-image-load-byte 1 6 byte)))  
                (when (and (index> left-bits 2)  
                           (index> right-bits 4))  
                  (setf (aref vector (index- x 3))  
                        (read-image-load-byte 1 5 byte)))  
                (when (and (index> left-bits 3)  
                           (index> right-bits 3))  
                  (setf (aref vector (index- x 4))  
                        (read-image-load-byte 1 4 byte)))  
                (when (and (index> left-bits 4)  
                           (index> right-bits 2))  
                  (setf (aref vector (index- x 5))  
                        (read-image-load-byte 1 3 byte)))  
                (when (and (index> left-bits 5)  
                           (index> right-bits 1))  
                  (setf (aref vector (index- x 6))  
                        (read-image-load-byte 1 2 byte)))  
                (when (index> left-bits 6)  
                  (setf (aref vector (index- x 7))  
                        (read-image-load-byte 1 1 byte)))))  
             (t  
              (unless (index-zerop left-bits)  
3369                 (let ((byte (aref buffer-bbuf (index1- start)))                 (let ((byte (aref buffer-bbuf (index1- start)))
3370                       (x (array-row-major-index array y left-bits)))                       (x (array-row-major-index array y left-bits)))
3371                   (declare (type card8 byte)                   (declare (type card8 byte)
3372                            (type array-index x))                            (type array-index x))
3373                   (setf (aref vector (index- x 1))                   (when (index> right-bits 6)
3374                         (read-image-load-byte 1 7 byte))                     (setf (aref vector (index- x 1))
3375                   (when (index> left-bits 1)                           (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))                     (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))                           (read-image-load-byte 1 6 byte))
3474                     (when (index> left-bits 2)                     (setf (aref vector (index+ x 7))
3475                       (setf (aref vector (index- x 3))                           (read-image-load-byte 1 7 byte))))
3476                             (read-image-load-byte 1 5 byte))                 )))))
3477                       (when (index> left-bits 3)      t)
                        (setf (aref vector (index- x 4))  
                              (read-image-load-byte 1 4 byte))  
                        (when (index> left-bits 4)  
                          (setf (aref vector (index- x 5))  
                                (read-image-load-byte 1 3 byte))  
                          (when (index> left-bits 5)  
                            (setf (aref vector (index- x 6))  
                                  (read-image-load-byte 1 2 byte))  
                            (when (index> left-bits 6)  
                              (setf (aref vector (index- x 7))  
                                    (read-image-load-byte 1 1 byte))  
                              ))))))))  
              (do* ((end (index+ start middle-bytes))  
                    (i start (index1+ i))  
                    (x (array-row-major-index array y left-bits) (index+ x 8)))  
                   ((index>= i end)  
                    (unless (index-zerop right-bits)  
                      (let ((byte (aref buffer-bbuf end))  
                            (x (array-row-major-index  
                                 array y (index+ left-bits middle-bits))))  
                        (declare (type card8 byte)  
                                 (type array-index x))  
                        (setf (aref vector (index+ x 0))  
                              (read-image-load-byte 1 0 byte))  
                        (when (index> right-bits 1)  
                          (setf (aref vector (index+ x 1))  
                                (read-image-load-byte 1 1 byte))  
                          (when (index> right-bits 2)  
                            (setf (aref vector (index+ x 2))  
                                  (read-image-load-byte 1 2 byte))  
                            (when (index> right-bits 3)  
                              (setf (aref vector (index+ x 3))  
                                    (read-image-load-byte 1 3 byte))  
                              (when (index> right-bits 4)  
                                (setf (aref vector (index+ x 4))  
                                      (read-image-load-byte 1 4 byte))  
                                (when (index> right-bits 5)  
                                  (setf (aref vector (index+ x 5))  
                                        (read-image-load-byte 1 5 byte))  
                                  (when (index> right-bits 6)  
                                    (setf (aref vector (index+ x 6))  
                                          (read-image-load-byte 1 6 byte))  
                                    )))))))))  
                (declare (type array-index end i x))  
                (let ((byte (aref buffer-bbuf i)))  
                  (declare (type card8 byte))  
                  (setf (aref vector (index+ x 0))  
                        (read-image-load-byte 1 0 byte))  
                  (setf (aref vector (index+ x 1))  
                        (read-image-load-byte 1 1 byte))  
                  (setf (aref vector (index+ x 2))  
                        (read-image-load-byte 1 2 byte))  
                  (setf (aref vector (index+ x 3))  
                        (read-image-load-byte 1 3 byte))  
                  (setf (aref vector (index+ x 4))  
                        (read-image-load-byte 1 4 byte))  
                  (setf (aref vector (index+ x 5))  
                        (read-image-load-byte 1 5 byte))  
                  (setf (aref vector (index+ x 6))  
                        (read-image-load-byte 1 6 byte))  
                  (setf (aref vector (index+ x 7))  
                        (read-image-load-byte 1 7 byte))))  
              ))))  
   t)  
3478    
3479  #+(or lcl3.0 excl cmu)  #+(or lcl3.0 excl)
3480  (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height  (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height
3481                               padded-bytes-per-line)                               padded-bytes-per-line bits-per-pixel)
3482    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
3483             (type pixarray-4 array)             (type pixarray-4 array)
3484             (type card16 x y width height)             (type card16 x y width height)
3485             (type array-index index padded-bytes-per-line))             (type array-index index padded-bytes-per-line)
3486    #.(declare-buffun)             (type (member 1 4 8 16 24 32) bits-per-pixel)
3487    (with-vector (buffer-bbuf buffer-bytes)             (ignore bits-per-pixel))
     (do* ((vector (underlying-simple-vector array))  
           (start (index+ index  
                          (index* y padded-bytes-per-line)  
                          (index-ceiling x 2))  
                  (index+ start padded-bytes-per-line))  
           (y 0 (index1+ y))  
           (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x)))  
                                         2)))  
           (right-nibbles (index-mod (index- width left-nibbles) 2))  
           (middle-nibbles (index- width left-nibbles right-nibbles))  
           (middle-bytes (index-floor middle-nibbles 2)))  
          ((index>= y height))  
       (declare (type (simple-array pixarray-4-element-type (*)) vector)  
                (type array-index start y  
                      left-nibbles right-nibbles middle-nibbles middle-bytes))  
       (unless (index-zerop left-nibbles)  
         (setf (aref array y 0)  
               (read-image-load-byte  
                 4 4 (aref buffer-bbuf (index1- start)))))  
       (do* ((end (index+ start middle-bytes))  
             (i start (index1+ i))  
             (x (array-row-major-index array y left-nibbles) (index+ x 2)))  
            ((index>= i end)  
             (unless (index-zerop right-nibbles)  
               (setf (aref array y (index+ left-nibbles middle-nibbles))  
                     (read-image-load-byte 4 0 (aref buffer-bbuf end)))))  
         (declare (type array-index end i x))  
         (let ((byte (aref buffer-bbuf i)))  
           (declare (type card8 byte))  
           (setf (aref vector (index+ x 0))  
                 (read-image-load-byte 4 0 byte))  
           (setf (aref vector (index+ x 1))  
                 (read-image-load-byte 4 4 byte))))  
       ))  
   t)  
   
 #+(or lcl3.0 excl cmu)  
 (defun fast-read-pixarray-8 (buffer-bbuf index array x y width height  
                              padded-bytes-per-line)  
   (declare (type buffer-bytes buffer-bbuf)  
            (type pixarray-8 array)  
            (type card16 x y width height)  
            (type array-index index padded-bytes-per-line))  
   #.(declare-buffun)  
   (with-vector (buffer-bbuf buffer-bytes)  
     (do* ((vector (underlying-simple-vector array))  
           (start (index+ index  
                          (index* y padded-bytes-per-line)  
                          x)  
                  (index+ start padded-bytes-per-line))  
           (y 0 (index1+ y)))  
          ((index>= y height))  
       (declare (type (simple-array pixarray-8-element-type (*)) vector)  
                (type array-index start y))  
       (do* ((end (index+ start width))  
             (i start (index1+ i))  
             (x (array-row-major-index array y 0) (index1+ x)))  
            ((index>= i end))  
         (declare (type array-index end i x))  
         (setf (aref vector x)  
               (the card8 (aref buffer-bbuf i))))))  
   t)  
   
 #+(or lcl3.0 excl cmu)  
 (defun fast-read-pixarray-16 (buffer-bbuf index array x y width height  
                               padded-bytes-per-line)  
   (declare (type buffer-bytes buffer-bbuf)  
            (type pixarray-16 array)  
            (type card16 width height)  
            (type array-index index padded-bytes-per-line))  
3488    #.(declare-buffun)    #.(declare-buffun)
3489    (with-vector (buffer-bbuf buffer-bytes)    (with-vector (buffer-bbuf buffer-bytes)
3490      (do* ((vector (underlying-simple-vector array))      (with-underlying-simple-vector (vector pixarray-4-element-type array)
3491            (start (index+ index        (do* ((start (index+ index
3492                           (index* y padded-bytes-per-line)                             (index* y padded-bytes-per-line)
3493                           (index* x 2))                             (index-ceiling x 2))
3494                   (index+ start padded-bytes-per-line))                     (index+ start padded-bytes-per-line))
3495            (y 0 (index1+ y)))              (y 0 (index1+ y))
3496           ((index>= y height))              (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x)))
3497        (declare (type (simple-array pixarray-16-element-type (*)) vector)                                                  2)))
3498                 (type array-index start y))              (right-nibbles (index-mod (index- width left-nibbles) 2))
3499        (do* ((end (index+ start (index* width 2)))              (middle-nibbles (index- width left-nibbles right-nibbles))
3500              (i start (index+ i 2))              (middle-bytes (index-floor middle-nibbles 2)))
3501              (x (array-row-major-index array y 0) (index1+ x)))             ((index>= y height))
3502             ((index>= i end))          (declare (type array-index start y
3503          (declare (type array-index end i x))                         left-nibbles right-nibbles middle-nibbles middle-bytes))
3504          (setf (aref vector x)          (unless (index-zerop left-nibbles)
3505                (read-image-assemble-bytes            (setf (aref array y 0)
3506                  (aref buffer-bbuf (index+ i 0))                  (read-image-load-byte
3507                  (aref buffer-bbuf (index+ i 1)))))))                    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)    t)
3524    
3525  #+Genera  #+(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)                                padded-bytes-per-line bits-per-pixel)
3528    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
3529             (type pixarray-24 array)             (type pixarray-24 array)
3530             (type card16 width height)             (type card16 width height)
3531             (type array-index index padded-bytes-per-line))             (type array-index index padded-bytes-per-line)
3532               (type (member 1 4 8 16 24 32) bits-per-pixel)
3533               (ignore bits-per-pixel))
3534    #.(declare-buffun)    #.(declare-buffun)
3535    (with-vector (buffer-bbuf buffer-bytes)    (with-vector (buffer-bbuf buffer-bytes)
3536      (do* ((array array)      (with-underlying-simple-vector (vector pixarray-24-element-type array)
3537            (start (index+ index        (do* ((start (index+ index
3538                           (index* y padded-bytes-per-line)                             (index* y padded-bytes-per-line)
3539                           (index* x 3))                             (index* x 3))
3540                   (index+ start padded-bytes-per-line))                     (index+ start padded-bytes-per-line))
3541            (y 0 (index1+ y)))              (y 0 (index1+ y)))
3542           ((index>= y height))             ((index>= y height))
3543        (declare (sys:array-register-1d array)          (declare (type array-index start y))
3544                 (type array-index start y))          (do* ((end (index+ start (index* width 3)))
3545        (do* ((end (index+ start (index* width 3)))                (i start (index+ i 3))
3546              (i start (index+ i 3))                (x (array-row-major-index array y 0) (index1+ x)))
3547              (x (array-row-major-index array y 0) (index1+ x)))               ((index>= i end))
3548             ((index>= i end))            (declare (type array-index end i x))
3549          (declare (type array-index end i x))            (setf (aref vector x)
3550          (setf (sys:%1d-aref array x)                  (read-image-assemble-bytes
3551                (read-image-assemble-bytes                    (aref buffer-bbuf (index+ i 0))
3552                  (aref buffer-bbuf (index+ i 0))                    (aref buffer-bbuf (index+ i 1))
3553                  (aref buffer-bbuf (index+ i 1))                    (aref buffer-bbuf (index+ i 2))))))))
                 (aref buffer-bbuf (index+ i 2)))))))  
3554    t)    t)
3555    
3556  #+(or lcl3.0 excl cmu)  #+lispm
3557  (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height  (defun fast-read-pixarray-using-bitblt
3558                                padded-bytes-per-line)         (bbuf boffset pixarray x y width height padded-bytes-per-line
3559    (declare (type buffer-bytes buffer-bbuf)          bits-per-pixel)
3560             (type pixarray-24 array)    (#+Genera sys:stack-let* #-Genera let*
3561             (type card16 width height)     ((dimensions (list (+ y height)
3562             (type array-index index padded-bytes-per-line))                        (floor (* padded-bytes-per-line 8) bits-per-pixel)))
3563    #.(declare-buffun)      (a (make-array
3564    (with-vector (buffer-bbuf buffer-bytes)           dimensions
3565      (do* ((vector (underlying-simple-vector array))           :element-type (array-element-type pixarray)
3566            (start (index+ index           :displaced-to bbuf
3567                           (index* y padded-bytes-per-line)           :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
3568                           (index* x 3))     (sys:bitblt boole-1 width height a x y pixarray 0 0))
                  (index+ start padded-bytes-per-line))  
           (y 0 (index1+ y)))  
          ((index>= y height))  
       (declare (type (simple-array pixarray-24-element-type (*)) vector)  
                (type array-index start y))  
       (do* ((end (index+ start (index* width 3)))  
             (i start (index+ i 3))  
             (x (array-row-major-index array y 0) (index1+ x)))  
            ((index>= i end))  
         (declare (type array-index end i x))  
         (setf (aref vector x)  
               (read-image-assemble-bytes  
                 (aref buffer-bbuf (index+ i 0))  
                 (aref buffer-bbuf (index+ i 1))  
                 (aref buffer-bbuf (index+ i 2)))))))  
3569    t)    t)
3570    
3571  #+(or lcl3.0 excl cmu)  #+(or CMU sbcl)
3572  (defun fast-read-pixarray-32 (buffer-bbuf index array x y width height  (defun pixarray-element-size (pixarray)
3573                                padded-bytes-per-line)    (let ((eltype (array-element-type pixarray)))
3574    (declare (type buffer-bytes buffer-bbuf)      (cond ((eq eltype 'bit) 1)
3575             (type pixarray-32 array)            ((and (consp eltype) (eq (first eltype) 'unsigned-byte))
3576             (type card16 width height)             (second eltype))
3577             (type array-index index padded-bytes-per-line))            (t
3578    #.(declare-buffun)             (error "Invalid pixarray: ~S." pixarray)))))
3579    (with-vector (buffer-bbuf buffer-bytes)  
3580      (do* ((vector (underlying-simple-vector array))  #+CMU
3581            (start (index+ index  ;;; COPY-BIT-RECT  --  Internal
3582                           (index* y padded-bytes-per-line)  ;;;
3583                           (index* x 4))  ;;;    This is the classic BITBLT operation, copying a rectangular subarray
3584                   (index+ start padded-bytes-per-line))  ;;; from one array to another (but source and destination must not overlap.)
3585            (y 0 (index1+ y)))  ;;; Widths are specified in bits.  Neither array can have a non-zero
3586           ((index>= y height))  ;;; displacement.  We allow extra random bit-offset to be thrown into the X.
3587        (declare (type (simple-array pixarray-32-element-type (*)) vector)  ;;;
3588                 (type array-index start y))  (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
3589        (do* ((end (index+ start (index* width 4)))                               height width)
3590              (i start (index+ i 4))    (declare (type array-index source-width sx sy dest-width dx dy height width))
3591              (x (array-row-major-index array y 0) (index1+ x)))    #.(declare-buffun)
3592             ((index>= i end))    (lisp::with-array-data ((sdata source)
3593          (declare (type array-index end i x))                                   (sstart)
3594          (setf (aref vector x)                                   (send))
3595                (read-image-assemble-bytes      (declare (ignore send))
3596                  (aref buffer-bbuf (index+ i 0))      (lisp::with-array-data ((ddata dest)
3597                  (aref buffer-bbuf (index+ i 1))                                     (dstart)
3598                  (aref buffer-bbuf (index+ i 2))                                     (dend))
3599                  (aref buffer-bbuf (index+ i 3)))))))        (declare (ignore dend))
3600          (assert (and (zerop sstart) (zerop dstart)))
3601          (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)
3602                                sx (index* sy source-width))
3603                        (index+ src-idx source-width))
3604               (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)
3605                                 dx (index* dy dest-width))
3606                         (index+ dest-idx dest-width))
3607               (count height (1- count)))
3608              ((zerop count))
3609            (declare (type array-index src-idx dest-idx count))
3610            (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    #+(or CMU sbcl)
3635    (defun fast-read-pixarray-using-bitblt
3636           (bbuf boffset pixarray x y width height padded-bytes-per-line
3637            bits-per-pixel)
3638      (declare (type (array * 2) pixarray))
3639      #.(declare-buffun)
3640      (copy-bit-rect bbuf
3641                     (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
3642                     (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0
3643                     pixarray
3644                     (index* (array-dimension pixarray 1) bits-per-pixel)
3645                     x y
3646                     height
3647                     (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
3698                               unit byte-lsb-first-p bit-lsb-first-p)
3699    (declare (type buffer-bytes bbuf)    (declare (type buffer-bytes bbuf)
3700             (type array-index boffset             (type array-index boffset
3701                   padded-bytes-per-line)                   padded-bytes-per-line)
3702             (type pixarray pixarray)             (type pixarray pixarray)
3703             (type card16 x y width height)             (type card16 x y width height)
3704             (type (member 1 4 8 16 24 32) bits-per-pixel))             (type (member 1 4 8 16 24 32) bits-per-pixel)
3705               (type (member 8 16 32) unit)
3706               (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
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)           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3709    (or    (or
3710      #+lispm      #+(or Genera lcl3.0 excl)
3711      (let* ((padded-bits-per-line (* padded-bytes-per-line 8))      (fast-read-pixarray-with-swap
3712             (padded-pixels-per-line        bbuf boffset pixarray x y width height padded-bytes-per-line
3713               (floor padded-bits-per-line bits-per-pixel))        bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3714             (pixarray-padded-pixels-per-line      (let ((function
3715               #+Genera (sys:array-row-span pixarray)              (or #+lispm
3716               #-Genera (array-dimension pixarray 1))                  (and (= (sys:array-element-size pixarray) bits-per-pixel)
3717             (pixarray-padded-bits-per-line                       (zerop (index-mod padded-bytes-per-line 4))
3718               (* pixarray-padded-pixels-per-line bits-per-pixel)))                       (zerop (index-mod
3719        (when (and (= (sys:array-element-size pixarray) bits-per-pixel)                                (* #+Genera (sys:array-row-span pixarray)
3720                   (zerop (index-mod padded-bits-per-line 32))                                   #-Genera (array-dimension pixarray 1)
3721                   (zerop (index-mod pixarray-padded-bits-per-line 32)))                                   bits-per-pixel)
3722          (#+Genera sys:stack-let* #-Genera let*                                32))
3723           ((dimensions (list height padded-pixels-per-line))                       #'fast-read-pixarray-using-bitblt)
3724            (a (make-array                  #+(or CMU)
3725                 dimensions                  (and (index= (pixarray-element-size pixarray) bits-per-pixel)
3726                 :element-type (array-element-type pixarray)                       #'fast-read-pixarray-using-bitblt)
3727                 :displaced-to bbuf                  #+(or lcl3.0 excl)
3728                 :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))                  (and (index= bits-per-pixel 1)
3729           (sys:bitblt boole-1 width height a x y pixarray 0 0))                       #'fast-read-pixarray-1)
3730          t))                  #+(or lcl3.0 excl)
3731      #+Genera                  (and (index= bits-per-pixel 4)
3732      (when (= bits-per-pixel 24)                       #'fast-read-pixarray-4)
3733        (fast-read-pixarray-24                  #+(or Genera lcl3.0 excl CMU)
3734          bbuf boffset pixarray x y width height padded-bytes-per-line))                  (and (index= bits-per-pixel 24)
3735      #+(or lcl3.0 excl cmu)                       #'fast-read-pixarray-24))))
3736      (funcall        (when function
3737        (ecase bits-per-pixel          (read-pixarray-internal
3738          (1 #'fast-read-pixarray-1) (4 #'fast-read-pixarray-4)            bbuf boffset pixarray x y width height padded-bytes-per-line
3739          (8 #'fast-read-pixarray-8) (16 #'fast-read-pixarray-16)            bits-per-pixel function
3740          (24 #'fast-read-pixarray-24) (32 #'fast-read-pixarray-32))            unit byte-lsb-first-p bit-lsb-first-p
3741        bbuf boffset pixarray x y width height padded-bytes-per-line)            +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 lcl3.0 excl cmu)  #+(or lcl3.0 excl)
3746  (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height  (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height
3747                                padded-bytes-per-line)                                padded-bytes-per-line bits-per-pixel)
3748    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
3749             (type pixarray-1 array)             (type pixarray-1 array)
3750             (type card16 x y width height)             (type card16 x y width height)
3751             (type array-index index padded-bytes-per-line))             (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)    #.(declare-buffun)
3755    (with-vector (buffer-bbuf buffer-bytes)    (with-vector (buffer-bbuf buffer-bytes)
3756      (do* ((vector (underlying-simple-vector array))      (with-underlying-simple-vector (vector pixarray-1-element-type array)
3757            (h 0 (index1+ h))        (do* ((h 0 (index1+ h))
3758            (y y (index1+ y))              (y y (index1+ y))
3759            (right-bits (index-mod width 8))              (right-bits (index-mod width 8))
3760            (middle-bits (index- width right-bits))              (middle-bits (index- width right-bits))
3761            (middle-bytes (index-ceiling middle-bits 8))              (middle-bytes (index-ceiling middle-bits 8))
3762            (start index (index+ start padded-bytes-per-line)))              (start index (index+ start padded-bytes-per-line)))
3763           ((index>= h height))             ((index>= h height))
3764        (declare (type (simple-array pixarray-1-element-type (*)) vector)          (declare (type array-index h y right-bits middle-bits
3765                 (type array-index h y right-bits middle-bits                         middle-bytes start))
3766                       middle-bytes start))          (do* ((end (index+ start middle-bytes))
3767        (do* ((end (index+ start middle-bytes))                (i start (index1+ i))
3768              (i start (index1+ i))                (start-x x)
3769              (start-x x)                (x (array-row-major-index array y start-x) (index+ x 8)))
3770              (x (array-row-major-index array y start-x) (index+ x 8)))               ((index>= i end)
3771             ((index>= i end)                (unless (index-zerop right-bits)
3772              (unless (index-zerop right-bits)                  (let ((x (array-row-major-index
3773                (let ((x (array-row-major-index                             array y (index+ start-x middle-bits))))
3774                           array y (index+ start-x middle-bits))))                    (declare (type array-index x))
3775                  (declare (type array-index x))                    (setf (aref buffer-bbuf end)
3776                  (setf (aref buffer-bbuf end)                          (write-image-assemble-bytes
3777                        (write-image-assemble-bytes                            (aref vector (index+ x 0))
3778                          (aref vector (index+ x 0))                            (if (index> right-bits 1)
3779                          (if (index> right-bits 1)                                (aref vector (index+ x 1))
3780                              (aref vector (index+ x 1))                              0)
3781                            0)                            (if (index> right-bits 2)
3782                          (if (index> right-bits 2)                                (aref vector (index+ x 2))
3783                              (aref vector (index+ x 2))                              0)
3784                            0)                            (if (index> right-bits 3)
3785                          (if (index> right-bits 3)                                (aref vector (index+ x 3))
3786                              (aref vector (index+ x 3))                              0)
3787                            0)                            (if (index> right-bits 4)
3788                          (if (index> right-bits 4)                                (aref vector (index+ x 4))
3789                              (aref vector (index+ x 4))                              0)
3790                            0)                            (if (index> right-bits 5)
3791                          (if (index> right-bits 5)                                (aref vector (index+ x 5))
3792                              (aref vector (index+ x 5))                              0)
3793                            0)                            (if (index> right-bits 6)
3794                          (if (index> right-bits 6)                                (aref vector (index+ x 6))
3795                              (aref vector (index+ x 6))                              0)
3796                            0)                            0)))))
3797                          0)))))            (declare (type array-index end i start-x x))
3798          (declare (type array-index end i start-x x))            (setf (aref buffer-bbuf i)
3799          (setf (aref buffer-bbuf i)                  (write-image-assemble-bytes
3800                (write-image-assemble-bytes                    (aref vector (index+ x 0))
3801                  (aref vector (index+ x 0))                    (aref vector (index+ x 1))
3802                  (aref vector (index+ x 1))                    (aref vector (index+ x 2))
3803                  (aref vector (index+ x 2))                    (aref vector (index+ x 3))
3804                  (aref vector (index+ x 3))                    (aref vector (index+ x 4))
3805                  (aref vector (index+ x 4))                    (aref vector (index+ x 5))
3806                  (aref vector (index+ x 5))                    (aref vector (index+ x 6))
3807                  (aref vector (index+ x 6))                    (aref vector (index+ x 7))))))))
                 (aref vector (index+ x 7)))))))  
3808    t)    t)
3809    
3810  #+(or lcl3.0 excl cmu)  #+(or lcl3.0 excl)
3811  (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height  (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height
3812                                padded-bytes-per-line)                                padded-bytes-per-line bits-per-pixel)
3813    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
3814             (type pixarray-4 array)             (type pixarray-4 array)
3815             (type int16 x y)             (type int16 x y)
3816             (type card16 width height)             (type card16 width height)
3817             (type array-index index padded-bytes-per-line))             (type array-index index padded-bytes-per-line)
3818    #.(declare-buffun)             (type (member 1 4 8 16 24 32) bits-per-pixel)
3819    (with-vector (buffer-bbuf buffer-bytes)             (ignore bits-per-pixel))
     (do* ((vector (underlying-simple-vector array))  
           (h 0 (index1+ h))  
           (y y (index1+ y))  
           (right-nibbles (index-mod width 2))  
           (middle-nibbles (index- width right-nibbles))  
           (middle-bytes (index-ceiling middle-nibbles 2))  
           (start index (index+ start padded-bytes-per-line)))  
          ((index>= h height))  
       (declare (type (simple-array pixarray-4-element-type (*)) vector)  
                (type array-index h y right-nibbles middle-nibbles  
                      middle-bytes start))  
       (do* ((end (index+ start middle-bytes))  
             (i start (index1+ i))  
             (start-x x)  
             (x (array-row-major-index array y start-x) (index+ x 2)))  
            ((index>= i end)  
             (unless (index-zerop right-nibbles)  
               (setf (aref buffer-bbuf end)  
                     (write-image-assemble-bytes  
                       (aref array y (index+ start-x middle-nibbles))  
                       0))))  
         (declare (type array-index end i start-x x))  
         (setf (aref buffer-bbuf i)  
               (write-image-assemble-bytes  
                 (aref vector (index+ x 0))  
                 (aref vector (index+ x 1)))))))  
   t)  
   
 #+(or lcl3.0 excl cmu)  
 (defun fast-write-pixarray-8 (buffer-bbuf index array x y width height  
                               padded-bytes-per-line)  
   (declare (type buffer-bytes buffer-bbuf)  
            (type pixarray-8 array)  
            (type int16 x y)  
            (type card16 width height)  
            (type array-index index padded-bytes-per-line))  
3820    #.(declare-buffun)    #.(declare-buffun)
3821    (with-vector (buffer-bbuf buffer-bytes)    (with-vector (buffer-bbuf buffer-bytes)
3822      (do* ((vector (underlying-simple-vector array))      (with-underlying-simple-vector (vector pixarray-4-element-type array)
3823            (h 0 (index1+ h))        (do* ((h 0 (index1+ h))
3824            (y y (index1+ y))              (y y (index1+ y))
3825            (start index (index+ start padded-bytes-per-line)))              (right-nibbles (index-mod width 2))
3826           ((index>= h height))              (middle-nibbles (index- width right-nibbles))
3827        (declare (type (simple-array pixarray-8-element-type (*)) vector)              (middle-bytes (index-ceiling middle-nibbles 2))
3828                 (type array-index h y start))              (start index (index+ start padded-bytes-per-line)))
3829        (do* ((end (index+ start width))             ((index>= h height))
3830              (i start (index1+ i))          (declare (type array-index h y right-nibbles middle-nibbles
3831              (x (array-row-major-index array y x) (index1+ x)))                         middle-bytes start))
3832             ((index>= i end))          (do* ((end (index+ start middle-bytes))
3833          (declare (type array-index end i x))                (i start (index1+ i))
3834          (setf (aref buffer-bbuf i) (the card8 (aref vector x))))))                (start-x x)
3835    t)                (x (array-row-major-index array y start-x) (index+ x 2)))
3836                 ((index>= i end)
3837  #+(or lcl3.0 excl cmu)                (unless (index-zerop right-nibbles)
3838  (defun fast-write-pixarray-16 (buffer-bbuf index array x y width height                  (setf (aref buffer-bbuf end)
3839                                 padded-bytes-per-line)                        (write-image-assemble-bytes
3840    (declare (type buffer-bytes buffer-bbuf)                          (aref array y (index+ start-x middle-nibbles))
3841             (type pixarray-16 array)                          0))))
3842             (type int16 x y)            (declare (type array-index end i start-x x))
3843             (type card16 width height)            (setf (aref buffer-bbuf i)
3844             (type array-index index padded-bytes-per-line))                  (write-image-assemble-bytes
3845    #.(declare-buffun)                    (aref vector (index+ x 0))
3846    (with-vector (buffer-bbuf buffer-bytes)                    (aref vector (index+ x 1))))))))
     (do* ((vector (underlying-simple-vector array))  
           (h 0 (index1+ h))  
           (y y (index1+ y))  
           (start index (index+ start padded-bytes-per-line)))  
          ((index>= h height))  
       (declare (type (simple-array pixarray-16-element-type (*)) vector)  
                (type array-index h y start))  
       (do* ((end (index+ start (index* width 2)))  
             (i start (index+ i 2))  
             (x (array-row-major-index array y x) (index1+ x)))  
            ((index>= i end))  
         (declare (type array-index end i x))  
         (let ((pixel (aref vector x)))  
           (declare (type pixarray-16-element-type pixel))  
           (setf (aref buffer-bbuf (index+ i 0))  
                 (write-image-load-byte 0 pixel 16))  
           (setf (aref buffer-bbuf (index+ i 1))  
                 (write-image-load-byte 8 pixel 16))))))  
3847    t)    t)
3848    
3849  #+Genera  #+(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)                                 padded-bytes-per-line bits-per-pixel)
3852    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
3853             (type pixarray-24 array)             (type pixarray-24 array)
3854             (type int16 x y)             (type int16 x y)
3855             (type card16 width height)             (type card16 width height)
3856             (type array-index index padded-bytes-per-line))             (type array-index index padded-bytes-per-line)
3857               (type (member 1 4 8 16 24 32) bits-per-pixel)
3858               (ignore bits-per-pixel))
3859    #.(declare-buffun)    #.(declare-buffun)
3860    (with-vector (buffer-bbuf buffer-bytes)    (with-vector (buffer-bbuf buffer-bytes)
3861      (do* ((array array)      (with-underlying-simple-vector (vector pixarray-24-element-type array)
3862            (h 0 (index1+ h))        (do* ((h 0 (index1+ h))
3863            (y y (index1+ y))              (y y (index1+ y))
3864            (start index (index+ start padded-bytes-per-line)))              (start index (index+ start padded-bytes-per-line)))
3865           ((index>= h height))             ((index>= h height))
3866        (declare (sys:array-register-1d array)          (declare (type array-index y start))
3867                 (type array-index y start))          (do* ((end (index+ start (index* width 3)))
3868        (do* ((end (index+ start (index* width 3)))                (i start (index+ i 3))
3869              (i start (index+ i 3))                (x (array-row-major-index array y x) (index1+ x)))
3870              (x (array-row-major-index array y x) (index1+ x)))               ((index>= i end))
3871             ((index>= i end))            (declare (type array-index end i x))
3872          (declare (type array-index end i x))            (let ((pixel (aref vector x)))
3873          (let ((pixel (sys:%1d-aref array x)))              (declare (type pixarray-24-element-type pixel))
3874            (declare (type pixarray-24-element-type pixel))              (setf (aref buffer-bbuf (index+ i 0))
3875            (setf (aref buffer-bbuf (index+ i 0))                    (write-image-load-byte 0 pixel 24))
3876                  (write-image-load-byte 0 pixel 24))              (setf (aref buffer-bbuf (index+ i 1))
3877            (setf (aref buffer-bbuf (index+ i 1))                    (write-image-load-byte 8 pixel 24))
3878                  (write-image-load-byte 8 pixel 24))              (setf (aref buffer-bbuf (index+ i 2))
3879            (setf (aref buffer-bbuf (index+ i 2))                    (write-image-load-byte 16 pixel 24)))))))
                 (write-image-load-byte 16 pixel 24))))))  
3880    t)    t)
3881    
3882  #+(or lcl3.0 excl cmu)  #+lispm
3883  (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height  (defun fast-write-pixarray-using-bitblt
3884                                 padded-bytes-per-line)         (bbuf boffset pixarray x y width height padded-bytes-per-line
3885    (declare (type buffer-bytes buffer-bbuf)          bits-per-pixel)
3886             (type pixarray-24 array)    (#+Genera sys:stack-let* #-Genera let*
3887             (type int16 x y)     ((dimensions (list (+ y height)
3888             (type card16 width height)                        (floor (* padded-bytes-per-line 8) bits-per-pixel)))
3889             (type array-index index padded-bytes-per-line))      (a (make-array
3890    #.(declare-buffun)           dimensions
3891    (with-vector (buffer-bbuf buffer-bytes)           :element-type (array-element-type pixarray)
3892      (do* ((vector (underlying-simple-vector array))           :displaced-to bbuf
3893            (h 0 (index1+ h))           :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
3894            (y y (index1+ y))     (sys:bitblt boole-1 width height pixarray x y a 0 0))
           (start index (index+ start padded-bytes-per-line)))  
          ((index>= h height))  
       (declare (type (simple-array pixarray-24-element-type (*)) vector)  
                (type array-index y start))  
       (do* ((end (index+ start (index* width 3)))  
             (i start (index+ i 3))  
             (x (array-row-major-index array y x) (index1+ x)))  
            ((index>= i end))  
         (declare (type array-index end i x))  
         (let ((pixel (aref vector x)))  
           (declare (type pixarray-24-element-type pixel))  
           (setf (aref buffer-bbuf (index+ i 0))  
                 (write-image-load-byte 0 pixel 24))  
           (setf (aref buffer-bbuf (index+ i 1))  
                 (write-image-load-byte 8 pixel 24))  
           (setf (aref buffer-bbuf (index+ i 2))  
                 (write-image-load-byte 16 pixel 24))))))  
3895    t)    t)
3896    
3897  #+(or lcl3.0 excl cmu)  #+(or CMU sbcl)
3898  (defun fast-write-pixarray-32 (buffer-bbuf index array x y width height  (defun fast-write-pixarray-using-bitblt
3899                                 padded-bytes-per-line)         (bbuf boffset pixarray x y width height padded-bytes-per-line
3900    (declare (type buffer-bytes buffer-bbuf)          bits-per-pixel)
3901             (type pixarray-32 array)    #.(declare-buffun)
3902             (type int16 x y)    (copy-bit-rect pixarray
3903             (type card16 width height)                   (index* (array-dimension pixarray 1) bits-per-pixel)
3904             (type array-index index padded-bytes-per-line))                   x y
3905    #.(declare-buffun)                   bbuf
3906    (with-vector (buffer-bbuf buffer-bytes)                   (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
3907      (do* ((vector (underlying-simple-vector array))                   (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0
3908            (h 0 (index1+ h))                   height
3909            (y y (index1+ y))                   (index* width bits-per-pixel))
           (start index (index+ start padded-bytes-per-line)))  
          ((index>= h height))  
       (declare (type (simple-array pixarray-32-element-type (*)) vector)  
                (type array-index h y start))  
       (do* ((end (index+ start (index* width 4)))  
             (i start (index+ i 4))  
             (x (array-row-major-index array y x) (index1+ x)))  
            ((index>= i end))  
         (declare (type array-index end i x))  
         (let ((pixel (aref vector x)))  
           (declare (type pixarray-32-element-type pixel))  
           (setf (aref buffer-bbuf (index+ i 0))  
                 (write-image-load-byte 0 pixel 32))  
           (setf (aref buffer-bbuf (index+ i 1))  
                 (write-image-load-byte 8 pixel 32))  
           (setf (aref buffer-bbuf (index+ i 2))  
                 (write-image-load-byte 16 pixel 32))  
           (setf (aref buffer-bbuf (index+ i 2))  
                 (write-image-load-byte 24 pixel 32))))))  
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)
3959    (declare (type buffer-bytes bbuf)    (declare (type buffer-bytes bbuf)
3960             (type pixarray pixarray)             (type pixarray pixarray)
3961             (type card16 x y width height)             (type card16 x y width height)
3962             (type array-index boffset padded-bytes-per-line)             (type array-index boffset padded-bytes-per-line)
3963             (type (member 1 4 8 16 24 32) bits-per-pixel))             (type (member 1 4 8 16 24 32) bits-per-pixel)
3964               (type (member 8 16 32) unit)
3965               (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
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)           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3968    (or    (or
3969      #+lispm      #+(or Genera lcl3.0 excl)
3970      (let* ((padded-bits-per-line (* padded-bytes-per-line 8))      (fast-write-pixarray-with-swap
3971             (padded-pixels-per-line        bbuf boffset pixarray x y width height padded-bytes-per-line
3972               (floor padded-bits-per-line bits-per-pixel))        bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
3973             (pixarray-padded-pixels-per-line      (let ((function
3974               #+Genera (sys:array-row-span pixarray)              (or #+lispm
3975               #-Genera (array-dimension pixarray 1))                  (and (= (sys:array-element-size pixarray) bits-per-pixel)
3976             (pixarray-padded-bits-per-line                       (zerop (index-mod padded-bytes-per-line 4))
3977               (* pixarray-padded-pixels-per-line bits-per-pixel)))                       (zerop (index-mod
3978        (when (and (= (sys:array-element-size pixarray) bits-per-pixel)                                (* #+Genera (sys:array-row-span pixarray)
3979                   (zerop (index-mod padded-bits-per-line 32))                                   #-Genera (array-dimension pixarray 1)
3980                   (zerop (index-mod pixarray-padded-bits-per-line 32)))                                   bits-per-pixel)
3981          (#+Genera sys:stack-let* #-Genera let*                                32))
3982           ((dimensions (list height padded-pixels-per-line))                       #'fast-write-pixarray-using-bitblt)
3983            (a (make-array                  #+(or CMU)
3984                 dimensions                  (and (index= (pixarray-element-size pixarray) bits-per-pixel)
3985                 :element-type (array-element-type pixarray)                       #'fast-write-pixarray-using-bitblt)
3986                 :displaced-to bbuf                  #+(or lcl3.0 excl)
3987                 :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))                  (and (index= bits-per-pixel 1)
3988           (sys:bitblt boole-1 width height pixarray x y a 0 0))                       #'fast-write-pixarray-1)
3989          t))                  #+(or lcl3.0 excl)
3990      #+Genera                  (and (index= bits-per-pixel 4)
3991      (when (= bits-per-pixel 24)                       #'fast-write-pixarray-4)
3992        (fast-write-pixarray-24                  #+(or Genera lcl3.0 excl CMU)
3993          bbuf boffset pixarray x y width height padded-bytes-per-line))                  (and (index= bits-per-pixel 24)
3994      #+(or lcl3.0 excl cmu)