/[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.3 by ram, Tue Aug 11 15:15:55 1992 UTC revision 1.3.1.1 by ram, Wed Jul 21 08:31:55 1993 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    #+cmu
24    (setf (getf ext:*herald-items* :xlib)
25          `("    CLX X Library " ,*version*))
26    
27  ;;; The size of the output buffer.  Must be a multiple of 4.  ;;; The size of the output buffer.  Must be a multiple of 4.
28  (defparameter *output-buffer-size* 8192)  (defparameter *output-buffer-size* 8192)
29    
# Line 67  Line 71 
71  ;;; 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
72  ;;; *buffer-speed* is 3 and *buffer-safety* is 0.  ;;; *buffer-speed* is 3 and *buffer-safety* is 0.
73  (defun declare-buffun ()  (defun declare-buffun ()
74      #+(and cmu clx-debugging)
75      '(declare (optimize (speed 1) (safety 1)))
76      #-(and cmu clx-debugging)
77    `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))    `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
78    
79  )  )
# Line 677  Line 684 
684    #.(declare-buffun)    #.(declare-buffun)
685    (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))))
686    
687    
688    #+cmu (progn
689    
690    ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
691    ;;; is irrational, there can't be a precise rational representation.  In
692    ;;; particular, the different float approximations will always be /=.  This
693    ;;; causes problems with type checking, because people might compute an
694    ;;; argument in any precision.  What we do is discard all the excess precision
695    ;;; in the value, and see if the protocal encoding falls in the desired range
696    ;;; (64'ths of a degree.)
697    ;;;
698    (deftype angle () '(satisfies anglep))
699    
700    (defun anglep (x)
701      (and (typep x 'real)
702           (<= (* -360 64) (radians->int16 x) (* 360 64))))
703    
704    )
705    
706    
707  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
708  ;; Character transformation  ;; Character transformation
# Line 1335  Line 1361 
1361  ;;; 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
1362  ;;; display object instead of a stream.  ;;; display object instead of a stream.
1363  ;;;  ;;;
1364  #+CMU  #+cmu
1365    (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
1366                             c-call:int
1367      (host c-call:c-string)
1368      (port c-call:int))
1369    #+cmu
1370  (defun open-x-stream (host display protocol)  (defun open-x-stream (host display protocol)
1371    (declare (ignore protocol))    (declare (ignore protocol))
1372    (let ((server-fd (connect-to-server host display)))    (let ((server-fd (connect-to-server host display)))
# Line 1344  Line 1375 
1375      (system:make-fd-stream server-fd :input t :output t      (system:make-fd-stream server-fd :input t :output t
1376                             :element-type '(unsigned-byte 8))))                             :element-type '(unsigned-byte 8))))
1377    
 ;;; 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))  
1378    
1379  ;;; BUFFER-READ-DEFAULT - read data from the X stream  ;;; BUFFER-READ-DEFAULT - read data from the X stream
1380    
# Line 1454  Line 1476 
1476    (declare (type display display)    (declare (type display display)
1477             (type buffer-bytes vector)             (type buffer-bytes vector)
1478             (type array-index start end)             (type array-index start end)
1479             (type (or null (real 0 *)) timeout))             (type (or null fixnum) timeout))
1480    #.(declare-buffun)    #.(declare-buffun)
1481    (cond ((and (and timeout (= timeout 0))    (cond ((and (eql timeout 0)
1482                (not (listen (display-input-stream display))))                (not (listen (display-input-stream display))))
1483           :timeout)           :timeout)
1484          (t          (t
# Line 1464  Line 1486 
1486                                vector start (- end start))                                vector start (- end start))
1487           nil)))           nil)))
1488    
1489    
1490  ;;; WARNING:  ;;; WARNING:
1491  ;;;     CLX performance will suffer if your lisp uses read-byte for  ;;;     CLX performance will suffer if your lisp uses read-byte for
1492  ;;;     receiving all data from the X Window System server.  ;;;     receiving all data from the X Window System server.
# Line 1573  Line 1596 
1596            (declare (type array-index index))            (declare (type array-index index))
1597            (write-byte (aref vector index) stream))))))            (write-byte (aref vector index) stream))))))
1598    
1599    #+CMU
1600    (defun buffer-write-default (vector display start end)
1601      (declare (type buffer-bytes vector)
1602               (type display display)
1603               (type array-index start end))
1604      #.(declare-buffun)
1605      (system:output-raw-bytes (display-output-stream display) vector start end)
1606      nil)
1607    
1608  ;;; buffer-force-output-default - force output to the X stream  ;;; buffer-force-output-default - force output to the X stream
1609    
1610  #+excl  #+excl
# Line 1580  Line 1612 
1612    ;; buffer-write-default does the actual writing.    ;; buffer-write-default does the actual writing.
1613    (declare (ignore display)))    (declare (ignore display)))
1614    
1615  #-excl  #-(or excl)
1616  (defun buffer-force-output-default (display)  (defun buffer-force-output-default (display)
1617    ;; The default buffer force-output function for use with common-lisp streams    ;; The default buffer force-output function for use with common-lisp streams
1618    (declare (type display display))    (declare (type display display))
# Line 1599  Line 1631 
1631    #.(declare-buffun)    #.(declare-buffun)
1632    (excl::filesys-checking-close (display-output-stream display)))    (excl::filesys-checking-close (display-output-stream display)))
1633    
1634  #-excl  #-(or excl)
1635  (defun buffer-close-default (display &key abort)  (defun buffer-close-default (display &key abort)
1636    ;; The default buffer close function for use with common-lisp streams    ;; The default buffer close function for use with common-lisp streams
1637    (declare (type display display))    (declare (type display display))
# Line 1647  Line 1679 
1679  #+CMU  #+CMU
1680  (defun buffer-input-wait-default (display timeout)  (defun buffer-input-wait-default (display timeout)
1681    (declare (type display display)    (declare (type display display)
1682             (type (or null (real 0 *)) timeout))             (type (or null number) timeout))
1683    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
1684      (declare (type (or null stream) stream))      (declare (type (or null stream) stream))
1685      (cond ((null stream))      (cond ((null stream))
1686            ((listen stream) nil)            ((listen stream) nil)
1687            ((and timeout (= timeout 0)) :timeout)            ((eql timeout 0) :timeout)
1688            (t            (t
1689             (if (system:wait-until-fd-usable (system:fd-stream-fd stream)             (if (system:wait-until-fd-usable (system:fd-stream-fd stream)
1690                                              :input timeout)                                              :input timeout)
# Line 1782  Line 1814 
1814  ;;; 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.
1815    
1816  ;;; The default implementation is to just use listen.  ;;; The default implementation is to just use listen.
1817  #-excl  #-(or excl)
1818  (defun buffer-listen-default (display)  (defun buffer-listen-default (display)
1819    (declare (type display display))    (declare (type display display))
1820    (let ((stream (display-input-stream display)))    (let ((stream (display-input-stream display)))
# Line 2114  Line 2146 
2146  #+CMU  #+CMU
2147  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2148    (let ((condx (apply #'make-condition condition keyargs)))    (let ((condx (apply #'make-condition condition keyargs)))
2149      (typecase condx      (when (eq condition 'closed-display)
2150        ;; This condition no longer exists.        (let ((disp (closed-display-display condx)))
2151        #||          (warn "Disabled event handling on ~S." disp)
2152        (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))))  
2153      (error condx)))      (error condx)))
2154    
2155  #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)  #-(or lispm ansi-common-lisp excl lcl3.0 CMU)
2156  (defun x-error (condition &rest keyargs)  (defun x-error (condition &rest keyargs)
2157    (error "X-Error: ~a"    (error "X-Error: ~a"
2158           (princ-to-string (apply #'make-condition condition keyargs))))           (princ-to-string (apply #'make-condition condition keyargs))))
# Line 2589  Line 2613 
2613  ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)  ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)
2614  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
2615    
2616  #-(or clx-ansi-common-lisp Genera)  #-(or clx-ansi-common-lisp Genera CMU)
2617  (defun with-standard-io-syntax-function (function)  (defun with-standard-io-syntax-function (function)
2618    (declare #+lispm    (declare #+lispm
2619             (sys:downward-funarg function))             (sys:downward-funarg function))
# Line 2611  Line 2635 
2635          #+lucid (lucid::*print-structure* t))          #+lucid (lucid::*print-structure* t))
2636      (funcall function)))      (funcall function)))
2637    
2638  #-(or clx-ansi-common-lisp Genera)  #-(or clx-ansi-common-lisp Genera CMU)
2639  (defmacro with-standard-io-syntax (&body body)  (defmacro with-standard-io-syntax (&body body)
2640    `(flet ((.with-standard-io-syntax-body. () ,@body))    `(flet ((.with-standard-io-syntax-body. () ,@body))
2641       (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))       (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))
# Line 2747  Line 2771 
2771       (declare (type (simple-array ,element-type (*)) ,variable))       (declare (type (simple-array ,element-type (*)) ,variable))
2772       ,@body))       ,@body))
2773    
2774    #+CMU
2775    ;;; We do *NOT* support viewing an array as having a different element type.
2776    ;;; Element-type is ignored.
2777    ;;;
2778    (defmacro with-underlying-simple-vector
2779              ((variable element-type pixarray) &body body)
2780      (declare (ignore element-type))
2781      `(lisp::with-array-data ((,variable ,pixarray)
2782                               (start)
2783                               (end))
2784          (declare (ignore start end))
2785          ,@body))
2786    
2787  ;;; These are used to read and write pixels from and to CARD8s.  ;;; These are used to read and write pixels from and to CARD8s.
2788    
2789  ;;; 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 2953 
2953                             (index-ceiling x 8))                             (index-ceiling x 8))
2954                     (index+ start padded-bytes-per-line))                     (index+ start padded-bytes-per-line))
2955              (y 0 (index1+ y))              (y 0 (index1+ y))
2956              (left-bits (index-mod (index- x) 8))              (left-bits (the array-index (mod (the fixnum (- x)) 8)))
2957              (right-bits (index-mod (index- width left-bits) 8))              (right-bits (index-mod (index- width left-bits) 8))
2958              (middle-bits (index- width left-bits right-bits))              (middle-bits (the fixnum (- (the fixnum (- width left-bits))
2959                                            right-bits)))
2960              (middle-bytes (index-floor middle-bits 8)))              (middle-bytes (index-floor middle-bits 8)))
2961             ((index>= y height))             ((index>= y height))
2962          (declare (type array-index start y          (declare (type array-index start y
2963                         left-bits right-bits middle-bits middle-bytes))                         left-bits right-bits middle-bytes)
2964          (cond ((index< middle-bits 0)                   (fixnum middle-bits))
2965            (cond ((< middle-bits 0)
2966                 (let ((byte (aref buffer-bbuf (index1- start)))                 (let ((byte (aref buffer-bbuf (index1- start)))
2967                       (x (array-row-major-index array y left-bits)))                       (x (array-row-major-index array y left-bits)))
2968                   (declare (type card8 byte)                   (declare (type card8 byte)
# Line 2988  Line 3027 
3027                       (unless (index-zerop right-bits)                       (unless (index-zerop right-bits)
3028                         (let ((byte (aref buffer-bbuf end))                         (let ((byte (aref buffer-bbuf end))
3029                               (x (array-row-major-index                               (x (array-row-major-index
3030                                    array y (index+ left-bits middle-bits))))                                   array y (index+ left-bits middle-bits))))
3031                           (declare (type card8 byte)                           (declare (type card8 byte)
3032                                    (type array-index x))                                    (type array-index x))
3033                           (setf (aref vector (index+ x 0))                           (setf (aref vector (index+ x 0))
# Line 3032  Line 3071 
3071                     (setf (aref vector (index+ x 7))                     (setf (aref vector (index+ x 7))
3072                           (read-image-load-byte 1 7 byte))))                           (read-image-load-byte 1 7 byte))))
3073                 )))))                 )))))
3074    t)      t)
3075    
3076  #+(or lcl3.0 excl)  #+(or lcl3.0 excl)
3077  (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 3090 
3090                             (index-ceiling x 2))                             (index-ceiling x 2))
3091                     (index+ start padded-bytes-per-line))                     (index+ start padded-bytes-per-line))
3092              (y 0 (index1+ y))              (y 0 (index1+ y))
3093              (left-nibbles (index-mod (index- x) 2))              (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x)))
3094                                                    2)))
3095              (right-nibbles (index-mod (index- width left-nibbles) 2))              (right-nibbles (index-mod (index- width left-nibbles) 2))
3096              (middle-nibbles (index- width left-nibbles right-nibbles))              (middle-nibbles (index- width left-nibbles right-nibbles))
3097              (middle-bytes (index-floor middle-nibbles 2)))              (middle-bytes (index-floor middle-nibbles 2)))
# Line 3079  Line 3119 
3119          )))          )))
3120    t)    t)
3121    
3122  #+(or Genera lcl3.0 excl)  #+(or Genera lcl3.0 excl CMU)
3123  (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
3124                                padded-bytes-per-line bits-per-pixel)                                padded-bytes-per-line bits-per-pixel)
3125    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
# Line 3125  Line 3165 
3165     (sys:bitblt boole-1 width height a x y pixarray 0 0))     (sys:bitblt boole-1 width height a x y pixarray 0 0))
3166    t)    t)
3167    
3168    #+CMU
3169    (defun pixarray-element-size (pixarray)
3170      (let ((eltype (array-element-type pixarray)))
3171        (cond ((eq eltype 'bit) 1)
3172              ((and (consp eltype) (eq (first eltype) 'unsigned-byte))
3173               (second eltype))
3174              (t
3175               (error "Invalid pixarray: ~S." pixarray)))))
3176    
3177    #+CMU
3178    ;;; COPY-BIT-RECT  --  Internal
3179    ;;;
3180    ;;;    This is the classic BITBLT operation, copying a rectangular subarray
3181    ;;; from one array to another (but source and destination must not overlap.)
3182    ;;; Widths are specified in bits.  Neither array can have a non-zero
3183    ;;; displacement.  We allow extra random bit-offset to be thrown into the X.
3184    ;;;
3185    (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
3186                                 height width)
3187      (declare (type array-index source-width sx sy dest-width dx dy height width))
3188       #.(declare-buffun)
3189       (lisp::with-array-data ((sdata source)
3190                               (sstart)
3191                               (send))
3192         (declare (ignore send))
3193         (lisp::with-array-data ((ddata dest)
3194                                 (dstart)
3195                                 (dend))
3196           (declare (ignore dend))
3197           (assert (and (zerop sstart) (zerop dstart)))
3198           (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits)
3199                                 sx (index* sy source-width))
3200                         (index+ src-idx source-width))
3201                (dest-idx (index+ (* vm:vector-data-offset vm:word-bits)
3202                                  dx (index* dy dest-width))
3203                          (index+ dest-idx dest-width))
3204                (count height (1- count)))
3205               ((zerop count))
3206             (declare (type array-index src-idx dest-idx count))
3207             (kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
3208    
3209    #+CMU
3210    (defun fast-read-pixarray-using-bitblt
3211           (bbuf boffset pixarray x y width height padded-bytes-per-line
3212            bits-per-pixel)
3213      (declare (type (array * 2) pixarray))
3214      #.(declare-buffun)
3215      (copy-bit-rect bbuf
3216                     (index* padded-bytes-per-line vm:byte-bits)
3217                     (index* boffset vm:byte-bits) 0
3218                     pixarray
3219                     (index* (array-dimension pixarray 1) bits-per-pixel)
3220                     x y
3221                     height
3222                     (index* width bits-per-pixel))
3223      t)
3224    
3225  #+(or Genera lcl3.0 excl)  #+(or Genera lcl3.0 excl)
3226  (defun fast-read-pixarray-with-swap  (defun fast-read-pixarray-with-swap
3227         (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 3296 
3296                                   bits-per-pixel)                                   bits-per-pixel)
3297                                32))                                32))
3298                       #'fast-read-pixarray-using-bitblt)                       #'fast-read-pixarray-using-bitblt)
3299                    #+CMU
3300                    (and (index= (pixarray-element-size pixarray) bits-per-pixel)
3301                         #'fast-read-pixarray-using-bitblt)
3302                  #+(or lcl3.0 excl)                  #+(or lcl3.0 excl)
3303                  (and (index= bits-per-pixel 1)                  (and (index= bits-per-pixel 1)
3304                       #'fast-read-pixarray-1)                       #'fast-read-pixarray-1)
3305                  #+(or lcl3.0 excl)                  #+(or lcl3.0 excl)
3306                  (and (index= bits-per-pixel 4)                  (and (index= bits-per-pixel 4)
3307                       #'fast-read-pixarray-4)                       #'fast-read-pixarray-4)
3308                  #+(or Genera lcl3.0 excl)                  #+(or Genera lcl3.0 excl CMU)
3309                  (and (index= bits-per-pixel 24)                  (and (index= bits-per-pixel 24)
3310                       #'fast-read-pixarray-24))))                       #'fast-read-pixarray-24))))
3311        (when function        (when function
# Line 3321  Line 3421 
3421                    (aref vector (index+ x 1))))))))                    (aref vector (index+ x 1))))))))
3422    t)    t)
3423    
3424  #+(or Genera lcl3.0 excl)  #+(or Genera lcl3.0 excl CMU)
3425  (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
3426                                 padded-bytes-per-line bits-per-pixel)                                 padded-bytes-per-line bits-per-pixel)
3427    (declare (type buffer-bytes buffer-bbuf)    (declare (type buffer-bytes buffer-bbuf)
# Line 3369  Line 3469 
3469     (sys:bitblt boole-1 width height pixarray x y a 0 0))     (sys:bitblt boole-1 width height pixarray x y a 0 0))
3470    t)    t)
3471    
3472    #+CMU
3473    (defun fast-write-pixarray-using-bitblt
3474           (bbuf boffset pixarray x y width height padded-bytes-per-line
3475            bits-per-pixel)
3476      #.(declare-buffun)
3477      (copy-bit-rect pixarray
3478                     (index* (array-dimension pixarray 1) bits-per-pixel)
3479                     x y
3480                     bbuf
3481                     (index* padded-bytes-per-line vm:byte-bits)
3482                     (index* boffset vm:byte-bits) 0
3483                     height
3484                     (index* width bits-per-pixel))
3485      t)
3486    
3487  #+(or Genera lcl3.0 excl)  #+(or Genera lcl3.0 excl)
3488  (defun fast-write-pixarray-with-swap  (defun fast-write-pixarray-with-swap
3489         (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 3555 
3555                                   bits-per-pixel)                                   bits-per-pixel)
3556                                32))                                32))
3557                       #'fast-write-pixarray-using-bitblt)                       #'fast-write-pixarray-using-bitblt)
3558                    #+CMU
3559                    (and (index= (pixarray-element-size pixarray) bits-per-pixel)
3560                         #'fast-write-pixarray-using-bitblt)
3561                  #+(or lcl3.0 excl)                  #+(or lcl3.0 excl)
3562                  (and (index= bits-per-pixel 1)                  (and (index= bits-per-pixel 1)
3563                       #'fast-write-pixarray-1)                       #'fast-write-pixarray-1)
3564                  #+(or lcl3.0 excl)                  #+(or lcl3.0 excl)
3565                  (and (index= bits-per-pixel 4)                  (and (index= bits-per-pixel 4)
3566                       #'fast-write-pixarray-4)                       #'fast-write-pixarray-4)
3567                  #+(or Genera lcl3.0 excl)                  #+(or Genera lcl3.0 excl CMU)
3568                  (and (index= bits-per-pixel 24)                  (and (index= bits-per-pixel 24)
3569                       #'fast-write-pixarray-24))))                       #'fast-write-pixarray-24))))
3570        (when function        (when function
# Line 3464  Line 3582 
3582             (type (member 1 4 8 16 24 32) bits-per-pixel))             (type (member 1 4 8 16 24 32) bits-per-pixel))
3583    (progn pixarray copy x y width height bits-per-pixel nil)    (progn pixarray copy x y width height bits-per-pixel nil)
3584    (or    (or
3585      #+lispm      #+(or lispm CMU)
3586      (let* ((pixarray-padded-pixels-per-line      (let* ((pixarray-padded-pixels-per-line
3587               #+Genera (sys:array-row-span pixarray)               #+Genera (sys:array-row-span pixarray)
3588               #-Genera (array-dimension pixarray 1))               #-Genera (array-dimension pixarray 1))
# Line 3475  Line 3593 
3593               #-Genera (array-dimension copy 1))               #-Genera (array-dimension copy 1))
3594             (copy-padded-bits-per-line             (copy-padded-bits-per-line
3595               (* copy-padded-pixels-per-line bits-per-pixel)))               (* copy-padded-pixels-per-line bits-per-pixel)))
3596          #-CMU
3597        (when (and (= (sys:array-element-size pixarray) bits-per-pixel)        (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
3598                   (zerop (index-mod pixarray-padded-bits-per-line 32))                   (zerop (index-mod pixarray-padded-bits-per-line 32))
3599                   (zerop (index-mod copy-padded-bits-per-line 32)))                   (zerop (index-mod copy-padded-bits-per-line 32)))
3600          (sys:bitblt boole-1 width height pixarray x y copy 0 0)          (sys:bitblt boole-1 width height pixarray x y copy 0 0)
3601            t)
3602          #+CMU
3603          (when (index= (pixarray-element-size pixarray)
3604                        (pixarray-element-size copy)
3605                        bits-per-pixel)
3606            (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
3607                           copy copy-padded-bits-per-line 0 0
3608                           height
3609                           (index* width bits-per-pixel))
3610          t))          t))
3611    
3612      #+(or lcl3.0 excl)      #+(or lcl3.0 excl)
3613      (unless (index= bits-per-pixel 24)      (unless (index= bits-per-pixel 24)
3614        (let ((pixarray-padded-bits-per-line        (let ((pixarray-padded-bits-per-line

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.3.1.1

  ViewVC Help
Powered by ViewVC 1.1.5