/[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.4 by ram, Fri Sep 30 16:04:44 1994 UTC revision 1.5 by ram, Sat Jan 18 14:30:31 1997 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-  ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
2    
3  ;; This file contains some of the system dependent code for CLX  ;; This file contains some of the system dependent code for CLX
4    
# Line 20  Line 20 
20    
21  (in-package :xlib)  (in-package :xlib)
22    
23    (proclaim '(declaration array-register))
24    
25    #+cmu
26    (setf (getf ext:*herald-items* :xlib)
27          `("    CLX X Library " ,*version*))
28    
29  ;;; The size of the output buffer.  Must be a multiple of 4.  ;;; The size of the output buffer.  Must be a multiple of 4.
30  (defparameter *output-buffer-size* 8192)  (defparameter *output-buffer-size* 8192)
31    
# Line 67  Line 73 
73  ;;; declaration is available, it would be a good idea to make it here when  ;;; declaration is available, it would be a good idea to make it here when
74  ;;; *buffer-speed* is 3 and *buffer-safety* is 0.  ;;; *buffer-speed* is 3 and *buffer-safety* is 0.
75  (defun declare-buffun ()  (defun declare-buffun ()
76      #+(and cmu clx-debugging)
77      '(declare (optimize (speed 1) (safety 1)))
78      #-(and cmu clx-debugging)
79    `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))    `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
80    
81  )  )
# Line 677  Line 686 
686    #.(declare-buffun)    #.(declare-buffun)
687    (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))))
688    
689    
690    #+cmu (progn
691    
692    ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
693    ;;; is irrational, there can't be a precise rational representation.  In
694    ;;; particular, the different float approximations will always be /=.  This
695    ;;; causes problems with type checking, because people might compute an
696    ;;; argument in any precision.  What we do is discard all the excess precision
697    ;;; in the value, and see if the protocal encoding falls in the desired range
698    ;;; (64'ths of a degree.)
699    ;;;
700    (deftype angle () '(satisfies anglep))
701    
702    (defun anglep (x)
703      (and (typep x 'real)
704           (<= (* -360 64) (radians->int16 x) (* 360 64))))
705    
706    )
707    
708    
709  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
710  ;; Character transformation  ;; Character transformation
# Line 873  Line 901 
901  ;;; against re-entering request functions.  This can happen if an interrupt  ;;; against re-entering request functions.  This can happen if an interrupt
902  ;;; occurs and the handler attempts to use X over the same display connection.  ;;; occurs and the handler attempts to use X over the same display connection.
903  ;;; This can happen if the GC hooks are used to notify the user over the same  ;;; This can happen if the GC hooks are used to notify the user over the same
904  ;;; display connection.  We lock out GC's just as a dummy check for our users.  ;;; display connection.  We inhibit GC notifications since display of them
905  ;;; Locking out interrupts has the problem that CLX always waits for replies  ;;; could cause recursive entry into CLX.
 ;;; within this dynamic scope, so if the server cannot reply for some reason,  
 ;;; we potentially dead-lock without interrupts.  
906  ;;;  ;;;
907  #+CMU  #+CMU
908  (defmacro holding-lock ((locator display &optional whostate &key timeout)  (defmacro holding-lock ((locator display &optional whostate &key timeout)
909                          &body body)                          &body body)
910    (declare (ignore locator display whostate timeout))    `(let ((ext:*gc-verbose* nil)
911    `(lisp::without-gcing (system:without-interrupts (progn ,@body))))           (ext:*gc-inhibit-hook* nil)
912             (ext:*before-gc-hooks* nil)
913             (ext:*after-gc-hooks* nil))
914         ,locator ,display ,whostate ,timeout
915         (system:without-interrupts (progn ,@body))))
916    
917  #+Genera  #+Genera
918  (defmacro holding-lock ((locator display &optional whostate &key timeout)  (defmacro holding-lock ((locator display &optional whostate &key timeout)
# Line 1335  Line 1365 
1365  ;;; 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
1366  ;;; display object instead of a stream.  ;;; display object instead of a stream.
1367  ;;;  ;;;
1368  #+CMU  #+cmu
1369    (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
1370                             c-call:int
1371      (host c-call:c-string)
1372      (port c-call:int))
1373    #+cmu
1374  (defun open-x-stream (host display protocol)  (defun open-x-stream (host display protocol)
1375    (declare (ignore protocol))    (declare (ignore protocol))
1376    (let ((server-fd (connect-to-server host display)))    (let ((server-fd (connect-to-server host display)))
# Line 1344  Line 1379 
1379      (system:make-fd-stream server-fd :input t :output t      (system:make-fd-stream server-fd :input t :output t
1380                             :element-type '(unsigned-byte 8))))                             :element-type '(unsigned-byte 8))))
1381    
 ;;; This loads the C foreign function used to make an IPC connection  
 ;;; to the X11 server.  It also defines the necessary types and things  
 ;;; to actually make the foreign call.  See the OPEN-X-STREAM function  
 ;;; in the dependent.lisp file.  
 ;;;  
 #+CMU  
 (ext:def-c-routine ("connect_to_server" connect-to-server) (ext:int)  
   (host system:null-terminated-string)  
   (port ext:int))  
1382    
1383  ;;; BUFFER-READ-DEFAULT - read data from the X stream  ;;; BUFFER-READ-DEFAULT - read data from the X stream
1384    
# Line 1454  Line 1480 
1480    (declare (type display display)    (declare (type display display)
1481             (type buffer-bytes vector)             (type buffer-bytes vector)
1482             (type array-index start end)             (type array-index start end)
1483             (type (or null (real 0 *)) timeout))             (type (or null fixnum) timeout))
1484    #.(declare-buffun)    #.(declare-buffun)
1485    (cond ((and (and timeout (= timeout 0))    (cond ((and (eql timeout 0)
1486                (not (listen (display-input-stream display))))                (not (listen (display-input-stream display))))
1487           :timeout)           :timeout)
1488          (t          (t
# Line 1464  Line 1490 
1490                                vector start (- end start))                                vector start (- end start))
1491           nil)))           nil)))
1492    
1493    
1494  ;;; WARNING:  ;;; WARNING:
1495  ;;;     CLX performance will suffer if your lisp uses read-byte for  ;;;     CLX performance will suffer if your lisp uses read-byte for
1496  ;;;     receiving all data from the X Window System server.  ;;;     receiving all data from the X Window System server.
# Line 1573  Line 1600 
1600            (declare (type array-index index))            (declare (type array-index index))
1601            (write-byte (aref vector index) stream))))))            (write-byte (aref vector index) stream))))))
1602    
1603    #+CMU
1604    (defun buffer-write-default (vector display start end)
1605      (declare (type buffer-bytes vector)
1606               (type display display)
1607               (type array-index start end))
1608      #.(declare-buffun)
1609      (system:output-raw-bytes (display-output-stream display) vector start end)
1610      nil)
1611    
1612  ;;; buffer-force-output-default - force output to the X stream  ;;; buffer-force-output-default - force output to the X stream
1613    
1614  #+excl  #+excl
# Line 1580  Line 1616 
1616    ;; buffer-write-default does the actual writing.    ;; buffer-write-default does the actual writing.
1617    (declare (ignore display)))    (declare (ignore display)))
1618    
1619  #-excl  #-(or excl)
1620  (defun buffer-force-output-default (display)  (defun buffer-force-output-default (display)
1621    ;; The default buffer force-output function for use with common-lisp streams    ;; The default buffer force-output function for use with common-lisp streams
1622    (declare (type display display))    (declare (type display display))
# Line 1599  Line 1635 
1635    #.(declare-buffun)    #.(declare-buffun)
1636    (excl::filesys-checking-close (display-output-stream display)))    (excl::filesys-checking-close (display-output-stream display)))
1637    
1638  #-excl  #-(or excl)
1639  (defun buffer-close-default (display &key abort)  (defun buffer-close-default (display &key abort)
1640    ;; The default buffer close function for use with common-lisp streams    ;; The default buffer close function for use with common-lisp streams
1641    (declare (type display display))    (declare (type display display))
# Line 1647  Line 1683 
1683  #+CMU  #+CMU
1684  (defun buffer-input-wait-default (display timeout)  (defun buffer-input-wait-default (display timeout)
1685    (declare (type display display)    (declare (type display display)
1686             (type (or null (real 0 *)) timeout))             (type (or null number) timeout))
1687    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
1688      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
1689      (cond ((null stream))      (cond ((null stream))
1690            ((listen stream) nil)            ((listen stream) nil)
1691            ((and timeout (= timeout 0)) :timeout)            ((eql timeout 0) :timeout)
1692            (t            (t
1693             (if (system:wait-until-fd-usable (system:fd-stream-fd stream)             (if (system:wait-until-fd-usable (system:fd-stream-fd stream)
1694                                              :input timeout)                                              :input timeout)
# Line 1782  Line 1818 
1818  ;;; 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.
1819    
1820  ;;; The default implementation is to just use listen.  ;;; The default implementation is to just use listen.
1821  #-excl  #-(or excl)
1822  (defun buffer-listen-default (display)  (defun buffer-listen-default (display)
1823    (declare (type display display))    (declare (type display display))
1824    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
# Line 2114  Line 2150 
2150  #+CMU  #+CMU
2151  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2152    (let ((condx (apply #'make-condition condition keyargs)))    (let ((condx (apply #'make-condition condition keyargs)))
2153      (typecase condx      (when (eq condition 'closed-display)
2154        ;; This condition no longer exists.        (let ((disp (closed-display-display condx)))
2155        #||          (warn "Disabled event handling on ~S." disp)
2156        (server-disconnect          (ext::disable-clx-event-handling disp)))
         (let ((disp (server-disconnect-display condx)))  
           (warn "Disabled event handling on ~S." disp)  
           (ext::disable-clx-event-handling disp)))  
       ||#  
       (closed-display  
         (let ((disp (closed-display-display condx)))  
           (warn "Disabled event handling on ~S." disp)  
           (ext::disable-clx-event-handling disp))))  
2157      (error condx)))      (error condx)))
2158    
2159  #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)  #-(or lispm ansi-common-lisp excl lcl3.0 CMU)
2160  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2161    (error "X-Error: ~a"    (error "X-Error: ~a"
2162           (princ-to-string (apply #'make-condition condition keyargs))))           (princ-to-string (apply #'make-condition condition keyargs))))
# Line 2589  Line 2617 
2617  ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)  ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)
2618  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2619    
2620  #-(or clx-ansi-common-lisp Genera)  #-(or clx-ansi-common-lisp Genera CMU)
2621  (defun with-standard-io-syntax-function (function)  (defun with-standard-io-syntax-function (function)
2622    (declare #+lispm    (declare #+lispm
2623             (sys:downward-funarg function))             (sys:downward-funarg function))
# Line 2611  Line 2639 
2639          #+lucid (lucid::*print-structure* t))          #+lucid (lucid::*print-structure* t))
2640      (funcall function)))      (funcall function)))
2641    
2642  #-(or clx-ansi-common-lisp Genera)  #-(or clx-ansi-common-lisp Genera CMU)
2643  (defmacro with-standard-io-syntax (&body body)  (defmacro with-standard-io-syntax (&body body)
2644    `(flet ((.with-standard-io-syntax-body. () ,@body))    `(flet ((.with-standard-io-syntax-body. () ,@body))
2645       (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))       (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))
# Line 2691  Line 2719 
2719    #+(or Genera Minima) 'fixnum)    #+(or Genera Minima) 'fixnum)
2720    
2721  (deftype pixarray-1  ()  (deftype pixarray-1  ()
2722    '(array pixarray-1-element-type (* *)))    '(#+cmu simple-array #-cmu array pixarray-1-element-type (* *)))
2723    
2724  (deftype pixarray-4  ()  (deftype pixarray-4  ()
2725    '(array pixarray-4-element-type (* *)))    '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))
2726    
2727  (deftype pixarray-8  ()  (deftype pixarray-8  ()
2728    '(array pixarray-8-element-type (* *)))    '(#+cmu simple-array #-cmu array pixarray-8-element-type (* *)))
2729    
2730  (deftype pixarray-16 ()  (deftype pixarray-16 ()
2731    '(array pixarray-16-element-type (* *)))    '(#+cmu simple-array #-cmu array pixarray-16-element-type (* *)))
2732    
2733  (deftype pixarray-24 ()  (deftype pixarray-24 ()
2734    '(array pixarray-24-element-type (* *)))    '(#+cmu simple-array #-cmu array pixarray-24-element-type (* *)))
2735    
2736  (deftype pixarray-32 ()  (deftype pixarray-32 ()
2737    '(array pixarray-32-element-type (* *)))    '(#+cmu simple-array #-cmu array pixarray-32-element-type (* *)))
2738    
2739  (deftype pixarray ()  (deftype pixarray ()
2740    '(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 2747  Line 2775 
2775       (declare (type (simple-array ,element-type (*)) ,variable))       (declare (type (simple-array ,element-type (*)) ,variable))
2776       ,@body))       ,@body))
2777    
2778    #+CMU
2779    ;;; We do *NOT* support viewing an array as having a different element type.
2780    ;;; Element-type is ignored.
2781    ;;;
2782    (defmacro with-underlying-simple-vector
2783              ((variable element-type pixarray) &body body)
2784      (declare (ignore element-type))
2785      `(lisp::with-array-data ((,variable ,pixarray)
2786                               (start)
2787                               (end))
2788          (declare (ignore start end))
2789          ,@body))
2790    
2791  ;;; These are used to read and write pixels from and to CARD8s.  ;;; These are used to read and write pixels from and to CARD8s.
2792    
2793  ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.  ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
# Line 2916  Line 2957 
2957                             (index-ceiling x 8))                             (index-ceiling x 8))
2958                     (index+ start padded-bytes-per-line))                     (index+ start padded-bytes-per-line))
2959              (y 0 (index1+ y))              (y 0 (index1+ y))
2960              (left-bits (index-mod (index- x) 8))              (left-bits (the array-index (mod (the fixnum (- x)) 8)))
2961              (right-bits (index-mod (index- width left-bits) 8))              (right-bits (index-mod (index- width left-bits) 8))
2962              (middle-bits (index- width left-bits right-bits))              (middle-bits (the fixnum (- (the fixnum (- width left-bits))
2963                                            right-bits)))
2964              (middle-bytes (index-floor middle-bits 8)))              (middle-bytes (index-floor middle-bits 8)))
2965             ((index>= y height))             ((index>= y height))
2966          (declare (type array-index start y          (declare (type array-index start y
2967                         left-bits right-bits middle-bits middle-bytes))                         left-bits right-bits middle-bytes)
2968          (cond ((index< middle-bits 0)                   (fixnum middle-bits))
2969            (cond ((< middle-bits 0)
2970                 (let ((byte (aref buffer-bbuf (index1- start)))                 (let ((byte (aref buffer-bbuf (index1- start)))
2971                       (x (array-row-major-index array y left-bits)))                       (x (array-row-major-index array y left-bits)))
2972                   (declare (type card8 byte)                   (declare (type card8 byte)
# Line 2988  Line 3031 
3031                       (unless (index-zerop right-bits)                       (unless (index-zerop right-bits)
3032                         (let ((byte (aref buffer-bbuf end))                         (let ((byte (aref buffer-bbuf end))
3033                               (x (array-row-major-index                               (x (array-row-major-index
3034                                    array y (index+ left-bits middle-bits))))                                   array y (index+ left-bits middle-bits))))
3035                           (declare (type card8 byte)                           (declare (type card8 byte)
3036                                    (type array-index x))                                    (type array-index x))
3037                           (setf (aref vector (index+ x 0))                           (setf (aref vector (index+ x 0))
# Line 3032  Line 3075 
3075                     (setf (aref vector (index+ x 7))                     (setf (aref vector (index+ x 7))
3076                           (read-image-load-byte 1 7 byte))))                           (read-image-load-byte 1 7 byte))))
3077                 )))))                 )))))
3078    t)      t)
3079    
3080  #+(or lcl3.0 excl)  #+(or lcl3.0 excl)
3081  (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height  (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height
# Line 3051  Line 3094 
3094                             (index-ceiling x 2))                             (index-ceiling x 2))
3095                     (index+ start padded-bytes-per-line))                     (index+ start padded-bytes-per-line))
3096              (y 0 (index1+ y))              (y 0 (index1+ y))
3097              (left-nibbles (index-mod (index- x) 2))              (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x)))
3098                                                    2)))
3099              (right-nibbles (index-mod (index- width left-nibbles) 2))              (right-nibbles (index-mod (index- width left-nibbles) 2))
3100              (middle-nibbles (index- width left-nibbles right-nibbles))              (middle-nibbles (index- width left-nibbles right-nibbles))
3101              (middle-bytes (index-floor middle-nibbles 2)))              (middle-bytes (index-floor middle-nibbles 2)))
# Line 3079  Line 3123 
3123          )))          )))
3124    t)    t)
3125    
3126  #+(or Genera lcl3.0 excl)  #+(or Genera lcl3.0 excl CMU)
3127  (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
3128                                padded-bytes-per-line bits-per-pixel)                                padded-bytes-per-line bits-per-pixel)
3129    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
# Line 3125  Line 3169 
3169     (sys:bitblt boole-1 width height a x y pixarray 0 0))     (sys:bitblt boole-1 width height a x y pixarray 0 0))
3170    t)    t)
3171    
3172    #+CMU
3173    (defun pixarray-element-size (pixarray)
3174      (let ((eltype (array-element-type pixarray)))
3175        (cond ((eq eltype 'bit) 1)
3176              ((and (consp eltype) (eq (first eltype) 'unsigned-byte))
3177               (second eltype))
3178              (t
3179               (error "Invalid pixarray: ~S." pixarray)))))
3180    
3181    #+CMU
3182    ;;; COPY-BIT-RECT  --  Internal
3183    ;;;
3184    ;;;    This is the classic BITBLT operation, copying a rectangular subarray
3185    ;;; from one array to another (but source and destination must not overlap.)
3186    ;;; Widths are specified in bits.  Neither array can have a non-zero
3187    ;;; displacement.  We allow extra random bit-offset to be thrown into the X.
3188    ;;;
3189    (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
3190                                 height width)
3191      (declare (type array-index source-width sx sy dest-width dx dy height width))
3192       #.(declare-buffun)
3193       (lisp::with-array-data ((sdata source)
3194                               (sstart)
3195                               (send))
3196         (declare (ignore send))
3197         (lisp::with-array-data ((ddata dest)
3198                                 (dstart)
3199                                 (dend))
3200           (declare (ignore dend))
3201           (assert (and (zerop sstart) (zerop dstart)))
3202           (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits)
3203                                 sx (index* sy source-width))
3204                         (index+ src-idx source-width))
3205                (dest-idx (index+ (* vm:vector-data-offset vm:word-bits)
3206                                  dx (index* dy dest-width))
3207                          (index+ dest-idx dest-width))
3208                (count height (1- count)))
3209               ((zerop count))
3210             (declare (type array-index src-idx dest-idx count))
3211             (kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
3212    
3213    #+CMU
3214    (defun fast-read-pixarray-using-bitblt
3215           (bbuf boffset pixarray x y width height padded-bytes-per-line
3216            bits-per-pixel)
3217      (declare (type (array * 2) pixarray))
3218      #.(declare-buffun)
3219      (copy-bit-rect bbuf
3220                     (index* padded-bytes-per-line vm:byte-bits)
3221                     (index* boffset vm:byte-bits) 0
3222                     pixarray
3223                     (index* (array-dimension pixarray 1) bits-per-pixel)
3224                     x y
3225                     height
3226                     (index* width bits-per-pixel))
3227      t)
3228    
3229  #+(or Genera lcl3.0 excl)  #+(or Genera lcl3.0 excl)
3230  (defun fast-read-pixarray-with-swap  (defun fast-read-pixarray-with-swap
3231         (bbuf boffset pixarray x y width height padded-bytes-per-line         (bbuf boffset pixarray x y width height padded-bytes-per-line
# Line 3199  Line 3300 
3300                                   bits-per-pixel)                                   bits-per-pixel)
3301                                32))                                32))
3302                       #'fast-read-pixarray-using-bitblt)                       #'fast-read-pixarray-using-bitblt)
3303                    #+CMU
3304                    (and (index= (pixarray-element-size pixarray) bits-per-pixel)
3305                         #'fast-read-pixarray-using-bitblt)
3306                  #+(or lcl3.0 excl)                  #+(or lcl3.0 excl)
3307                  (and (index= bits-per-pixel 1)                  (and (index= bits-per-pixel 1)
3308                       #'fast-read-pixarray-1)                       #'fast-read-pixarray-1)
3309                  #+(or lcl3.0 excl)                  #+(or lcl3.0 excl)
3310                  (and (index= bits-per-pixel 4)                  (and (index= bits-per-pixel 4)
3311                       #'fast-read-pixarray-4)                       #'fast-read-pixarray-4)
3312                  #+(or Genera lcl3.0 excl)                  #+(or Genera lcl3.0 excl CMU)
3313                  (and (index= bits-per-pixel 24)                  (and (index= bits-per-pixel 24)
3314                       #'fast-read-pixarray-24))))                       #'fast-read-pixarray-24))))
3315        (when function        (when function
# Line 3321  Line 3425 
3425                    (aref vector (index+ x 1))))))))                    (aref vector (index+ x 1))))))))
3426    t)    t)
3427    
3428  #+(or Genera lcl3.0 excl)  #+(or Genera lcl3.0 excl CMU)
3429  (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
3430                                 padded-bytes-per-line bits-per-pixel)                                 padded-bytes-per-line bits-per-pixel)
3431    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
# Line 3369  Line 3473 
3473     (sys:bitblt boole-1 width height pixarray x y a 0 0))     (sys:bitblt boole-1 width height pixarray x y a 0 0))
3474    t)    t)
3475    
3476    #+CMU
3477    (defun fast-write-pixarray-using-bitblt
3478           (bbuf boffset pixarray x y width height padded-bytes-per-line
3479            bits-per-pixel)
3480      #.(declare-buffun)
3481      (copy-bit-rect pixarray
3482                     (index* (array-dimension pixarray 1) bits-per-pixel)
3483                     x y
3484                     bbuf
3485                     (index* padded-bytes-per-line vm:byte-bits)
3486                     (index* boffset vm:byte-bits) 0
3487                     height
3488                     (index* width bits-per-pixel))
3489      t)
3490    
3491  #+(or Genera lcl3.0 excl)  #+(or Genera lcl3.0 excl)
3492  (defun fast-write-pixarray-with-swap  (defun fast-write-pixarray-with-swap
3493         (bbuf boffset pixarray x y width height padded-bytes-per-line         (bbuf boffset pixarray x y width height padded-bytes-per-line
# Line 3440  Line 3559 
3559                                   bits-per-pixel)                                   bits-per-pixel)
3560                                32))                                32))
3561                       #'fast-write-pixarray-using-bitblt)                       #'fast-write-pixarray-using-bitblt)
3562                    #+CMU
3563                    (and (index= (pixarray-element-size pixarray) bits-per-pixel)
3564                         #'fast-write-pixarray-using-bitblt)
3565                  #+(or lcl3.0 excl)                  #+(or lcl3.0 excl)
3566                  (and (index= bits-per-pixel 1)                  (and (index= bits-per-pixel 1)
3567                       #'fast-write-pixarray-1)                       #'fast-write-pixarray-1)
3568                  #+(or lcl3.0 excl)                  #+(or lcl3.0 excl)
3569                  (and (index= bits-per-pixel 4)                  (and (index= bits-per-pixel 4)
3570                       #'fast-write-pixarray-4)                       #'fast-write-pixarray-4)
3571                  #+(or Genera lcl3.0 excl)                  #+(or Genera lcl3.0 excl CMU)
3572                  (and (index= bits-per-pixel 24)                  (and (index= bits-per-pixel 24)
3573                       #'fast-write-pixarray-24))))                       #'fast-write-pixarray-24))))
3574        (when function        (when function
# Line 3464  Line 3586 
3586             (type (member 1 4 8 16 24 32) bits-per-pixel))             (type (member 1 4 8 16 24 32) bits-per-pixel))
3587    (progn pixarray copy x y width height bits-per-pixel nil)    (progn pixarray copy x y width height bits-per-pixel nil)
3588    (or    (or
3589      #+lispm      #+(or lispm CMU)
3590      (let* ((pixarray-padded-pixels-per-line      (let* ((pixarray-padded-pixels-per-line
3591               #+Genera (sys:array-row-span pixarray)               #+Genera (sys:array-row-span pixarray)
3592               #-Genera (array-dimension pixarray 1))               #-Genera (array-dimension pixarray 1))
# Line 3475  Line 3597 
3597               #-Genera (array-dimension copy 1))               #-Genera (array-dimension copy 1))
3598             (copy-padded-bits-per-line             (copy-padded-bits-per-line
3599               (* copy-padded-pixels-per-line bits-per-pixel)))               (* copy-padded-pixels-per-line bits-per-pixel)))
3600          #-CMU
3601        (when (and (= (sys:array-element-size pixarray) bits-per-pixel)        (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
3602                   (zerop (index-mod pixarray-padded-bits-per-line 32))                   (zerop (index-mod pixarray-padded-bits-per-line 32))
3603                   (zerop (index-mod copy-padded-bits-per-line 32)))                   (zerop (index-mod copy-padded-bits-per-line 32)))
3604          (sys:bitblt boole-1 width height pixarray x y copy 0 0)          (sys:bitblt boole-1 width height pixarray x y copy 0 0)
3605            t)
3606          #+CMU
3607          (when (index= (pixarray-element-size pixarray)
3608                        (pixarray-element-size copy)
3609                        bits-per-pixel)
3610            (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
3611                           copy copy-padded-bits-per-line 0 0
3612                           height
3613                           (index* width bits-per-pixel))
3614          t))          t))
3615    
3616      #+(or lcl3.0 excl)      #+(or lcl3.0 excl)
3617      (unless (index= bits-per-pixel 24)      (unless (index= bits-per-pixel 24)
3618        (let ((pixarray-padded-bits-per-line        (let ((pixarray-padded-bits-per-line

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

  ViewVC Help
Powered by ViewVC 1.1.5