/[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.5.2.2 by pw, Tue Jun 23 11:21:21 1998 UTC revision 1.5.2.3 by pw, Tue May 23 16:35:54 2000 UTC
# Line 17  Line 17 
17  ;;; Texas Instruments Incorporated provides this software "as is" without  ;;; Texas Instruments Incorporated provides this software "as is" without
18  ;;; express or implied warranty.  ;;; express or implied warranty.
19  ;;;  ;;;
20    #+cmu
21    (ext:file-comment
22      "$Header$")
23    
24  (in-package :xlib)  (in-package :xlib)
25    
# Line 29  Line 32 
32  ;;; The size of the output buffer.  Must be a multiple of 4.  ;;; The size of the output buffer.  Must be a multiple of 4.
33  (defparameter *output-buffer-size* 8192)  (defparameter *output-buffer-size* 8192)
34    
 #+explorer  
 (zwei:define-indentation event-case (1 1))  
   
35  ;;; Number of seconds to wait for a reply to a server request  ;;; Number of seconds to wait for a reply to a server request
36  (defparameter *reply-timeout* nil)  (defparameter *reply-timeout* nil)
37    
38  #-(or clx-overlapping-arrays (not clx-little-endian))  #-(or (not clx-little-endian))
39  (progn  (progn
40    (defconstant *word-0* 0)    (defconstant *word-0* 0)
41    (defconstant *word-1* 1)    (defconstant *word-1* 1)
# Line 45  Line 45 
45    (defconstant *long-2* 2)    (defconstant *long-2* 2)
46    (defconstant *long-3* 3))    (defconstant *long-3* 3))
47    
48  #-(or clx-overlapping-arrays clx-little-endian)  #-(or clx-little-endian)
49  (progn  (progn
50    (defconstant *word-0* 1)    (defconstant *word-0* 1)
51    (defconstant *word-1* 0)    (defconstant *word-1* 0)
# Line 84  Line 84 
84                   card16->int16 int16->card16                   card16->int16 int16->card16
85                   card32->int32 int32->card32))                   card32->int32 int32->card32))
86    
87  #-Genera  
88  (progn  (progn
89    
90  (defun card8->int8 (x)  (defun card8->int8 (x)
# Line 131  Line 131 
131    
132  )  )
133    
 #+Genera  
 (progn  
   
 (defun card8->int8 (x)  
   (declare lt:(side-effects simple reducible))  
   (if (logbitp 7 x) (- x #x100) x))  
   
 (defun int8->card8 (x)  
   (declare lt:(side-effects simple reducible))  
   (ldb (byte 8 0) x))  
   
 (defun card16->int16 (x)  
   (declare lt:(side-effects simple reducible))  
   (if (logbitp 15 x) (- x #x10000) x))  
   
 (defun int16->card16 (x)  
   (declare lt:(side-effects simple reducible))  
   (ldb (byte 16 0) x))  
   
 (defun card32->int32 (x)  
   (declare lt:(side-effects simple reducible))  
   (sys:%logldb (byte 32 0) x))  
   
 (defun int32->card32 (x)  
   (declare lt:(side-effects simple reducible))  
   (ldb (byte 32 0) x))  
   
 )  
   
134  (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))  (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
135    
136  #-(or Genera lcl3.0 excl)  
137  (progn  (progn
138    
139  (defun aref-card8 (a i)  (defun aref-card8 (a i)
# Line 195  Line 166 
166    
167  )  )
168    
 #+Genera  
 (progn  
   
 (defun aref-card8 (a i)  
   (aref a i))  
   
 (defun aset-card8 (v a i)  
   (zl:aset v a i))  
   
 (defun aref-int8 (a i)  
   (card8->int8 (aref a i)))  
   
 (defun aset-int8 (v a i)  
   (zl:aset (int8->card8 v) a i))  
   
 )  
   
 #+(or excl lcl3.0 clx-overlapping-arrays)  
 (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29  
                  aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))  
   
 #+(and clx-overlapping-arrays Genera)  
 (progn  
   
 (defun aref-card16 (a i)  
   (aref a i))  
   
 (defun aset-card16 (v a i)  
   (zl:aset v a i))  
   
 (defun aref-int16 (a i)  
   (card16->int16 (aref a i)))  
   
 (defun aset-int16 (v a i)  
   (zl:aset (int16->card16 v) a i)  
   v)  
   
 (defun aref-card32 (a i)  
   (int32->card32 (aref a i)))  
   
 (defun aset-card32 (v a i)  
   (zl:aset (card32->int32 v) a i))  
   
 (defun aref-int32 (a i) (aref a i))  
   
 (defun aset-int32 (v a i)  
   (zl:aset v a i))  
   
 (defun aref-card29 (a i)  
   (aref a i))  
   
 (defun aset-card29 (v a i)  
   (zl:aset v a i))  
   
 )  
   
 #+(and clx-overlapping-arrays (not Genera))  
 (progn  
   
 (defun aref-card16 (a i)  
   (aref a i))  
   
 (defun aset-card16 (v a i)  
   (setf (aref a i) v))  
   
 (defun aref-int16 (a i)  
   (card16->int16 (aref a i)))  
   
 (defun aset-int16 (v a i)  
   (setf (aref a i) (int16->card16 v))  
   v)  
   
 (defun aref-card32 (a i)  
   (aref a i))  
   
 (defun aset-card32 (v a i)  
   (setf (aref a i) v))  
   
 (defun aref-int32 (a i)  
   (card32->int32 (aref a i)))  
   
 (defun aset-int32 (v a i)  
   (setf (aref a i) (int32->card32 v))  
   v)  
   
 (defun aref-card29 (a i)  
   (aref a i))  
   
 (defun aset-card29 (v a i)  
   (setf (aref a i) v))  
   
 )  
   
 #+excl  
 (progn  
   
 (defun aref-card8 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (clx-values card8))  
   #.(declare-buffun)  
   (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                          :unsigned-byte)))  
   
 (defun aset-card8 (v a i)  
   (declare (type card8 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                     :unsigned-byte) v))  
   
 (defun aref-int8 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (clx-values int8))  
   #.(declare-buffun)  
   (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                         :signed-byte)))  
   
 (defun aset-int8 (v a i)  
   (declare (type int8 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                     :signed-byte) v))  
   
 (defun aref-card16 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (clx-values card16))  
   #.(declare-buffun)  
   (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                           :unsigned-word)))  
   
 (defun aset-card16 (v a i)  
   (declare (type card16 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                     :unsigned-word) v))  
   
 (defun aref-int16 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (clx-values int16))  
   #.(declare-buffun)  
   (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                          :signed-word)))  
   
 (defun aset-int16 (v a i)  
   (declare (type int16 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                     :signed-word) v))  
   
 (defun aref-card32 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (clx-values card32))  
   #.(declare-buffun)  
   (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                           :unsigned-long)))  
   
 (defun aset-card32 (v a i)  
   (declare (type card32 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))  
   
 (defun aref-int32 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (clx-values int32))  
   #.(declare-buffun)  
   (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                          :signed-long)))  
   
 (defun aset-int32 (v a i)  
   (declare (type int32 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i  
                     :signed-long) v))  
   
 (defun aref-card29 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i))  
   (declare (clx-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))  
   
 )  
   
 #+lcl3.0  
 (progn  
   
 (defun aref-card8 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i)  
            (clx-values card8))  
   #.(declare-buffun)  
   (the card8 (lucid::%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 (lucid::%svref-8bit a i) v))  
   
 (defun aref-int8 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i)  
            (clx-values int8))  
   #.(declare-buffun)  
   (the int8 (lucid::%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 (lucid::%svref-signed-8bit a i) v))  
   
 (defun aref-card16 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i)  
            (clx-values card16))  
   #.(declare-buffun)  
   (the card16 (lucid::%svref-16bit a (index-ash i -1))))  
   
 (defun aset-card16 (v a i)  
   (declare (type card16 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (lucid::%svref-16bit a (index-ash i -1)) v))  
   
 (defun aref-int16 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i)  
            (clx-values int16))  
   #.(declare-buffun)  
   (the int16 (lucid::%svref-signed-16bit a (index-ash i -1))))  
   
 (defun aset-int16 (v a i)  
   (declare (type int16 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v))  
   
 (defun aref-card32 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i)  
            (clx-values card32))  
   #.(declare-buffun)  
   (the card32 (lucid::%svref-32bit a (index-ash i -2))))  
   
 (defun aset-card32 (v a i)  
   (declare (type card32 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (lucid::%svref-32bit a (index-ash i -2)) v))  
   
 (defun aref-int32 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i)  
            (clx-values int32))  
   #.(declare-buffun)  
   (the int32 (lucid::%svref-signed-32bit a (index-ash i -2))))  
   
 (defun aset-int32 (v a i)  
   (declare (type int32 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v))  
   
 (defun aref-card29 (a i)  
   (declare (type buffer-bytes a)  
            (type array-index i)  
            (clx-values card29))  
   #.(declare-buffun)  
   (the card29 (lucid::%svref-32bit a (index-ash i -2))))  
   
 (defun aset-card29 (v a i)  
   (declare (type card29 v)  
            (type buffer-bytes a)  
            (type array-index i))  
   #.(declare-buffun)  
   (setf (lucid::%svref-32bit a (index-ash i -2)) v))  
   
 )  
   
169    
   
 #-(or excl lcl3.0 clx-overlapping-arrays)  
170  (progn  (progn
171    
172  (defun aref-card16 (a i)  (defun aref-card16 (a i)
# Line 687  Line 343 
343    (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))))
344    
345    
346  #+cmu (progn  #+cmu
347    (progn
348    
349  ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI  ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
350  ;;; is irrational, there can't be a precise rational representation.  In  ;;; is irrational, there can't be a precise rational representation.  In
# Line 718  Line 375 
375    
376  (macrolet ((char-translators ()  (macrolet ((char-translators ()
377               (let ((alist               (let ((alist
378                       `(#-lispm                       `(;; The normal ascii codes for the control characters.
                        ;; The normal ascii codes for the control characters.  
379                         ,@`((#\Return . 13)                         ,@`((#\Return . 13)
380                             (#\Linefeed . 10)                             (#\Linefeed . 10)
381                             (#\Rubout . 127)                             (#\Rubout . 127)
# Line 728  Line 384 
384                             (#\Backspace . 8)                             (#\Backspace . 8)
385                             (#\Newline . 10)                             (#\Newline . 10)
386                             (#\Space . 32))                             (#\Space . 32))
387                         ;; One the lispm, #\Newline is #\Return, but we'd really like  
                        ;; #\Newline to translate to ascii code 10, so we swap the  
                        ;; Ascii codes for #\Return and #\Linefeed. We also provide  
                        ;; mappings from the counterparts of these control characters  
                        ;; so that the character mapping from the lisp machine  
                        ;; character set to ascii is invertible.  
                        #+lispm  
                        ,@`((#\Return . 10)   (,(code-char  10) . ,(char-code #\Return))  
                            (#\Linefeed . 13) (,(code-char  13) . ,(char-code #\Linefeed))  
                            (#\Rubout . 127)  (,(code-char 127) . ,(char-code #\Rubout))  
                            (#\Page . 12)     (,(code-char  12) . ,(char-code #\Page))  
                            (#\Tab . 9)       (,(code-char   9) . ,(char-code #\Tab))  
                            (#\Backspace . 8) (,(code-char   8) . ,(char-code #\Backspace))  
                            (#\Newline . 10)  (,(code-char  10) . ,(char-code #\Newline))  
                            (#\Space . 32)    (,(code-char  32) . ,(char-code #\Space)))  
388                         ;; The rest of the common lisp charater set with the normal                         ;; The rest of the common lisp charater set with the normal
389                         ;; ascii codes for them.                         ;; ascii codes for them.
390                         (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)                         (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
# Line 795  Line 437 
437                                            (dolist (pair alist)                                            (dolist (pair alist)
438                                              (setf (aref array (cdr pair)) (car pair)))                                              (setf (aref array (cdr pair)) (car pair)))
439                                            array))                                            array))
                          #-Genera  
440                           (progn                           (progn
441                             (defun char->card8 (char)                             (defun char->card8 (char)
442                               (declare (type base-char char))                               (declare (type base-char char))
# Line 811  Line 452 
452                                              card8)                                              card8)
453                                        (error "Invalid CHAR code ~D." card8))))                                        (error "Invalid CHAR code ~D." card8))))
454                             )                             )
                          #+Genera  
                          (progn  
                            (defun char->card8 (char)  
                              (declare lt:(side-effects reader reducible))  
                              (aref *char-to-card8-translation-table* (char-code char)))  
                            (defun card8->char (card8)  
                              (declare lt:(side-effects reader reducible))  
                              (aref *card8-to-char-translation-table* card8))  
                            )  
                          #-Minima  
455                           (dotimes (i 256)                           (dotimes (i 256)
456                             (unless (= i (char->card8 (card8->char i)))                             (unless (= i (char->card8 (card8->char i)))
457                               (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 828  Line 459 
459                                           (card8->char i)                                           (card8->char i)
460                                           (char->card8 (card8->char i))))                                           (char->card8 (card8->char i))))
461                               (return nil)))                               (return nil)))
                          #-Minima  
462                           (dotimes (i (length *char-to-card8-translation-table*))                           (dotimes (i (length *char-to-card8-translation-table*))
463                             (let ((char (code-char i)))                             (let ((char (code-char i)))
464                               (unless (eql char (card8->char (char->card8 char)))                               (unless (eql char (card8->char (char->card8 char)))
# Line 861  Line 491 
491    
492  ;;; MAKE-PROCESS-LOCK: Creating a process lock.  ;;; MAKE-PROCESS-LOCK: Creating a process lock.
493    
494  #-(or LispM excl Minima (and cmu mp))  #-(or (and cmu mp))
495  (defun make-process-lock (name)  (defun make-process-lock (name)
496    (declare (ignore name))    (declare (ignore name))
497    nil)    nil)
498    
 #+excl  
 (defun make-process-lock (name)  
   (mp:make-process-lock :name name))  
   
 #+(and LispM (not Genera))  
 (defun make-process-lock (name)  
   (vector nil name))  
   
 #+Genera  
 (defun make-process-lock (name)  
   (process:make-lock name :flavor 'clx-lock))  
   
 #+Minima  
 (defun make-process-lock (name)  
   (minima:make-lock name :recursive t))  
499    
500  #+(and cmu mp)  #+(and cmu mp)
501  (defun make-process-lock (name)  (defun make-process-lock (name)
# Line 894  Line 509 
509    
510  ;; If you're not sharing DISPLAY objects within a multi-processing  ;; If you're not sharing DISPLAY objects within a multi-processing
511  ;; shared-memory environment, this is sufficient  ;; shared-memory environment, this is sufficient
512  #-(or lispm excl lcl3.0 Minima (and CMU mp))  #-(or (and CMU mp))
513  (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)  (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
514    (declare (ignore locator display whostate timeout))    (declare (ignore locator display whostate timeout))
515    `(progn ,@body))    `(progn ,@body))
# Line 928  Line 543 
543    `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))    `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
544      ,@body))      ,@body))
545    
 #+Genera  
 (defmacro holding-lock ((locator display &optional whostate &key timeout)  
                         &body body)  
   (declare (ignore whostate))  
   `(process:with-lock (,locator :timeout ,timeout)  
      (let ((.debug-io. (buffer-debug-io ,display)))  
        (scl:let-if .debug-io. ((*debug-io* .debug-io.))  
          ,@body))))  
   
 #+(and lispm (not Genera))  
 (defmacro holding-lock ((locator display &optional whostate &key timeout)  
                         &body body)  
   (declare (ignore display))  
   ;; This macro is for use in a multi-process environment.  
   (let ((lock (gensym))  
         (have-lock (gensym))  
         (timeo (gensym)))  
     `(let* ((,lock (zl:locf (svref ,locator 0)))  
             (,have-lock (eq (car ,lock) sys:current-process))  
             (,timeo ,timeout))  
        (unwind-protect  
            (when (cond (,have-lock)  
                        ((#+explorer si:%store-conditional  
                          #-explorer sys:store-conditional  
                          ,lock nil sys:current-process))  
                        ((null ,timeo)  
                         (sys:process-lock ,lock nil ,(or whostate "CLX Lock")))  
                        ((sys:process-wait-with-timeout  
                             ,(or whostate "CLX Lock") (round (* ,timeo 60.))  
                           #'(lambda (lock process)  
                               (#+explorer si:%store-conditional  
                                #-explorer sys:store-conditional  
                                lock nil process))  
                           ,lock sys:current-process)))  
              ,@body)  
          (unless ,have-lock  
            (#+explorer si:%store-conditional  
             #-explorer sys:store-conditional  
             ,lock sys:current-process nil))))))  
   
 ;; Lucid has a process locking mechanism as well under release 3.0  
 #+lcl3.0  
 (defmacro holding-lock ((locator display &optional whostate &key timeout)  
                         &body body)  
   (declare (ignore display))  
   (if timeout  
       ;; Hair to support timeout.  
       `(let ((.have-lock. (eq ,locator lcl:*current-process*))  
              (.timeout. ,timeout))  
          (unwind-protect  
              (when (cond (.have-lock.)  
                          ((conditional-store ,locator nil lcl:*current-process*))  
                          ((null .timeout.)  
                           (lcl:process-lock ,locator)  
                           t)  
                          ((lcl:process-wait-with-timeout ,whostate .timeout.  
                             #'(lambda ()  
                                 (conditional-store ,locator nil lcl:*current-process*))))  
                          ;; abort the PROCESS-UNLOCK if actually timing out  
                          (t  
                           (setf .have-lock. :abort)  
                           nil))  
                ,@body)  
            (unless .have-lock.  
              (lcl:process-unlock ,locator))))  
     `(lcl:with-process-lock (,locator)  
        ,@body)))  
   
   
 #+excl  
 (defmacro holding-lock ((locator display &optional whostate &key timeout)  
                         &body body)  
   (declare (ignore display))  
   `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)  
      (unwind-protect  
          (block .hl-doit.  
            (when mp::*scheduler-stack-group* ; fast test for scheduler running  
              (setq .hl-lock. ,locator  
                    .hl-curproc. mp::*current-process*)  
              (when (and .hl-curproc.    ; nil if in process-wait fun  
                         (not (eq (mp::process-lock-locker .hl-lock.)  
                                  .hl-curproc.)))  
                ;; Then we need to grab the lock.  
                ,(if timeout  
                     `(if (not (mp::process-lock .hl-lock. .hl-curproc.  
                                                 ,whostate ,timeout))  
                          (return-from .hl-doit. nil))  
                   `(mp::process-lock .hl-lock. .hl-curproc.  
                                      ,@(when whostate `(,whostate))))  
                ;; There is an apparent race condition here.  However, there is  
                ;; no actual race condition -- our implementation of mp:process-  
                ;; lock guarantees that the lock will still be held when it  
                ;; returns, and no interrupt can happen between that and the  
                ;; execution of the next form.  -- jdi 2/27/91  
                (setq .hl-obtained-lock. t)))  
            ,@body)  
        (if (and .hl-obtained-lock.  
                 ;; Note -- next form added to allow error handler inside  
                 ;; body to unlock the lock prematurely if it knows that  
                 ;; the current process cannot possibly continue but will  
                 ;; throw out (or is it throw up?).  
                 (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))  
            (mp::process-unlock .hl-lock. .hl-curproc.)))))  
   
 #+Minima  
 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)  
   `(holding-lock-1 #'(lambda () ,@body) ,locator ,display  
                    ,@(and whostate `(:whostate ,whostate))  
                    ,@(and timeout `(:timeout ,timeout))))  
   
 #+Minima  
 (defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout)  
   (declare (dynamic-extent continuation))  
   (declare (ignore display whostate timeout))  
   (minima:with-lock (lock)  
     (funcall continuation)))  
546    
547  ;;; WITHOUT-ABORTS  ;;; WITHOUT-ABORTS
548    
# Line 1056  Line 555 
555  (defmacro without-aborts (&body body)  (defmacro without-aborts (&body body)
556    `(progn ,@body))    `(progn ,@body))
557    
 #+Genera  
 (defmacro without-aborts (&body body)  
   `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.")  
      ,@body))  
   
 #+excl  
 (defmacro without-aborts (&body body)  
   `(without-interrupts ,@body))  
   
 #+lcl3.0  
 (defmacro without-aborts (&body body)  
   `(lcl:with-interruptions-inhibited ,@body))  
   
558  ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.  ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
559  ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's  ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
560  ;;; value changes.  ;;; value changes.
561    
562  #-(or lispm excl lcl3.0 Minima (and cmu mp))  #-(or (and cmu mp))
563  (defun process-block (whostate predicate &rest predicate-args)  (defun process-block (whostate predicate &rest predicate-args)
564    (declare (ignore whostate))    (declare (ignore whostate))
565    (or (apply predicate predicate-args)    (or (apply predicate predicate-args)
566        (error "Program tried to wait with no scheduler.")))        (error "Program tried to wait with no scheduler.")))
567    
 #+Genera  
 (defun process-block (whostate predicate &rest predicate-args)  
   (declare (type function predicate)  
            #+clx-ansi-common-lisp  
            (dynamic-extent predicate)  
            #-clx-ansi-common-lisp  
            (sys:downward-funarg predicate))  
   (apply #'process:block-process whostate predicate predicate-args))  
   
 #+(and lispm (not Genera))  
 (defun process-block (whostate predicate &rest predicate-args)  
   (declare (type function predicate)  
            #+clx-ansi-common-lisp  
            (dynamic-extent predicate)  
            #-clx-ansi-common-lisp  
            (sys:downward-funarg predicate))  
   (apply #'global:process-wait whostate predicate predicate-args))  
   
 #+excl  
 (defun process-block (whostate predicate &rest predicate-args)  
   (if mp::*scheduler-stack-group*  
       (apply #'mp::process-wait whostate predicate predicate-args)  
       (or (apply predicate predicate-args)  
           (error "Program tried to wait with no scheduler."))))  
   
 #+lcl3.0  
 (defun process-block (whostate predicate &rest predicate-args)  
   (declare (dynamic-extent predicate-args))  
   (apply #'lcl:process-wait whostate predicate predicate-args))  
   
 #+Minima  
 (defun process-block (whostate predicate &rest predicate-args)  
   (declare (type function predicate)  
            (dynamic-extent predicate))  
   (apply #'minima:process-wait whostate predicate predicate-args))  
   
568  #+(and cmu mp)  #+(and cmu mp)
569  (defun process-block (whostate predicate &rest predicate-args)  (defun process-block (whostate predicate &rest predicate-args)
570    (declare (type function predicate))    (declare (type function predicate))
# Line 1125  Line 575 
575    
576  (declaim (inline process-wakeup))  (declaim (inline process-wakeup))
577    
578  #-(or excl Genera Minima (and cmu mp))  #-(or (and cmu mp))
579  (defun process-wakeup (process)  (defun process-wakeup (process)
580    (declare (ignore process))    (declare (ignore process))
581    nil)    nil)
582    
 #+excl  
 (defun process-wakeup (process)  
   (let ((curproc mp::*current-process*))  
     (when (and curproc process)  
       (unless (mp::process-p curproc)  
         (error "~s is not a process" curproc))  
       (unless (mp::process-p process)  
         (error "~s is not a process" process))  
       (if (> (mp::process-priority process) (mp::process-priority curproc))  
           (mp::process-allow-schedule process)))))  
   
 #+Genera  
 (defun process-wakeup (process)  
   (process:wakeup process))  
   
 #+Minima  
 (defun process-wakeup (process)  
   (when process  
     (minima:process-wakeup process)))  
   
583  #+(and cmu mp)  #+(and cmu mp)
584  (defun process-wakeup (process)  (defun process-wakeup (process)
585    (declare (ignore process))    (declare (ignore process))
# Line 1162  Line 592 
592    
593  ;;; Default return NIL, which is acceptable even if there is a scheduler.  ;;; Default return NIL, which is acceptable even if there is a scheduler.
594    
595  #-(or lispm excl lcl3.0 Minima (and cmu mp))  #-(or (and cmu mp))
596  (defun current-process ()  (defun current-process ()
597    nil)    nil)
598    
 #+lispm  
 (defun current-process ()  
   sys:current-process)  
   
 #+excl  
 (defun current-process ()  
   (and mp::*scheduler-stack-group*  
        mp::*current-process*))  
   
 #+lcl3.0  
 (defun current-process ()  
   lcl:*current-process*)  
   
 #+Minima  
 (defun current-process ()  
   (minima:current-process))  
   
599  #+(and cmu mp)  #+(and cmu mp)
600  (defun current-process ()  (defun current-process ()
601    mp:*current-process*)    mp:*current-process*)
602    
603  ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.  ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
604    
605  #-(or lispm excl lcl3.0 Minima cmu)  #-(or cmu)
606  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
607    `(progn ,@body))    `(progn ,@body))
608    
 #+(and lispm (not Genera))  
 (defmacro without-interrupts (&body body)  
   `(sys:without-interrupts ,@body))  
   
 #+Genera  
 (defmacro without-interrupts (&body body)  
   `(process:with-no-other-processes ,@body))  
   
 #+LCL3.0  
 (defmacro without-interrupts (&body body)  
   `(lcl:with-scheduling-inhibited ,@body))  
   
 #+Minima  
 (defmacro without-interrupts (&body body)  
   `(minima:with-no-other-processes ,@body))  
   
609  #+cmu  #+cmu
610  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
611    `(sys:without-interrupts ,@body))    `(sys:without-interrupts ,@body))
# Line 1230  Line 627 
627  ;;;  ;;;
628  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
629    
 #-Genera  
630  (defmacro wrap-buf-output ((buffer) &body body)  (defmacro wrap-buf-output ((buffer) &body body)
631    ;; Error recovery wrapper    ;; Error recovery wrapper
632    `(unless (buffer-dead ,buffer)    `(unless (buffer-dead ,buffer)
633       ,@body))       ,@body))
634    
 #+Genera  
 (defmacro wrap-buf-output ((buffer) &body body)  
   ;; Error recovery wrapper  
   `(let ((.buffer. ,buffer))  
      (unless (buffer-dead .buffer.)  
        (scl:condition-bind  
          (((sys:network-error)  
            #'(lambda (error)  
                (scl:condition-case ()  
                     (funcall (buffer-close-function .buffer.) .buffer. :abort t)  
                   (sys:network-error))  
                (setf (buffer-dead .buffer.) error)  
                (setf (buffer-output-stream .buffer.) nil)  
                (setf (buffer-input-stream .buffer.) nil)  
                nil)))  
          ,@body))))  
   
 #-Genera  
635  (defmacro wrap-buf-input ((buffer) &body body)  (defmacro wrap-buf-input ((buffer) &body body)
636    (declare (ignore buffer))    (declare (ignore buffer))
637    ;; Error recovery wrapper    ;; Error recovery wrapper
638    `(progn ,@body))    `(progn ,@body))
639    
 #+Genera  
 (defmacro wrap-buf-input ((buffer) &body body)  
   ;; Error recovery wrapper  
   `(let ((.buffer. ,buffer))  
      (scl:condition-bind  
        (((sys:network-error)  
          #'(lambda (error)  
              (scl:condition-case ()  
                   (funcall (buffer-close-function .buffer.) .buffer. :abort t)  
                 (sys:network-error))  
              (setf (buffer-dead .buffer.) error)  
              (setf (buffer-output-stream .buffer.) nil)  
              (setf (buffer-input-stream .buffer.) nil)  
              nil)))  
        ,@body)))  
   
640    
641  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
642  ;;; System dependent IO primitives  ;;; System dependent IO primitives
# Line 1285  Line 647 
647  ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X  ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
648  ;;; server  ;;; server
649    
650  #-(or explorer Genera lucid kcl ibcl excl Minima CMU)  #-(or CMU)
651  (defun open-x-stream (host display protocol)  (defun open-x-stream (host display protocol)
652    host display protocol ;; unused    host display protocol ;; unused
653    (error "OPEN-X-STREAM not implemented yet."))    (error "OPEN-X-STREAM not implemented yet."))
654    
 ;;; Genera:  
   
 ;;; TCP and DNA are both layered products, so try to work with either one.  
   
 #+Genera  
 (when (fboundp 'tcp:add-tcp-port-for-protocol)  
   (tcp:add-tcp-port-for-protocol :x-window-system 6000))  
   
 #+Genera  
 (when (fboundp 'dna:add-dna-contact-id-for-protocol)  
   (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0"))  
   
 #+Genera  
 (net:define-protocol :x-window-system (:x-window-system :byte-stream)  
   (:invoke-with-stream ((stream :characters nil :ascii-translation nil))  
     stream))  
   
 #+Genera  
 (eval-when (compile)  
   (compiler:function-defined 'tcp:open-tcp-stream)  
   (compiler:function-defined 'dna:open-dna-bidirectional-stream))  
   
 #+Genera  
 (defun open-x-stream (host display protocol)  
   (let ((host (net:parse-host host)))  
     (if (or protocol (plusp display))  
         ;; The protocol was specified or the display isn't 0, so we  
         ;; can't use the Generic Network System.  If the protocol was  
         ;; specified, then use that protocol, otherwise, blindly use  
         ;; TCP.  
         (ccase protocol  
           ((:tcp nil)  
            (tcp:open-tcp-stream  
              host (+ *x-tcp-port* display) nil  
              :direction :io  
              :characters nil  
              :ascii-translation nil))  
           ((:dna)  
            (dna:open-dna-bidirectional-stream  
              host (format nil "X$X~D" display)  
              :characters nil  
              :ascii-translation nil)))  
       (let ((neti:*invoke-service-automatic-retry* t))  
         (net:invoke-service-on-host :x-window-system host)))))  
   
 #+explorer  
 (defun open-x-stream (host display protocol)  
   (declare (ignore protocol))  
   (net:open-connection-on-medium  
     (net:parse-host host)                       ;Host  
     :byte-stream                                ;Medium  
     "X11"                                       ;Logical contact name  
     :stream-type :character-stream  
     :direction :bidirectional  
     :timeout-after-open nil  
     :remote-port (+ *x-tcp-port* display)))  
   
 #+explorer  
 (net:define-logical-contact-name  
   "X11"  
   `((:local "X11")  
     (:chaos "X11")  
     (:nsp-stream "X11")  
     (:tcp ,*x-tcp-port*)))  
   
 #+lucid  
 (defun open-x-stream (host display protocol)  
   protocol ;; unused  
   (let ((fd (connect-to-server host display)))  
     (when (minusp fd)  
       (error "Failed to connect to server: ~A ~D" host display))  
     (user::make-lisp-stream :input-handle fd  
                             :output-handle fd  
                             :element-type 'unsigned-byte  
                             #-lcl3.0 :stream-type #-lcl3.0 :ephemeral)))  
   
 #+(or kcl ibcl)  
 (defun open-x-stream (host display protocol)  
   protocol ;; unused  
   (let ((stream (open-socket-stream host display)))  
     (if (streamp stream)  
         stream  
       (error "Cannot connect to server: ~A:~D" host display))))  
   
 #+excl  
 ;;  
 ;; Note that since we don't use the CL i/o facilities to do i/o, the display  
 ;; input and output "stream" is really a file descriptor (fixnum).  
 ;;  
 (defun open-x-stream (host display protocol)  
   (declare (ignore protocol));; unused  
   (let ((fd (connect-to-server (string host) display)))  
     (when (minusp fd)  
       (error "Failed to connect to server: ~A ~D" host display))  
     fd))  
   
 #+Minima  
 (defun open-x-stream (host display protocol)  
   (declare (ignore protocol));; unused  
   (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address  
                                                   (cdr (host-address host)))  
                           :foreign-port (+ *x-tcp-port* display)))  
   
655  ;;; OPEN-X-STREAM -- for CMU Common Lisp.  ;;; OPEN-X-STREAM -- for CMU Common Lisp.
656  ;;;  ;;;
657  ;;; The file descriptor here just gets tossed into the stream slot of the  ;;; The file descriptor here just gets tossed into the stream slot of the
# Line 1415  Line 674 
674    
675  ;;; BUFFER-READ-DEFAULT - read data from the X stream  ;;; BUFFER-READ-DEFAULT - read data from the X stream
676    
 #+(or Genera explorer)  
 (defun buffer-read-default (display vector start end timeout)  
   ;; returns non-NIL if EOF encountered  
   ;; Returns :TIMEOUT when timeout exceeded  
   (declare (type display display)  
            (type buffer-bytes vector)  
            (type array-index start end)  
            (type (or null (real 0 *)) timeout))  
   #.(declare-buffun)  
   (let ((stream (display-input-stream display)))  
     (or (cond ((null stream))  
               ((funcall stream :listen) nil)  
               ((and timeout (= timeout 0)) :timeout)  
               ((buffer-input-wait-default display timeout)))  
         (multiple-value-bind (ignore eofp)  
             (funcall stream :string-in nil vector start end)  
           eofp))))  
   
   
 #+excl  
 ;;  
 ;; Rewritten 10/89 to not use foreign function interface to do I/O.  
 ;;  
 (defun buffer-read-default (display vector start end timeout)  
   (declare (type display display)  
            (type buffer-bytes vector)  
            (type array-index start end)  
            (type (or null (real 0 *)) timeout))  
   #.(declare-buffun)  
   
   (let* ((howmany (- end start))  
          (fd (display-input-stream display)))  
     (declare (type array-index howmany)  
              (fixnum fd))  
     (or (cond ((fd-char-avail-p fd) nil)  
               ((and timeout (= timeout 0)) :timeout)  
               ((buffer-input-wait-default display timeout)))  
         (fd-read-bytes fd vector start howmany))))  
   
   
 #+lcl3.0  
 (defmacro with-underlying-stream ((variable stream display direction) &body body)  
   `(let ((,variable  
           (or (getf (display-plist ,display) ',direction)  
               (setf (getf (display-plist ,display) ',direction)  
                     (lucid::underlying-stream  
                       ,stream ,(if (eq direction 'input) :input :output))))))  
      ,@body))  
   
 #+lcl3.0  
 (defun buffer-read-default (display vector start end timeout)  
   ;;Note that LISTEN must still be done on "slow stream" or the I/O system  
   ;;gets confused.  But reading should be done from "fast stream" for speed.  
   ;;We used to inhibit scheduling because there were races in Lucid's  
   ;;multitasking system.  Empirical evidence suggests they may be gone now.  
   ;;Should you decide you need to inhibit scheduling, do it around the  
   ;;lcl:read-array.  
   (declare (type display display)  
            (type buffer-bytes vector)  
            (type array-index start end)  
            (type (or null (real 0 *)) timeout))  
   #.(declare-buffun)  
   (let ((stream (display-input-stream display)))  
     (declare (type (or null stream) stream))  
     (or (cond ((null stream))  
               ((listen stream) nil)  
               ((and timeout (= timeout 0)) :timeout)  
               ((buffer-input-wait-default display timeout)))  
         (with-underlying-stream (stream stream display input)  
           (eq (lcl:read-array stream vector start end nil :eof) :eof)))))  
   
 #+Minima  
 (defun buffer-read-default (display vector start end timeout)  
   ;; returns non-NIL if EOF encountered  
   ;; Returns :TIMEOUT when timeout exceeded  
   (declare (type display display)  
            (type buffer-bytes vector)  
            (type array-index start end)  
            (type (or null (real 0 *)) timeout))  
   #.(declare-buffun)  
   (let ((stream (display-input-stream display)))  
     (or (cond ((null stream))  
               ((listen stream) nil)  
               ((and timeout (= timeout 0)) :timeout)  
               ((buffer-input-wait-default display timeout)))  
         (eq :eof (minima:read-vector vector stream nil start end)))))  
   
677  ;;; BUFFER-READ-DEFAULT for CMU Common Lisp.  ;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
678  ;;;  ;;;
679  ;;;    If timeout is 0, then we call LISTEN to see if there is any input.  ;;;    If timeout is 0, then we call LISTEN to see if there is any input.
# Line 1529  Line 701 
701  ;;;     receiving all data from the X Window System server.  ;;;     receiving all data from the X Window System server.
702  ;;;     You are encouraged to write a specialized version of  ;;;     You are encouraged to write a specialized version of
703  ;;;     buffer-read-default that does block transfers.  ;;;     buffer-read-default that does block transfers.
704  #-(or Genera explorer excl lcl3.0 Minima CMU)  #-(or CMU)
705  (defun buffer-read-default (display vector start end timeout)  (defun buffer-read-default (display vector start end timeout)
706    (declare (type display display)    (declare (type display display)
707             (type buffer-bytes vector)             (type buffer-bytes vector)
708             (type array-index start end)             (type array-index start end)
709             (type (or null (real 0 *)) timeout))             (type (or null (real 0 *)) timeout))
710    #.(declare-buffun)    #.(declare-buffun)
711    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
     (declare (type (or null stream) stream))  
     (or (cond ((null stream))  
               ((listen stream) nil)  
               ((and timeout (= timeout 0)) :timeout)  
               ((buffer-input-wait-default display timeout)))  
         (do* ((index start (index1+ index)))  
              ((index>= index end) nil)  
           (declare (type array-index index))  
           (let ((c (read-byte stream nil nil)))  
             (declare (type (or null card8) c))  
             (if (null c)  
                 (return t)  
               (setf (aref vector index) (the card8 c))))))))  
   
 ;;; BUFFER-WRITE-DEFAULT - write data to the X stream  
   
 #+(or Genera explorer)  
 (defun buffer-write-default (vector display start end)  
   ;; The default buffer write function for use with common-lisp streams  
   (declare (type buffer-bytes vector)  
            (type display display)  
            (type array-index start end))  
   #.(declare-buffun)  
   (let ((stream (display-output-stream display)))  
     (declare (type (or null stream) stream))  
     (unless (null stream)  
       (write-string vector stream :start start :end end))))  
   
 #+excl  
 (defun buffer-write-default (vector display start end)  
   (declare (type buffer-bytes vector)  
            (type display display)  
            (type array-index start end))  
   #.(declare-buffun)  
   (excl::filesys-write-bytes (display-output-stream display) vector start  
                              (- end start)))  
   
 #+lcl3.0  
 (defun buffer-write-default (vector display start end)  
   ;;We used to inhibit scheduling because there were races in Lucid's  
   ;;multitasking system.  Empirical evidence suggests they may be gone now.  
   ;;Should you decide you need to inhibit scheduling, do it around the  
   ;;lcl:write-array.  
   (declare (type display display)  
            (type buffer-bytes vector)  
            (type array-index start end))  
   #.(declare-buffun)  
   (let ((stream (display-output-stream display)))  
712      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
713      (unless (null stream)      (or (cond ((null stream))
714        (with-underlying-stream (stream stream display output)                ((listen stream) nil)
715          (lcl:write-array stream vector start end)))))                ((and timeout (= timeout 0)) :timeout)
716                  ((buffer-input-wait-default display timeout)))
717            (do* ((index start (index1+ index)))
718                 ((index>= index end) nil)
719              (declare (type array-index index))
720              (let ((c (read-byte stream nil nil)))
721                (declare (type (or null card8) c))
722                (if (null c)
723                    (return t)
724                  (setf (aref vector index) (the card8 c))))))))
725    
726  #+Minima  ;;; BUFFER-WRITE-DEFAULT - write data to the X stream
 (defun buffer-write-default (vector display start end)  
   ;; The default buffer write function for use with common-lisp streams  
   (declare (type buffer-bytes vector)  
            (type display display)  
            (type array-index start end))  
   #.(declare-buffun)  
   (let ((stream (display-output-stream display)))  
     (declare (type (or null stream) stream))  
     (unless (null stream)  
       (minima:write-vector vector stream start end))))  
727    
728  #+CMU  #+CMU
729  (defun buffer-write-default (vector display start end)  (defun buffer-write-default (vector display start end)
# Line 1617  Line 740 
740  ;;;     You are STRONGLY encouraged to write a specialized version  ;;;     You are STRONGLY encouraged to write a specialized version
741  ;;;     of buffer-write-default that does block transfers.  ;;;     of buffer-write-default that does block transfers.
742    
743  #-(or Genera explorer excl lcl3.0 Minima CMU)  #-(or CMU)
744  (defun buffer-write-default (vector display start end)  (defun buffer-write-default (vector display start end)
745    ;; The default buffer write function for use with common-lisp streams    ;; The default buffer write function for use with common-lisp streams
746    (declare (type buffer-bytes vector)    (declare (type buffer-bytes vector)
# Line 1644  Line 767 
767    
768  ;;; buffer-force-output-default - force output to the X stream  ;;; buffer-force-output-default - force output to the X stream
769    
 #+excl  
 (defun buffer-force-output-default (display)  
   ;; buffer-write-default does the actual writing.  
   (declare (ignore display)))  
   
 #-(or excl)  
770  (defun buffer-force-output-default (display)  (defun buffer-force-output-default (display)
771    ;; The default buffer force-output function for use with common-lisp streams    ;; The default buffer force-output function for use with common-lisp streams
772    (declare (type display display))    (declare (type display display))
# Line 1660  Line 777 
777    
778  ;;; BUFFER-CLOSE-DEFAULT - close the X stream  ;;; BUFFER-CLOSE-DEFAULT - close the X stream
779    
 #+excl  
 (defun buffer-close-default (display &key abort)  
   ;; The default buffer close function for use with common-lisp streams  
   (declare (type display display)  
            (ignore abort))  
   #.(declare-buffun)  
   (excl::filesys-checking-close (display-output-stream display)))  
   
 #-(or excl)  
780  (defun buffer-close-default (display &key abort)  (defun buffer-close-default (display &key abort)
781    ;; The default buffer close function for use with common-lisp streams    ;; The default buffer close function for use with common-lisp streams
782    (declare (type display display))    (declare (type display display))
# Line 1686  Line 794 
794  ;;; The default implementation  ;;; The default implementation
795    
796  ;; Poll for input every *buffer-read-polling-time* SECONDS.  ;; Poll for input every *buffer-read-polling-time* SECONDS.
797  #-(or Genera explorer excl lcl3.0 CMU)  #-(or CMU)
798  (defparameter *buffer-read-polling-time* 0.5)  (defparameter *buffer-read-polling-time* 0.5)
799    
800  #-(or Genera explorer excl lcl3.0 CMU)  #-(or CMU)
801  (defun buffer-input-wait-default (display timeout)  (defun buffer-input-wait-default (display timeout)
802    (declare (type display display)    (declare (type display display)
803             (type (or null (real 0 *)) timeout))             (type (or null (real 0 *)) timeout))
# Line 1730  Line 838 
838                 nil                 nil
839                 :timeout)))))                 :timeout)))))
840    
 #+Genera  
 (defun buffer-input-wait-default (display timeout)  
   (declare (type display display)  
            (type (or null (real 0 *)) timeout))  
   (declare (clx-values timeout))  
   (let ((stream (display-input-stream display)))  
     (declare (type (or null stream) stream))  
     (cond ((null stream))  
           ((scl:send stream :listen) nil)  
           ((and timeout (= timeout 0)) :timeout)  
           ((null timeout) (si:stream-input-block stream "CLX Input"))  
           (t  
            (scl:condition-bind ((neti:protocol-timeout  
                                   #'(lambda (error)  
                                       (when (eq stream (scl:send error :stream))  
                                         (return-from buffer-input-wait-default :timeout)))))  
              (neti:with-stream-timeout (stream :input timeout)  
                (si:stream-input-block stream "CLX Input")))))  
     nil))  
   
 #+explorer  
 (defun buffer-input-wait-default (display timeout)  
   (declare (type display display)  
            (type (or null (real 0 *)) timeout))  
   (declare (clx-values timeout))  
   (let ((stream (display-input-stream display)))  
     (declare (type (or null stream) stream))  
     (cond ((null stream))  
           ((zl:send stream :listen) nil)  
           ((and timeout (= timeout 0)) :timeout)  
           ((null timeout)  
            (si:process-wait "CLX Input" stream :listen))  
           (t  
            (unless (si:process-wait-with-timeout  
                        "CLX Input" (round (* timeout 60.)) stream :listen)  
              (return-from buffer-input-wait-default :timeout))))  
     nil))  
   
 #+excl  
 ;;  
 ;; This is used so an 'eq' test may be used to find out whether or not we can  
 ;; safely throw this process out of the CLX read loop.  
 ;;  
 (defparameter *read-whostate* "waiting for input from X server")  
   
 ;;  
 ;; Note that this function returns nil on error if the scheduler is running,  
 ;; t on error if not.  This is ok since buffer-read will detect the error.  
 ;;  
 #+excl  
 (defun buffer-input-wait-default (display timeout)  
   (declare (type display display)  
            (type (or null (real 0 *)) timeout))  
   (declare (clx-values timeout))  
   (let ((fd (display-input-stream display)))  
     (declare (fixnum fd))  
     (when (>= fd 0)  
       (cond ((fd-char-avail-p fd)  
              nil)  
   
             ;; Otherwise no bytes were available on the socket  
             ((and timeout (= timeout 0))  
              ;; If there aren't enough and timeout == 0, timeout.  
              :timeout)  
   
             ;; If the scheduler is running let it do timeouts.  
             (mp::*scheduler-stack-group*  
              #+allegro  
              (if (not  
                   (mp:wait-for-input-available fd :whostate *read-whostate*  
                                                :wait-function #'fd-char-avail-p  
                                                :timeout timeout))  
                  (return-from buffer-input-wait-default :timeout))  
              #-allegro  
              (mp::wait-for-input-available fd :whostate *read-whostate*  
                                            :wait-function #'fd-char-avail-p))  
   
             ;; Otherwise we have to handle timeouts by hand, and call select()  
             ;; to block until input is available.  Note we don't really handle  
             ;; the interaction of interrupts and (numberp timeout) here.  XX  
             (t  
              (let ((res 0))  
                (declare (fixnum res))  
                (with-interrupt-checking-on  
                 (loop  
                   (setq res (fd-wait-for-input fd (if (null timeout) 0  
                                                     (truncate timeout))))  
                   (cond ((plusp res)    ; success  
                          (return nil))  
                         ((eq res 0)     ; timeout  
                          (return :timeout))  
                         ((eq res -1)    ; error  
                          (return t))  
                         ;; Otherwise we got an interrupt -- go around again.  
                         )))))))))  
   
   
 #+lcl3.0  
 (defun buffer-input-wait-default (display timeout)  
   (declare (type display display)  
            (type (or null (real 0 *)) timeout)  
            (clx-values timeout))  
   #.(declare-buffun)  
   (let ((stream (display-input-stream display)))  
     (declare (type (or null stream) stream))  
     (cond ((null stream))  
           ((listen stream) nil)  
           ((and timeout (= timeout 0)) :timeout)  
           ((with-underlying-stream (stream stream display input)  
              (lucid::waiting-for-input-from-stream stream  
                (lucid::with-io-unlocked  
                  (if (null timeout)  
                      (lcl:process-wait "CLX Input" #'listen stream)  
                    (lcl:process-wait-with-timeout  
                      "CLX Input" timeout #'listen stream)))))  
            nil)  
           (:timeout))))  
   
841    
842  ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the  ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
843  ;;; buffer. This should never block, so it can be called from the scheduler.  ;;; buffer. This should never block, so it can be called from the scheduler.
844    
845  ;;; The default implementation is to just use listen.  ;;; The default implementation is to just use listen.
846  #-(or excl)  
847  (defun buffer-listen-default (display)  (defun buffer-listen-default (display)
848    (declare (type display display))    (declare (type display display))
849    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
# Line 1862  Line 852 
852          t          t
853        (listen stream))))        (listen stream))))
854    
 #+excl  
 (defun buffer-listen-default (display)  
   (declare (type display display))  
   (let ((fd (display-input-stream display)))  
     (declare (type fixnum fd))  
     (if (= fd -1)  
         t  
       (fd-char-avail-p fd))))  
   
855    
856  ;;;----------------------------------------------------------------------------  ;;;----------------------------------------------------------------------------
857  ;;; System dependent speed hacks  ;;; System dependent speed hacks
# Line 1882  Line 863 
863  ;; consing garbage, you may want to re-write this to allocate and  ;; consing garbage, you may want to re-write this to allocate and
864  ;; initialize lists from a resource.  ;; initialize lists from a resource.
865  ;;  ;;
 #-lispm  
866  (defmacro with-stack-list ((var &rest elements) &body body)  (defmacro with-stack-list ((var &rest elements) &body body)
867    ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)    ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
868    ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)    ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
# Line 1890  Line 870 
870    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
871    `(let ((,var (list ,@elements)))    `(let ((,var (list ,@elements)))
872       (declare (type cons ,var)       (declare (type cons ,var)
873                #+clx-ansi-common-lisp (dynamic-extent ,var))                (dynamic-extent ,var))
874       ,@body))       ,@body))
875    
 #-lispm  
876  (defmacro with-stack-list* ((var &rest elements) &body body)  (defmacro with-stack-list* ((var &rest elements) &body body)
877    ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)    ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
878    ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)    ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
# Line 1901  Line 880 
880    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.    ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
881    `(let ((,var (list* ,@elements)))    `(let ((,var (list* ,@elements)))
882       (declare (type cons ,var)       (declare (type cons ,var)
883                #+clx-ansi-common-lisp (dynamic-extent ,var))                (dynamic-extent ,var))
884       ,@body))       ,@body))
885    
886  (declaim (inline buffer-replace))  (declaim (inline buffer-replace))
887    
 #+lispm  
 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))  
   (declare (type vector buf1 buf2)  
            (type array-index start1 end1 start2))  
   (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))  
   
 #+excl  
 (defun buffer-replace (target-sequence source-sequence target-start  
                                        target-end &optional (source-start 0))  
   (declare (type buffer-bytes target-sequence source-sequence)  
            (type array-index target-start target-end source-start)  
            (optimize (speed 3) (safety 0)))  
   
   (let ((source-end (length source-sequence)))  
     (declare (type array-index source-end))  
   
     (excl:if* (and (eq target-sequence source-sequence)  
                    (> target-start source-start))  
        then (let ((nelts (min (- target-end target-start)  
                               (- source-end source-start))))  
               (do ((target-index (+ target-start nelts -1) (1- target-index))  
                    (source-index (+ source-start nelts -1) (1- source-index)))  
                   ((= target-index (1- target-start)) target-sequence)  
                 (declare (type array-index target-index source-index))  
   
                 (setf (aref target-sequence target-index)  
                   (aref source-sequence source-index))))  
        else (do ((target-index target-start (1+ target-index))  
                  (source-index source-start (1+ source-index)))  
                 ((or (= target-index target-end) (= source-index source-end))  
                  target-sequence)  
               (declare (type array-index target-index source-index))  
   
               (setf (aref target-sequence target-index)  
                 (aref source-sequence source-index))))))  
   
888  #+cmu  #+cmu
889  (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))  (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
890    (declare (type buffer-bytes buf1 buf2)    (declare (type buffer-bytes buf1 buf2)
# Line 1954  Line 897 
897             (* vm:vector-data-offset vm:word-bits))             (* vm:vector-data-offset vm:word-bits))
898     (* (- end1 start1) vm:byte-bits)))     (* (- end1 start1) vm:byte-bits)))
899    
900  #+lucid  #-CMU
 ;;;The compiler is *supposed* to optimize calls to replace, but in actual  
 ;;;fact it does not.  
 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))  
   (declare (type buffer-bytes buf1 buf2)  
            (type array-index start1 end1 start2))  
   #.(declare-buffun)  
   (let ((end2 (lucid::%simple-8bit-vector-length buf2)))  
     (declare (type array-index end2))  
     (lucid::simple-8bit-vector-replace-internal  
       buf1 buf2 start1 end1 start2 end2)))  
   
 #+(and clx-overlapping-arrays (not (or lispm excl)))  
 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))  
   (declare (type vector buf1 buf2)  
            (type array-index start1 end1 start2))  
   (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))  
   
 #-(or lispm lucid excl CMU clx-overlapping-arrays)  
901  (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))  (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
902    (declare (type buffer-bytes buf1 buf2)    (declare (type buffer-bytes buf1 buf2)
903             (type array-index start1 end1 start2))             (type array-index start1 end1 start2))
904    (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))    (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
905    
 #+ti  
 (defun with-location-bindings (sys:&quote bindings &rest body)  
   (do ((bindings bindings (cdr bindings)))  
       ((null bindings)  
        (sys:eval-body-as-progn body))  
     (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))  
               (sys:*eval (cadar bindings)))))  
   
 #+ti  
 (compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)  
   (let ((bindings (cadr form))  
         (body (cddr form)))  
     `(let ()  
        ,@(loop for (accessor value) in bindings  
                collect `(si:bind (si:locf ,accessor) ,value))  
        ,@body)))  
   
 #+ti  
 (defun (:property with-location-bindings compiler::cw-handler) (exp)  
   (let* ((bindlist (mapcar #'compiler::cw-clause (second exp)))  
          (body (compiler::cw-clause (cddr exp))))  
     (and compiler::cw-return-expansion-flag  
          (list* (first exp) bindlist body))))  
   
 #+(and lispm (not ti))  
 (defmacro with-location-bindings (bindings &body body)  
   `(sys:letf* ,bindings ,@body))  
   
 #+lispm  
 (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)  
                                   &body body)  
   ;; don't use svref on LHS because Symbolics didn't define locf for it  
   (let* ((local-state (gensym))  
          (bindings `(((aref ,local-state ,ts-index) 0))))       ; will become zero anyway  
     (dolist (index indexes)  
       (push `((aref ,local-state ,index) (svref ,saved-state ,index))  
             bindings))  
     `(let ((,local-state (gcontext-local-state ,gc)))  
        (declare (type gcontext-state ,local-state))  
        (unwind-protect  
            (with-location-bindings ,bindings  
              ,@body)  
          (setf (svref ,local-state ,ts-index) 0)  
          (when ,temp-gc  
            (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))  
          (deallocate-gcontext-state ,saved-state)))))  
   
 #-lispm  
906  (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)  (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
907                                    &body body)                                    &body body)
908    (let ((local-state (gensym))    (let ((local-state (gensym))
# Line 2077  Line 954 
954  ;;; 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
955  ;;; 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
956  ;;; production time.  ;;; production time.
957  (defconstant *type-check?* #+(or Genera Minima CMU) nil #-(or Genera Minima CMU) t)  (defconstant *type-check?* #+(or CMU) nil #-(or CMU) t)
958    
959  ;; 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
960  ;; 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 2090  Line 967 
967  ;; dispatching, not just type checking.  -- Ram.  ;; dispatching, not just type checking.  -- Ram.
968    
969  (defmacro type? (object type)  (defmacro type? (object type)
970    #+cmu    `(typep ,object ,type))
   `(typep ,object ,type)  
   #-cmu  
   (if (not (constantp type))  
       `(typep ,object ,type)  
     (progn  
       (setq type (eval type))  
       #+(or Genera explorer Minima)  
       (if *type-check?*  
           `(locally (declare (optimize safety)) (typep ,object ',type))  
         `(typep ,object ',type))  
       #-(or Genera explorer Minima)  
       (let ((predicate (assoc type  
                               '((drawable drawable-p) (window window-p)  
                                 (pixmap pixmap-p) (cursor cursor-p)  
                                 (font font-p) (gcontext gcontext-p)  
                                 (colormap colormap-p) (null null)  
                                 (integer integerp)))))  
         (cond (predicate  
                `(,(second predicate) ,object))  
               ((eq type 'generalized-boolean)  
                't)                      ; Everything is a generalized-boolean.  
               (*type-check?*  
                `(locally (declare (optimize safety)) (typep ,object ',type)))  
               (t  
                `(typep ,object ',type)))))))  
971    
972  ;; X-TYPE-ERROR is the function called for type errors.  ;; X-TYPE-ERROR is the function called for type errors.
973  ;; If you want lots of checking, but are concerned about code size,  ;; If you want lots of checking, but are concerned about code size,
# Line 2144  Line 996 
996        (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)
997        (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)))
998    
 #+(and lispm (not Genera) (not clx-ansi-common-lisp))  
 (defun x-error (condition &rest keyargs)  
   (apply #'sys:signal condition keyargs))  
   
 #+(and lispm (not Genera) (not clx-ansi-common-lisp))  
 (defun x-cerror (proceed-format-string condition &rest keyargs)  
   (sys:signal (apply #'zl:make-condition condition keyargs)  
               :proceed-types proceed-format-string))  
   
 #+(and Genera (not clx-ansi-common-lisp))  
 (defun x-error (condition &rest keyargs)  
   (declare (dbg:error-reporter))  
   (apply #'sys:signal condition keyargs))  
   
 #+(and Genera (not clx-ansi-common-lisp))  
 (defun x-cerror (proceed-format-string condition &rest keyargs)  
   (declare (dbg:error-reporter))  
   (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))  
   
 #+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp))  
999  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
1000    (declare (dynamic-extent keyargs))    (declare (dynamic-extent keyargs))
1001    (apply #'error condition keyargs))    (apply #'error condition keyargs))
1002    
 #+(or clx-ansi-common-lisp excl lcl3.0 CMU)  
1003  (defun x-cerror (proceed-format-string condition &rest keyargs)  (defun x-cerror (proceed-format-string condition &rest keyargs)
1004    (declare (dynamic-extent keyargs))    (declare (dynamic-extent keyargs))
1005    (apply #'cerror proceed-format-string condition keyargs))    (apply #'cerror proceed-format-string condition keyargs))
# Line 2191  Line 1022 
1022          (ext::disable-clx-event-handling disp)))          (ext::disable-clx-event-handling disp)))
1023      (error condx)))      (error condx)))
1024    
 #-(or lispm ansi-common-lisp excl lcl3.0 CMU)  
 (defun x-error (condition &rest keyargs)  
   (error "X-Error: ~a"  
          (princ-to-string (apply #'make-condition condition keyargs))))  
   
 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)  
 (defun x-cerror (proceed-format-string condition &rest keyargs)  
   (cerror proceed-format-string "X-Error: ~a"  
          (princ-to-string (apply #'make-condition condition keyargs))))  
   
 ;; version 15 of Pitman error handling defines the syntax for define-condition to be:  
 ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]  
 ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)  
 ;; or (:report exp)  
   
 #+lcl3.0  
 (defmacro define-condition (name parent-types &optional slots &rest args)  
   `(lcl:define-condition  
      ,name (,(first parent-types))  
      ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))  
               slots)  
      ,@args))  
   
 #+(and excl (not clx-ansi-common-lisp))  
 (defmacro define-condition (name parent-types &optional slots &rest args)  
   `(excl::define-condition  
      ,name (,(first parent-types))  
      ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))  
               slots)  
      ,@args))  
   
 #+(and CMU (not clx-ansi-common-lisp))  
 (defmacro define-condition (name parent-types &optional slots &rest args)  
   `(lisp:define-condition  
      ,name (,(first parent-types))  
      ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))  
               slots)  
      ,@args))  
   
 #+(and lispm (not clx-ansi-common-lisp))  
 (defmacro define-condition (name parent-types &body options)  
   (let ((slot-names  
           (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))  
                   (pop options)))  
         (documentation nil)  
         (conc-name (concatenate 'string (string name) "-"))  
         (reporter nil))  
     (dolist (item options)  
       (ecase (first item)  
         (:documentation (setq documentation (second item)))  
         (:conc-name (setq conc-name (string (second item))))  
         (:report (setq reporter (second item)))))  
     `(within-definition (,name define-condition)  
        (zl:defflavor ,name ,slot-names ,parent-types  
          :initable-instance-variables  
          #-Genera  
          (:accessor-prefix ,conc-name)  
          #+Genera  
          (:conc-name ,conc-name)  
          #-Genera  
          (:outside-accessible-instance-variables ,@slot-names)  
          #+Genera  
          (:readable-instance-variables ,@slot-names))  
        ,(when reporter ;; when no reporter, parent's is inherited  
           `(zl:defmethod #-Genera (,name :report)  
                          #+Genera (dbg:report ,name) (stream)  
               ,(if (stringp reporter)  
                    `(write-string ,reporter stream)  
                  `(,reporter global:self stream))  
               global:self))  
        (zl:compile-flavor-methods ,name)  
        ,(when documentation  
           `(setf (documentation name 'type) ,documentation))  
        ',name)))  
   
 #+(and lispm (not Genera) (not clx-ansi-common-lisp))  
 (zl:defflavor x-error () (global:error))  
   
 #+(and Genera (not clx-ansi-common-lisp))  
 (scl:defflavor x-error  
         ((dbg:proceed-types '(:continue))       ;  
          continue-format-string)  
         (sys:error)  
   (:initable-instance-variables continue-format-string))  
   
 #+(and Genera (not clx-ansi-common-lisp))  
 (scl:defmethod (scl:make-instance x-error) (&rest ignore)  
   (when (not (sys:variable-boundp continue-format-string))  
     (setf dbg:proceed-types (remove :continue dbg:proceed-types))))  
   
 #+(and Genera (not clx-ansi-common-lisp))  
 (scl:defmethod (dbg:proceed x-error :continue) ()  
   :continue)  
   
 #+(and Genera (not clx-ansi-common-lisp))  
 (sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)  
   (format stream continue-format-string))  
1025    
 #+(or clx-ansi-common-lisp excl lcl3.0 CMU)  
1026  (define-condition x-error (error) ())  (define-condition x-error (error) ())
1027    
 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)  
 (defstruct x-error  
   report-function)  
   
 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)  
 (defmacro define-condition (name parent-types &body options)  
   ;; Define a structure that when printed displays an error message  
   (flet ((reporter-for-condition (name)  
            (xintern "." name '-reporter.)))  
     (let ((slot-names  
             (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))  
                     (pop options)))  
           (documentation nil)  
           (conc-name (concatenate 'string (string name) "-"))  
           (reporter nil)  
           (condition (gensym))  
           (stream (gensym))  
           (report-function (reporter-for-condition name)))  
       (dolist (item options)  
         (ecase (first item)  
           (:documentation (setq documentation (second item)))  
           (:conc-name (setq conc-name (string (second item))))  
           (:report (setq reporter (second item)))))  
       (unless reporter  
         (setq report-function (reporter-for-condition (first parent-types))))  
       `(within-definition (,name define-condition)  
          (defstruct (,name (:conc-name ,(intern conc-name))  
                      (:print-function condition-print)  
                      (:include ,(first parent-types)  
                       (report-function ',report-function)))  
            ,@slot-names)  
          ,(when documentation  
             `(setf (documentation name 'type) ,documentation))  
          ,(when reporter  
             `(defun ,report-function (,condition ,stream)  
                ,(if (stringp reporter)  
                     `(write-string ,reporter ,stream)  
                   `(,reporter ,condition ,stream))  
                ,condition))  
          ',name))))  
   
 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)  
 (defun condition-print (condition stream depth)  
   (declare (type x-error condition)  
            (type stream stream)  
            (ignore depth))  
   (if *print-escape*  
       (print-unreadable-object (condition stream :type t))  
     (funcall (x-error-report-function condition) condition stream))  
   condition)  
   
 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)  
 (defun make-condition (type &rest slot-initializations)  
   (declare (dynamic-extent slot-initializations))  
   (let ((make-function (intern (concatenate 'string (string 'make-) (string type))  
                                (symbol-package type))))  
     (apply make-function slot-initializations)))  
   
 #-(or clx-ansi-common-lisp excl lcl3.0 CMU)  
 (define-condition type-error (x-error)  
   ((datum :reader type-error-datum :initarg :datum)  
    (expected-type :reader type-error-expected-type :initarg :expected-type))  
   (:report  
     (lambda (condition stream)  
       (format stream "~s isn't a ~a"  
               (type-error-datum condition)  
               (type-error-expected-type condition)))))  
1028    
1029    
1030  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
1031  ;;  HOST hacking  ;;  HOST hacking
1032  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
1033    
1034  #-(or explorer Genera Minima Allegro CMU)  #-(or CMU)
1035  (defun host-address (host &optional (family :internet))  (defun host-address (host &optional (family :internet))
1036    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
1037    ;; and cdr is a list of network address bytes.    ;; and cdr is a list of network address bytes.
# Line 2375  Line 1041 
1041    host family    host family
1042    (error "HOST-ADDRESS not implemented yet."))    (error "HOST-ADDRESS not implemented yet."))
1043    
 #+explorer  
 (defun host-address (host &optional (family :internet))  
   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)  
   ;; and cdr is a list of network address bytes.  
   (declare (type stringable host)  
            (type (or null (member :internet :decnet :chaos) card8) family))  
   (declare (clx-values list))  
   (ecase family  
     ((:internet nil 0)  
      (let ((addr (ip:get-ip-address host)))  
        (unless addr (error "~s isn't an internet host name" host))  
        (list :internet  
              (ldb (byte 8 24) addr)  
              (ldb (byte 8 16) addr)  
              (ldb (byte 8 8) addr)  
              (ldb (byte 8 0) addr))))  
     ((:chaos 2)  
      (let ((addr (first (chaos:chaos-addresses host))))  
        (unless addr (error "~s isn't a chaos host name" host))  
        (list :chaos  
              (ldb (byte 8 0) addr)  
              (ldb (byte 8 8) addr))))))  
   
 #+Genera  
 (defun host-address (host &optional (family :internet))  
   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)  
   ;; and cdr is a list of network address bytes.  
   (declare (type stringable host)  
            (type (or null (member :internet :decnet :chaos) card8) family))  
   (declare (clx-values list))  
   (setf host (string host))  
   (let ((net-type (ecase family  
                     ((:internet nil 0) :internet)  
                     ((:DECnet 1) :dna)  
                     ((:chaos 2) :chaos))))  
     (dolist (addr  
               (sys:send (net:parse-host host) :network-addresses)  
               (error "~S isn't a valid ~(~A~) host name" host family))  
       (let ((network (car addr))  
             (address (cadr addr)))  
         (when (sys:send network :network-typep net-type)  
           (return (ecase family  
                     ((:internet nil 0)  
                      (multiple-value-bind (a b c d) (tcp:explode-internet-address address)  
                        (list :internet a b c d)))  
                     ((:DECnet 1)  
                      (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address)))  
                     ((:chaos 2)  
                      (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))  
   
 #+Minima  
 (defun host-address (host &optional (family :internet))  
   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)  
   ;; and cdr is a list of network address bytes.  
   (declare (type stringable host)  
            (type (or null (member :internet :decnet :chaos) card8) family))  
   (declare (clx-values list))  
   (etypecase family  
     ((:internet nil 0)  
       (list* :internet  
              (multiple-value-list  
                (minima:ip-address-components (minima:parse-ip-address (string host))))))))  
   
 #+Allegro  
 (defun host-address (host &optional (family :internet))  
   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)  
   ;; and cdr is a list of network address bytes.  
   (declare (type stringable host)  
            (type (or null (member :internet :decnet :chaos) card8) family))  
   (declare (clx-values list))  
   (labels ((no-host-error ()  
              (error "Unknown host ~S" host))  
            (no-address-error ()  
              (error "Host ~S has no ~S address" host family)))  
     (let ((hostent 0))  
       (unwind-protect  
            (progn  
              (setf hostent (ipc::gethostbyname (string host)))  
              (when (zerop hostent)  
                (no-host-error))  
              (ecase family  
                ((:internet nil 0)  
                 (unless (= (ipc::hostent-addrtype hostent) 2)  
                   (no-address-error))  
                 (assert (= (ipc::hostent-length hostent) 4))  
                 (let ((addr (ipc::hostent-addr hostent)))  
                    (when (or (member comp::.target.  
                                      '(:hp :sgi4d :sony :dec3100)  
                                      :test #'eq)  
                              (probe-file "/lib/ld.so"))  
                      ;; BSD 4.3 based systems require an extra indirection  
                      (setq addr (si:memref-int addr 0 0 :unsigned-long)))  
                   (list :internet  
                         (si:memref-int addr 0 0 :unsigned-byte)  
                         (si:memref-int addr 1 0 :unsigned-byte)  
                         (si:memref-int addr 2 0 :unsigned-byte)  
                         (si:memref-int addr 3 0 :unsigned-byte))))))  
         (ff:free-cstruct hostent)))))  
   
1044  #+CMU  #+CMU
1045  (defun host-address (host &optional (family :internet))  (defun host-address (host &optional (family :internet))
1046    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)    ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
# Line 2499  Line 1066 
1066                   (ldb (byte 8  8) addr)                   (ldb (byte 8  8) addr)
1067                   (ldb (byte 8  0) addr))))))))                   (ldb (byte 8  0) addr))))))))
1068    
 ;;;  
   
 #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts  
 (defun get-host (host-object)  
   ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)  
   ;; and cdr is a list of network address bytes.  
   (declare (type list host-object))  
   (declare (clx-values string family))  
   (let* ((family (first host-object))  
          (address (ecase family  
                     (:internet  
                      (dpb (second host-object)  
                           (byte 8 24)  
                           (dpb (third host-object)  
                                (byte 8 16)  
                                (dpb (fourth host-object)  
                                     (byte 8 8)  
                                     (fifth host-object)))))  
                     (:chaos  
                      (dpb (third host-object) (byte 8 8) (second host-object))))))  
     (when (eq family :internet) (setq family :ip))  
     (let ((host (si:get-host-from-address address family)))  
       (values (and host (funcall host :name)) family))))  
   
 ;;; This isn't required, but it helps make sense of the results from access-hosts  
 #+Genera  
 (defun get-host (host-object)  
   ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)  
   ;; and cdr is a list of network address bytes.  
   (declare (type list host-object))  
   (declare (clx-values string family))  
   (let ((family (first host-object)))  
     (values (sys:send (net:get-host-from-address  
                         (ecase family  
                           (:internet  
                             (apply #'tcp:build-internet-address (rest host-object)))  
                           ((:chaos :DECnet)  
                            (dpb (third host-object) (byte 8 8) (second host-object))))  
                         (net:local-network-of-type (if (eq family :DECnet)  
                                                        :DNA  
                                                        family)))  
                       :name)  
             family)))  
   
 ;;; This isn't required, but it helps make sense of the results from access-hosts  
 #+Minima  
 (defun get-host (host-object)  
   ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)  
   ;; and cdr is a list of network address bytes.  
   (declare (type list host-object))  
   (declare (clx-values string family))  
   (let ((family (first host-object)))  
     (values (ecase family  
               (:internet  
                 (minima:ip-address-string  
                   (apply #'minima:make-ip-address (rest host-object)))))  
             family)))  
   
1069    
1070  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
1071  ;; Whether to use closures for requests or not.  ;; Whether to use closures for requests or not.
# Line 2569  Line 1078 
1078  ;;; 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.
1079    
1080  (defmacro use-closures ()  (defmacro use-closures ()
1081    #+(or lispm Minima) t    nil)
   #-(or lispm Minima) nil)  
   
 #+(or Genera Minima)  
 (defun clx-macroexpand (form env)  
   (declare (ignore env))  
   form)  
1082    
 #-(or Genera Minima)  
1083  (defun clx-macroexpand (form env)  (defun clx-macroexpand (form env)
1084    (macroexpand form env))    (macroexpand form env))
1085    
# Line 2590  Line 1092 
1092  ;;; Utilities  ;;; Utilities
1093    
1094  (defun getenv (name)  (defun getenv (name)
   #+excl (sys:getenv name)  
   #+lcl3.0 (lcl:environment-variable name)  
1095    #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))    #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
1096    #-(or excl lcl3.0 CMU) (progn name nil))    #-(or CMU) (progn name nil))
1097    
1098  (defun homedir-file-pathname (name)  (defun homedir-file-pathname (name)
1099    (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)    (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
# Line 2612  Line 1112 
1112    (or (let ((string (getenv "XENVIRONMENT")))    (or (let ((string (getenv "XENVIRONMENT")))
1113          (and string          (and string
1114               (pathname string)))               (pathname string)))
1115        (homedir-file-pathname (concatenate 'string ".Xdefaults-"        (homedir-file-pathname (concatenate 'string ".Xdefaults-" (machine-instance)))))
                                           #+excl (short-site-name)  
                                           #-excl (machine-instance)))))  
1116    
1117  ;;; AUTHORITY-PATHNAME - The pathname of the authority file.  ;;; AUTHORITY-PATHNAME - The pathname of the authority file.
1118    
# Line 2643  Line 1141 
1141    (setq *temp-gcontext-cache* nil)    (setq *temp-gcontext-cache* nil)
1142    nil)    nil)
1143    
 #+Genera  
 (si:define-gc-cleanup clx-cleanup ("CLX Cleanup")  
   (gc-cleanup))  
   
   
 ;;-----------------------------------------------------------------------------  
 ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)  
 ;;-----------------------------------------------------------------------------  
   
 #-(or clx-ansi-common-lisp Genera CMU)  
 (defun with-standard-io-syntax-function (function)  
   (declare #+lispm  
            (sys:downward-funarg function))  
   (let ((*package* (find-package :user))  
         (*print-array* t)  
         (*print-base* 10)  
         (*print-case* :upcase)  
         (*print-circle* nil)  
         (*print-escape* t)  
         (*print-gensym* t)  
         (*print-length* nil)  
         (*print-level* nil)  
         (*print-pretty* nil)  
         (*print-radix* nil)  
         (*read-base* 10)  
         (*read-default-float-format* 'single-float)  
         (*read-suppress* nil)  
         #+ticl (ticl:*print-structure* t)  
         #+lucid (lucid::*print-structure* t))  
     (funcall function)))  
   
 #-(or clx-ansi-common-lisp Genera CMU)  
 (defmacro with-standard-io-syntax (&body body)  
   `(flet ((.with-standard-io-syntax-body. () ,@body))  
      (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))  
1144    
1145    
1146  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
# Line 2695  Line 1158 
1158  ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.  ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
1159  ;;; In ambiguous cases, the most specific translation is used.  ;;; In ambiguous cases, the most specific translation is used.
1160    
 #-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU)  
 (defun default-keysym-translate (display state object)  
   (declare (type display display)  
            (type card16 state)  
            (type t object)  
            (clx-values t)  
            (special left-meta-keysym right-meta-keysym  
                     left-super-keysym right-super-keysym  
                     left-hyper-keysym right-hyper-keysym))  
   (when (characterp object)  
     (when (logbitp (position :control *state-mask-vector*) state)  
       (setf (char-bit object :control) 1))  
     (when (or (state-keysymp display state left-meta-keysym)  
               (state-keysymp display state right-meta-keysym))  
       (setf (char-bit object :meta) 1))  
     (when (or (state-keysymp display state left-super-keysym)  
               (state-keysymp display state right-super-keysym))  
       (setf (char-bit object :super) 1))  
     (when (or (state-keysymp display state left-hyper-keysym)  
               (state-keysymp display state right-hyper-keysym))  
       (setf (char-bit object :hyper) 1)))  
   object)  
1161    
 #+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU)  
1162  (defun default-keysym-translate (display state object)  (defun default-keysym-translate (display state object)
1163    (declare (type display display)    (declare (type display display)
1164             (type card16 state)             (type card16 state)
# Line 2750  Line 1190 
1190    '(unsigned-byte 24))    '(unsigned-byte 24))
1191    
1192  (deftype pixarray-32-element-type ()  (deftype pixarray-32-element-type ()
1193    #-(or Genera Minima) '(unsigned-byte 32)   '(unsigned-byte 32))
   #+(or Genera Minima) 'fixnum)  
1194    
1195  (deftype pixarray-1  ()  (deftype pixarray-1  ()
1196    '(#+cmu simple-array #-cmu array pixarray-1-element-type (* *)))    '(simple-array pixarray-1-element-type (* *)))
1197    
1198  (deftype pixarray-4  ()  (deftype pixarray-4  ()
1199    '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))    '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))
1200    
1201  (deftype pixarray-8  ()  (deftype pixarray-8  ()
1202    '(#+cmu simple-array #-cmu array pixarray-8-element-type (* *)))    '(simple-array pixarray-8-element-type (* *)))
1203    
1204  (deftype pixarray-16 ()  (deftype pixarray-16 ()
1205    '(#+cmu simple-array #-cmu array pixarray-16-element-type (* *)))    '(simple-array pixarray-16-element-type (* *)))
1206    
1207  (deftype pixarray-24 ()  (deftype pixarray-24 ()
1208    '(#+cmu simple-array #-cmu array pixarray-24-element-type (* *)))    '(simple-array pixarray-24-element-type (* *)))
1209    
1210  (deftype pixarray-32 ()  (deftype pixarray-32 ()
1211    '(#+cmu simple-array #-cmu array pixarray-32-element-type (* *)))    '(simple-array pixarray-32-element-type (* *)))
1212    
1213  (deftype pixarray ()  (deftype pixarray ()
1214    '(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 2779  Line 1218 
1218    
1219  ;;; WITH-UNDERLYING-SIMPLE-VECTOR  ;;; WITH-UNDERLYING-SIMPLE-VECTOR
1220    
 #+Genera  
 (defmacro with-underlying-simple-vector  
           ((variable element-type pixarray) &body body)  
   (let ((bits-per-element  
           (sys:array-bits-per-element  
             (symbol-value (sys:type-array-element-type element-type)))))  
     `(scl:stack-let ((,variable  
                       (make-array  
                         (index-ceiling  
                           (index* (array-total-size ,pixarray)  
                                   (sys:array-element-size ,pixarray))  
                           ,bits-per-element)  
                         :element-type ',element-type  
                         :displaced-to ,pixarray)))  
        (declare (type (vector ,element-type) ,variable))  
        ,@body)))  
   
 #+lcl3.0  
 (defmacro with-underlying-simple-vector  
           ((variable element-type pixarray) &body body)  
   `(let ((,variable (sys:underlying-simple-vector ,pixarray)))  
      (declare (type (simple-array ,element-type (*)) ,variable))  
      ,@body))  
   
 #+excl  
 (defmacro with-underlying-simple-vector  
           ((variable element-type pixarray) &body body)  
   `(let ((,variable (cdr (excl::ah_data ,pixarray))))  
      (declare (type (simple-array ,element-type (*)) ,variable))  
      ,@body))  
   
1221  #+CMU  #+CMU
1222  ;;; We do *NOT* support viewing an array as having a different element type.  ;;; We do *NOT* support viewing an array as having a different element type.
1223  ;;; Element-type is ignored.  ;;; Element-type is ignored.
# Line 2830  Line 1238 
1238  (defmacro read-image-load-byte (size position integer)  (defmacro read-image-load-byte (size position integer)
1239    (unless *image-bit-lsb-first-p* (setq position (- 7 position)))    (unless *image-bit-lsb-first-p* (setq position (- 7 position)))
1240    `(the (unsigned-byte ,size)    `(the (unsigned-byte ,size)
1241          (#-Genera ldb #+Genera sys:%logldb          (ldb (byte ,size ,position)(the card8 ,integer))))
          (byte ,size ,position)  
          (the card8 ,integer))))  
1242    
1243  ;;; 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
1244  ;;; the appropriate number of CARD8s.  ;;; the appropriate number of CARD8s.
# Line 2843  Line 1249 
1249          (count 0))          (count 0))
1250      (dolist (byte (rest bytes))      (dolist (byte (rest bytes))
1251        (setq it        (setq it
1252              `(#-Genera dpb #+Genera sys:%logdpb              `(dpb
1253                (the card8 ,byte)                (the card8 ,byte)
1254                (byte 8 ,(incf count 8))                (byte 8 ,(incf count 8))
1255                (the (unsigned-byte ,count) ,it))))                (the (unsigned-byte ,count) ,it))))
1256      #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it)      `(the (unsigned-byte ,(* (length bytes) 8)) ,it)))
1257      #+Genera it))  
1258    
1259  ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit  ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
1260  ;;; pixel.  ;;; pixel.
# Line 2857  Line 1263 
1263    integer-size    integer-size
1264    (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position)))    (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position)))
1265    `(the card8    `(the card8
1266          (#-Genera ldb #+Genera sys:%logldb          (ldb
1267           (byte 8 ,position)           (byte 8 ,position)
1268           #-Genera (the (unsigned-byte ,integer-size) ,integer)           (the (unsigned-byte ,integer-size) ,integer))))
          #+Genera ,integer  
          )))  
1269    
1270  ;;; 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
1271  ;;; pixels.  ;;; pixels.
# Line 2872  Line 1276 
1276          (it (first bytes))          (it (first bytes))
1277          (count 0))          (count 0))
1278      (dolist (byte (rest bytes))      (dolist (byte (rest bytes))
1279        (setq it `(#-Genera dpb #+Genera sys:%logdpb        (setq it `(dpb
1280                   (the (unsigned-byte ,size) ,byte)                   (the (unsigned-byte ,size) ,byte)
1281                   (byte ,size ,(incf count size))                   (byte ,size ,(incf count size))
1282                   (the (unsigned-byte ,count) ,it))))                   (the (unsigned-byte ,count) ,it))))
1283      `(the card8 ,it)))      `(the card8 ,it)))
1284    
 #+(or Genera lcl3.0 excl)  
 (defvar *computed-image-byte-lsb-first-p* *image-byte-lsb-first-p*)  
   
 #+(or Genera lcl3.0 excl)  
 (defvar *computed-image-bit-lsb-first-p* *image-bit-lsb-first-p*)  
   
1285  ;;; The following table gives the bit ordering within bytes (when accessed  ;;; The following table gives the bit ordering within bytes (when accessed
1286  ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to  ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
1287  ;;; 31, where bit 0 should be leftmost on the display.  For a given byte  ;;; 31, where bit 0 should be leftmost on the display.  For a given byte
# Line 2915  Line 1313 
1313  ;;; 2Ll 07-00 15-08 23-16 31-24  ;;; 2Ll 07-00 15-08 23-16 31-24
1314  ;;; 4Ll 07-00 15-08 23-16 31-24  ;;; 4Ll 07-00 15-08 23-16 31-24
1315    
 #+(or Genera lcl3.0 excl)  
 (defconstant  
   *image-bit-ordering-table*  
   '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil))  
     ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil))  
     ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil))  
     ((1 (07 00) (15 08) (23 16) (31 24)) (nil t))  
     ((2 (15 08) (07 00) (31 24) (23 16)) (nil t))  
     ((4 (31 24) (23 16) (15 08) (07 00)) (nil t))  
     ((1 (00 07) (08 15) (16 23) (24 31)) (t   nil))  
     ((2 (08 15) (00 07) (24 31) (16 23)) (t   nil))  
     ((4 (24 31) (16 23) (08 15) (00 07)) (t   nil))  
     ((1 (07 00) (15 08) (23 16) (31 24)) (t   t))  
     ((2 (07 00) (15 08) (23 16) (31 24)) (t   t))  
     ((4 (07 00) (15 08) (23 16) (31 24)) (t   t))))  
   
 #+(or Genera lcl3.0 excl)  
 (defun compute-image-byte-and-bit-ordering ()  
   (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p))  
   ;; First compute the ordering  
   (let ((ordering nil)  
         (a (make-array '(1 32) :element-type 'bit :initial-element 0)))  
     (dotimes (i 4)  
       (push (flet ((bitpos (a i n)  
                      (declare (optimize (speed 3) (safety 0) (space 0)))  
                      (declare (type (simple-array bit (* *)) a)  
                               (type fixnum i n))  
                      (with-underlying-simple-vector (v (unsigned-byte 8) a)  
                        (prog2  
                          (setf (aref v i) n)  
                          (dotimes (i 32)  
                            (unless (zerop (aref a 0 i))  
                              (return i)))  
                          (setf (aref v i) 0)))))  
               (list (bitpos a i #b10000000)  
                     (bitpos a i #b00000001)))  
             ordering))  
     (setq ordering (cons (floor *image-unit* 8) (nreverse ordering)))  
     ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p  
     (let ((byte-and-bit-ordering  
             (second (assoc ordering *image-bit-ordering-table*  
                            :test #'equal))))  
       (unless byte-and-bit-ordering  
         (error "Couldn't determine image byte and bit ordering~@  
                 measured image ordering = ~A"  
                ordering))  
       (values-list byte-and-bit-ordering))))  
   
 #+(or Genera lcl3.0 excl)  
 (multiple-value-setq  
   (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)  
   (compute-image-byte-and-bit-ordering))  
1316    
1317  ;;; 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
1318  ;;; 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
# Line 2975  Line 1321 
1321    
1322  ;;; 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
1323    
1324  #+(or lcl3.0 excl)  #+(or CMU)
 (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height  
                              padded-bytes-per-line bits-per-pixel)  
   (declare (type buffer-bytes buffer-bbuf)  
            (type pixarray-1 array)  
            (type card16 x y width height)  
            (type array-index index padded-bytes-per-line)  
            (type (member 1 4 8 16 24 32) bits-per-pixel)  
            (ignore bits-per-pixel))  
   #.(declare-buffun)  
   (with-vector (buffer-bbuf buffer-bytes)  
     (with-underlying-simple-vector (vector pixarray-1-element-type array)  
       (do* ((start (index+ index  
                            (index* y padded-bytes-per-line)  
                            (index-ceiling x 8))  
                    (index+ start padded-bytes-per-line))  
             (y 0 (index1+ y))  
             (left-bits (the array-index (mod (the fixnum (- x)) 8)))  
             (right-bits (index-mod (index- width left-bits) 8))  
             (middle-bits (the fixnum (- (the fixnum (- width left-bits))  
                                         right-bits)))  
             (middle-bytes (index-floor middle-bits 8)))  
            ((index>= y height))  
         (declare (type array-index start y  
                        left-bits right-bits middle-bytes)  
                  (fixnum middle-bits))  
         (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)  
                  (let ((byte (aref buffer-bbuf (index1- start)))  
                        (x (array-row-major-index array y left-bits)))  
                    (declare (type card8 byte)  
                             (type array-index x))  
                    (setf (aref vector (index- x 1))  
                          (read-image-load-byte 1 7 byte))  
                    (when (index> left-bits 1)  
                      (setf (aref vector (index- x 2))  
                            (read-image-load-byte 1 6 byte))  
                      (when (index> left-bits 2)  
                        (setf (aref vector (index- x 3))  
                              (read-image-load-byte 1 5 byte))  
                        (when (index> left-bits 3)  
                          (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)  
   
 #+(or lcl3.0 excl)  
 (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height  
                              padded-bytes-per-line bits-per-pixel)  
   (declare (type buffer-bytes buffer-bbuf)  
            (type pixarray-4 array)  
            (type card16 x y width height)  
            (type array-index index padded-bytes-per-line)  
            (type (member 1 4 8 16 24 32) bits-per-pixel)  
            (ignore bits-per-pixel))  
   #.(declare-buffun)  
   (with-vector (buffer-bbuf buffer-bytes)  
     (with-underlying-simple-vector (vector pixarray-4-element-type array)  
       (do* ((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 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 Genera lcl3.0 excl CMU)  
1325  (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
1326                                padded-bytes-per-line bits-per-pixel)                                padded-bytes-per-line bits-per-pixel)
1327    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
# Line 3189  Line 1352 
1352                    (aref buffer-bbuf (index+ i 2))))))))                    (aref buffer-bbuf (index+ i 2))))))))
1353    t)    t)
1354    
 #+lispm  
 (defun fast-read-pixarray-using-bitblt  
        (bbuf boffset pixarray x y width height padded-bytes-per-line  
         bits-per-pixel)  
   (#+Genera sys:stack-let* #-Genera let*  
    ((dimensions (list (+ y height)  
                       (floor (* padded-bytes-per-line 8) bits-per-pixel)))  
     (a (make-array  
          dimensions  
          :element-type (array-element-type pixarray)  
          :displaced-to bbuf  
          :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))  
    (sys:bitblt boole-1 width height a x y pixarray 0 0))  
   t)  
   
1355  #+CMU  #+CMU
1356  (defun pixarray-element-size (pixarray)  (defun pixarray-element-size (pixarray)
1357    (let ((eltype (array-element-type pixarray)))    (let ((eltype (array-element-type pixarray)))
# Line 3261  Line 1409 
1409                   (index* width bits-per-pixel))                   (index* width bits-per-pixel))
1410    t)    t)
1411    
 #+(or Genera lcl3.0 excl)  
 (defun fast-read-pixarray-with-swap  
        (bbuf boffset pixarray x y width height padded-bytes-per-line  
         bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)  
   (declare (type buffer-bytes bbuf)  
            (type array-index boffset  
                  padded-bytes-per-line)  
            (type pixarray pixarray)  
            (type card16 x y width height)  
            (type (member 1 4 8 16 24 32) bits-per-pixel)  
            (type (member 8 16 32) unit)  
            (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))  
   (unless (index= bits-per-pixel 24)  
     (let ((pixarray-padded-bits-per-line  
             (if (index= height 1) 0  
               (index* (index- (array-row-major-index pixarray 1 0)  
                               (array-row-major-index pixarray 0 0))  
                       bits-per-pixel)))  
           (x-bits (index* x bits-per-pixel)))  
       (declare (type array-index pixarray-padded-bits-per-line x-bits))  
       (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)  
                 (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))  
                      (index-zerop (index-mod x-bits 8)))  
               (and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*))  
                    (index-zerop (index-mod x-bits *image-unit*))))  
         (multiple-value-bind (image-swap-function image-swap-lsb-first-p)  
             (image-swap-function  
               bits-per-pixel  
               unit byte-lsb-first-p bit-lsb-first-p  
               *image-unit* *computed-image-byte-lsb-first-p*  
               *computed-image-bit-lsb-first-p*)  
           (declare (type symbol image-swap-function)  
                    (type generalized-boolean image-swap-lsb-first-p))  
           (with-underlying-simple-vector (dst card8 pixarray)  
             (funcall  
               (symbol-function image-swap-function) bbuf dst  
               (index+ boffset  
                       (index* y padded-bytes-per-line)  
                       (index-floor x-bits 8))  
               0 (index-ceiling (index* width bits-per-pixel) 8)  
               padded-bytes-per-line  
               (index-floor pixarray-padded-bits-per-line 8)  
               height image-swap-lsb-first-p)))  
         t))))  
   
1412  (defun fast-read-pixarray (bbuf boffset pixarray  (defun fast-read-pixarray (bbuf boffset pixarray
1413                             x y width height padded-bytes-per-line                             x y width height padded-bytes-per-line
1414                             bits-per-pixel                             bits-per-pixel
# Line 3321  Line 1424 
1424    (progn bbuf boffset pixarray x y width height padded-bytes-per-line    (progn bbuf boffset pixarray x y width height padded-bytes-per-line
1425           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1426    (or    (or
     #+(or Genera lcl3.0 excl)  
     (fast-read-pixarray-with-swap  
       bbuf boffset pixarray x y width height padded-bytes-per-line  
       bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)  
1427      (let ((function      (let ((function
1428              (or #+lispm              (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
                 (and (= (sys:array-element-size pixarray) bits-per-pixel)  
                      (zerop (index-mod padded-bytes-per-line 4))  
                      (zerop (index-mod  
                               (* #+Genera (sys:array-row-span pixarray)  
                                  #-Genera (array-dimension pixarray 1)  
                                  bits-per-pixel)  
                               32))  
1429                       #'fast-read-pixarray-using-bitblt)                       #'fast-read-pixarray-using-bitblt)
                 #+CMU  
                 (and (index= (pixarray-element-size pixarray) bits-per-pixel)  
                      #'fast-read-pixarray-using-bitblt)  
                 #+(or lcl3.0 excl)  
                 (and (index= bits-per-pixel 1)  
                      #'fast-read-pixarray-1)  
                 #+(or lcl3.0 excl)  
                 (and (index= bits-per-pixel 4)  
                      #'fast-read-pixarray-4)  
                 #+(or Genera lcl3.0 excl CMU)  
1430                  (and (index= bits-per-pixel 24)                  (and (index= bits-per-pixel 24)
1431                       #'fast-read-pixarray-24))))                       #'fast-read-pixarray-24))))
1432        (when function        (when function
# Line 3356  Line 1438 
1438    
1439  ;;; 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
1440    
1441  #+(or lcl3.0 excl)  #+(or CMU)
 (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height  
                               padded-bytes-per-line bits-per-pixel)  
   (declare (type buffer-bytes buffer-bbuf)  
            (type pixarray-1 array)  
            (type card16 x y width height)  
            (type array-index index padded-bytes-per-line)  
            (type (member 1 4 8 16 24 32) bits-per-pixel)  
            (ignore bits-per-pixel))  
   #.(declare-buffun)  
   (with-vector (buffer-bbuf buffer-bytes)  
     (with-underlying-simple-vector (vector pixarray-1-element-type array)  
       (do* ((h 0 (index1+ h))  
             (y y (index1+ y))  
             (right-bits (index-mod width 8))  
             (middle-bits (index- width right-bits))  
             (middle-bytes (index-ceiling middle-bits 8))  
             (start index (index+ start padded-bytes-per-line)))  
            ((index>= h height))  
         (declare (type array-index h y right-bits middle-bits  
                        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 8)))  
              ((index>= i end)  
               (unless (index-zerop right-bits)  
                 (let ((x (array-row-major-index  
                            array y (index+ start-x middle-bits))))  
                   (declare (type array-index x))  
                   (setf (aref buffer-bbuf end)  
                         (write-image-assemble-bytes  
                           (aref vector (index+ x 0))  
                           (if (index> right-bits 1)  
                               (aref vector (index+ x 1))  
                             0)  
                           (if (index> right-bits 2)  
                               (aref vector (index+ x 2))  
                             0)  
                           (if (index> right-bits 3)  
                               (aref vector (index+ x 3))  
                             0)  
                           (if (index> right-bits 4)  
                               (aref vector (index+ x 4))  
                             0)  
                           (if (index> right-bits 5)  
                               (aref vector (index+ x 5))  
                             0)  
                           (if (index> right-bits 6)  
                               (aref vector (index+ x 6))  
                             0)  
                           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))  
                   (aref vector (index+ x 2))  
                   (aref vector (index+ x 3))  
                   (aref vector (index+ x 4))  
                   (aref vector (index+ x 5))  
                   (aref vector (index+ x 6))  
                   (aref vector (index+ x 7))))))))  
   t)  
   
 #+(or lcl3.0 excl)  
 (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height  
                               padded-bytes-per-line bits-per-pixel)  
   (declare (type buffer-bytes buffer-bbuf)  
            (type pixarray-4 array)  
            (type int16 x y)  
            (type card16 width height)  
            (type array-index index padded-bytes-per-line)  
            (type (member 1 4 8 16 24 32) bits-per-pixel)  
            (ignore bits-per-pixel))  
   #.(declare-buffun)  
   (with-vector (buffer-bbuf buffer-bytes)  
     (with-underlying-simple-vector (vector pixarray-4-element-type array)  
       (do* ((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 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 Genera lcl3.0 excl CMU)  
1442  (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
1443                                 padded-bytes-per-line bits-per-pixel)                                 padded-bytes-per-line bits-per-pixel)
1444    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
# Line 3493  Line 1471 
1471                    (write-image-load-byte 16 pixel 24)))))))                    (write-image-load-byte 16 pixel 24)))))))
1472    t)    t)
1473    
 #+lispm  
 (defun fast-write-pixarray-using-bitblt  
        (bbuf boffset pixarray x y width height padded-bytes-per-line  
         bits-per-pixel)  
   (#+Genera sys:stack-let* #-Genera let*  
    ((dimensions (list (+ y height)  
                       (floor (* padded-bytes-per-line 8) bits-per-pixel)))  
     (a (make-array  
          dimensions  
          :element-type (array-element-type pixarray)  
          :displaced-to bbuf  
          :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))  
    (sys:bitblt boole-1 width height pixarray x y a 0 0))  
   t)  
   
1474  #+CMU  #+CMU
1475  (defun fast-write-pixarray-using-bitblt  (defun fast-write-pixarray-using-bitblt
1476         (bbuf boffset pixarray x y width height padded-bytes-per-line         (bbuf boffset pixarray x y width height padded-bytes-per-line
# Line 3523  Line 1486 
1486                   (index* width bits-per-pixel))                   (index* width bits-per-pixel))
1487    t)    t)
1488    
 #+(or Genera lcl3.0 excl)  
 (defun fast-write-pixarray-with-swap  
        (bbuf boffset pixarray x y width height padded-bytes-per-line  
         bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)  
   (declare (type buffer-bytes bbuf)  
            (type pixarray pixarray)  
            (type card16 x y width height)  
            (type array-index boffset padded-bytes-per-line)  
            (type (member 1 4 8 16 24 32) bits-per-pixel)  
            (type (member 8 16 32) unit)  
            (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))  
   (unless (index= bits-per-pixel 24)  
     (let ((pixarray-padded-bits-per-line  
             (if (index= height 1) 0  
               (index* (index- (array-row-major-index pixarray 1 0)  
                               (array-row-major-index pixarray 0 0))  
                       bits-per-pixel)))  
           (pixarray-start-bit-offset  
             (index* (array-row-major-index pixarray y x)  
                     bits-per-pixel)))  
       (declare (type array-index pixarray-padded-bits-per-line  
                      pixarray-start-bit-offset))  
       (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)  
                 (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))  
                      (index-zerop (index-mod pixarray-start-bit-offset 8)))  
               (and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*))  
                    (index-zerop (index-mod pixarray-start-bit-offset *image-unit*))))  
         (multiple-value-bind (image-swap-function image-swap-lsb-first-p)  
             (image-swap-function  
               bits-per-pixel  
               *image-unit* *computed-image-byte-lsb-first-p*  
               *computed-image-bit-lsb-first-p*  
               unit byte-lsb-first-p bit-lsb-first-p)  
           (declare (type symbol image-swap-function)  
                    (type generalized-boolean image-swap-lsb-first-p))  
           (with-underlying-simple-vector (src card8 pixarray)  
             (funcall  
               (symbol-function image-swap-function)  
               src bbuf (index-floor pixarray-start-bit-offset 8) boffset  
               (index-ceiling (index* width bits-per-pixel) 8)  
               (index-floor pixarray-padded-bits-per-line 8)  
               padded-bytes-per-line height image-swap-lsb-first-p))  
           t)))))  
   
1489  (defun fast-write-pixarray (bbuf boffset pixarray x y width height  (defun fast-write-pixarray (bbuf boffset pixarray x y width height
1490                              padded-bytes-per-line bits-per-pixel                              padded-bytes-per-line bits-per-pixel
1491                              unit byte-lsb-first-p bit-lsb-first-p)                              unit byte-lsb-first-p bit-lsb-first-p)
# Line 3580  Line 1499 
1499    (progn bbuf boffset pixarray x y width height padded-bytes-per-line    (progn bbuf boffset pixarray x y width height padded-bytes-per-line
1500           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)           bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
1501    (or    (or
     #+(or Genera lcl3.0 excl)  
     (fast-write-pixarray-with-swap  
       bbuf boffset pixarray x y width height padded-bytes-per-line  
       bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)  
1502      (let ((function      (let ((function
1503              (or #+lispm              (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
                 (and (= (sys:array-element-size pixarray) bits-per-pixel)  
                      (zerop (index-mod padded-bytes-per-line 4))  
                      (zerop (index-mod  
                               (* #+Genera (sys:array-row-span pixarray)  
                                  #-Genera (array-dimension pixarray 1)  
                                  bits-per-pixel)  
                               32))  
1504                       #'fast-write-pixarray-using-bitblt)                       #'fast-write-pixarray-using-bitblt)
                 #+CMU  
                 (and (index= (pixarray-element-size pixarray) bits-per-pixel)  
                      #'fast-write-pixarray-using-bitblt)  
                 #+(or lcl3.0 excl)  
                 (and (index= bits-per-pixel 1)  
                      #'fast-write-pixarray-1)  
                 #+(or lcl3.0 excl)  
                 (and (index= bits-per-pixel 4)  
                      #'fast-write-pixarray-4)  
                 #+(or Genera lcl3.0 excl CMU)  
1505                  (and (index= bits-per-pixel 24)                  (and (index= bits-per-pixel 24)
1506                       #'fast-write-pixarray-24))))                       #'fast-write-pixarray-24))))
1507        (when function        (when function
# Line 3620  Line 1518 
1518             (type card16 x y width height)             (type card16 x y width height)
1519             (type (member 1 4 8 16 24 32) bits-per-pixel))             (type (member 1 4 8 16 24 32) bits-per-pixel))
1520    (progn pixarray copy x y width height bits-per-pixel nil)    (progn pixarray copy x y width height bits-per-pixel nil)
1521    (or    (let* ((pixarray-padded-pixels-per-line
1522      #+(or lispm CMU)            (array-dimension pixarray 1))
1523      (let* ((pixarray-padded-pixels-per-line           (pixarray-padded-bits-per-line
1524               #+Genera (sys:array-row-span pixarray)            (* pixarray-padded-pixels-per-line bits-per-pixel))
1525               #-Genera (array-dimension pixarray 1))           (copy-padded-pixels-per-line
1526             (pixarray-padded-bits-per-line            (array-dimension copy 1))
1527               (* pixarray-padded-pixels-per-line bits-per-pixel))           (copy-padded-bits-per-line
1528             (copy-padded-pixels-per-line            (* copy-padded-pixels-per-line bits-per-pixel)))
1529               #+Genera (sys:array-row-span copy)      (when (index= (pixarray-element-size pixarray)
1530               #-Genera (array-dimension copy 1))                    (pixarray-element-size copy)
1531             (copy-padded-bits-per-line                    bits-per-pixel)
1532               (* copy-padded-pixels-per-line bits-per-pixel)))        (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
1533        #-CMU                       copy copy-padded-bits-per-line 0 0
1534        (when (and (= (sys:array-element-size pixarray) bits-per-pixel)                       height
1535                   (zerop (index-mod pixarray-padded-bits-per-line 32))                       (index* width bits-per-pixel))
                  (zerop (index-mod copy-padded-bits-per-line 32)))  
         (sys:bitblt boole-1 width height pixarray x y copy 0 0)  
         t)  
       #+CMU  
       (when (index= (pixarray-element-size pixarray)  
                     (pixarray-element-size copy)  
                     bits-per-pixel)  
         (copy-bit-rect pixarray pixarray-padded-bits-per-line x y  
                        copy copy-padded-bits-per-line 0 0  
                        height  
                        (index* width bits-per-pixel))  
         t))  
   
     #+(or lcl3.0 excl)  
     (unless (index= bits-per-pixel 24)  
       (let ((pixarray-padded-bits-per-line  
               (if (index= height 1) 0  
                 (index* (index- (array-row-major-index pixarray 1 0)  
                                 (array-row-major-index pixarray 0 0))  
                         bits-per-pixel)))  
             (copy-padded-bits-per-line  
               (if (index= height 1) 0  
                 (index* (index- (array-row-major-index copy 1 0)  
                                 (array-row-major-index copy 0 0))  
                         bits-per-pixel)))  
             (pixarray-start-bit-offset  
               (index* (array-row-major-index pixarray y x)  
                       bits-per-pixel)))  
         (declare (type array-index pixarray-padded-bits-per-line  
                        copy-padded-bits-per-line pixarray-start-bit-offset))  
         (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)  
                   (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))  
                        (index-zerop (index-mod copy-padded-bits-per-line 8))  
                        (index-zerop (index-mod pixarray-start-bit-offset 8)))  
                 (and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*))  
                      (index-zerop (index-mod copy-padded-bits-per-line *image-unit*))  
                      (index-zerop (index-mod pixarray-start-bit-offset *image-unit*))))  
           (with-underlying-simple-vector (src card8 pixarray)  
             (with-underlying-simple-vector (dst card8 copy)  
               (image-noswap  
                 src dst  
                 (index-floor pixarray-start-bit-offset 8) 0  
                 (index-ceiling (index* width bits-per-pixel) 8)  
                 (index-floor pixarray-padded-bits-per-line 8)  
                 (index-floor copy-padded-bits-per-line 8)  
                 height nil)))  
           t)))  
     #+(or lcl3.0 excl)  
     (macrolet  
       ((copy (type element-type)  
          `(let ((pixarray pixarray)  
                 (copy copy))  
             (declare (type ,type pixarray copy))  
             #.(declare-buffun)  
             (with-underlying-simple-vector (src ,element-type pixarray)  
               (with-underlying-simple-vector (dst ,element-type copy)  
                 (do* ((dst-y 0 (index1+ dst-y))  
                       (src-y y (index1+ src-y)))  
                      ((index>= dst-y height))  
                   (declare (type card16 dst-y src-y))  
                   (do* ((dst-idx (array-row-major-index copy dst-y 0)  
                                  (index1+ dst-idx))  
                         (dst-end (index+ dst-idx width))  
                         (src-idx (array-row-major-index pixarray src-y x)  
                                  (index1+ src-idx)))  
                        ((index>= dst-idx dst-end))  
                     (declare (type array-index dst-idx src-idx dst-end))  
                     (setf (aref dst dst-idx)  
                           (the ,element-type (aref src src-idx))))))))))  
       (ecase bits-per-pixel  
         (1  (copy pixarray-1  pixarray-1-element-type))  
         (4  (copy pixarray-4  pixarray-4-element-type))  
         (8  (copy pixarray-8  pixarray-8-element-type))  
         (16 (copy pixarray-16 pixarray-16-element-type))  
         (24 (copy pixarray-24 pixarray-24-element-type))  
         (32 (copy pixarray-32 pixarray-32-element-type)))  
1536        t)))        t)))

Legend:
Removed from v.1.5.2.2  
changed lines
  Added in v.1.5.2.3

  ViewVC Help
Powered by ViewVC 1.1.5