Raymond Toy pushed to branch rtoy-update-clx at cmucl / cmucl
Commits: 6ea45079 by Raymond Toy at 2018-01-27T09:06:25-08:00 Move these files extensions dir to match upstream clx.
[skip-ci]
- - - - - e6f4c980 by Raymond Toy at 2018-01-27T09:08:11-08:00 Merge upstream changes.
[skip-ci]
- - - - -
10 changed files:
- src/clx/big-requests.lisp → src/clx/extensions/big-requests.lisp - src/clx/dpms.lisp → src/clx/extensions/dpms.lisp - src/clx/gl.lisp → src/clx/extensions/gl.lisp - src/clx/glx.lisp → src/clx/extensions/glx.lisp - src/clx/screensaver.lisp → src/clx/extensions/screensaver.lisp - src/clx/shape.lisp → src/clx/extensions/shape.lisp - src/clx/xinerama.lisp → src/clx/extensions/xinerama.lisp - src/clx/xrender.lisp → src/clx/extensions/xrender.lisp - src/clx/xtest.lisp → src/clx/extensions/xtest.lisp - src/clx/xvidmode.lisp → src/clx/extensions/xvidmode.lisp
Changes:
===================================== src/clx/big-requests.lisp → src/clx/extensions/big-requests.lisp ===================================== --- a/src/clx/big-requests.lisp +++ b/src/clx/extensions/big-requests.lisp @@ -12,9 +12,6 @@ ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-#+cmu -(ext:file-comment "$Id: big-requests.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") - (in-package "XLIB")
;;; No new events or errors are defined by this extension. (Big
===================================== src/clx/dpms.lisp → src/clx/extensions/dpms.lisp ===================================== --- a/src/clx/dpms.lisp +++ b/src/clx/extensions/dpms.lisp @@ -13,10 +13,7 @@ ;;;; any purpose of the information in this document. This documentation is ;;;; provided ``as is'' without express or implied warranty.
-#+cmu -(ext:file-comment "$Id: dpms.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :dpms +(defpackage #:xlib/dpms (:use :common-lisp) (:import-from :xlib "DEFINE-EXTENSION" @@ -39,7 +36,7 @@ "DPMS-FORCE-LEVEL" "DPMS-INFO"))
-(in-package :dpms) +(in-package #:xlib/dpms)
(define-extension "DPMS")
===================================== src/clx/gl.lisp → src/clx/extensions/gl.lisp ===================================== --- a/src/clx/gl.lisp +++ b/src/clx/extensions/gl.lisp @@ -1,9 +1,6 @@ -#+cmu -(ext:file-comment "$Id: gl.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :gl +(defpackage #:xlib/gl (:use :common-lisp :xlib) - (:import-from :glx + (:import-from :xlib/glx "*CURRENT-CONTEXT*" "CONTEXT" "CONTEXT-P" @@ -1156,7 +1153,7 @@ ))
-(in-package :gl) +(in-package #:xlib/gl)
@@ -2138,6 +2135,27 @@ value)
+#+lispworks +(progn + (defun %single-float-bits (x) + (declare (type single-float x)) + (fli:with-dynamic-foreign-objects ((bits :int32)) + (fli:with-coerced-pointer (pointer :type :lisp-single-float) bits + (setf (fli:dereference pointer) x)) + (fli:dereference bits))) + + (declaim (notinline aset-float32)) + (defun aset-float32 (value array index) + (declare (type (or short-float single-float) value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((bits (%single-float-bits (coerce value 'single-float)))) + (declare (type (unsigned-byte 32) bits)) + (aset-card32 bits array index)) + value)) + + #+sbcl (defun aset-float64 (value array index) (declare (type double-float value) @@ -2180,6 +2198,36 @@ value)
+#+lispworks +(progn + (fli:define-c-struct %uint64 + (high :uint32) + (low :uint32)) + + (defun %double-float-bits (x) + (declare (type double-float x)) + (fli:with-dynamic-foreign-objects ((bits %uint64)) + (fli:with-coerced-pointer (pointer :type :lisp-double-float) bits + (setf (fli:dereference pointer) x)) + + (values (fli:foreign-slot-value bits 'low :type :uint32 :object-type '%uint64) + (fli:foreign-slot-value bits 'high :type :uint32 :object-type '%uint64)))) + + (declaim (notinline aset-float64)) + (defun aset-float64 (value array index) + (declare (type double-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (multiple-value-bind (low high) + (%double-float-bits value) + (declare (type (unsigned-byte 32) low high)) + + (aset-card32 low array index) + (aset-card32 high array (the array-index (+ index 4)))) + value)) + + (eval-when (:compile-toplevel :load-toplevel :execute) (defun byte-width (type) (ecase type @@ -2593,7 +2641,7 @@ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ - #.+max-convolution-width+) + #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) @@ -2619,7 +2667,7 @@ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ - #.+max-convolution-width+) + #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+)
===================================== src/clx/glx.lisp → src/clx/extensions/glx.lisp ===================================== --- a/src/clx/glx.lisp +++ b/src/clx/extensions/glx.lisp @@ -1,7 +1,4 @@ -#+cmu -(ext:file-comment "$Id: glx.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :glx +(defpackage #:xlib/glx (:use :common-lisp :xlib) (:import-from :xlib "DEFINE-ACCESSOR" @@ -72,11 +69,11 @@ ))
-(in-package :glx) - - -(declaim (optimize (debug 3) (safety 3))) +(in-package #:xlib/glx)
+;;; Generally don't want this declamation to have load-time effects +(eval-when (:compile-toplevel) + (declaim (optimize (debug 3) (safety 3))))
(define-extension "GLX" :events (:glx-pbuffer-clobber) @@ -599,7 +596,7 @@ Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." (let* ((ctx *current-context*) (display (context-display ctx))) ;; Make sure all rendering commands are sent away. - (glx:render) + (render) (with-buffer-request (display (extension-opcode display "GLX")) (data +swap-buffers+) ;; *** GLX_CONTEXT_TAG
===================================== src/clx/screensaver.lisp → src/clx/extensions/screensaver.lisp =====================================
===================================== src/clx/shape.lisp → src/clx/extensions/shape.lisp ===================================== --- a/src/clx/shape.lisp +++ b/src/clx/extensions/shape.lisp @@ -20,9 +20,6 @@ ;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz
-#+cmu -(ext:file-comment "$Id: shape.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib)
(export '(shape-query-version
===================================== src/clx/xinerama.lisp → src/clx/extensions/xinerama.lisp ===================================== --- a/src/clx/xinerama.lisp +++ b/src/clx/extensions/xinerama.lisp @@ -12,7 +12,7 @@ ;;; This is an implementation of the XINERAMA extension. It does not ;;; include the obsolete PanoramiX calls.
-(defpackage "XLIB.XINERAMA" +(defpackage #:xlib/xinerama (:use "COMMON-LISP" "XLIB") (:nicknames "XINERAMA") (:import-from "XLIB" @@ -33,7 +33,7 @@ "XINERAMA-QUERY-VERSION" "XINERAMA-IS-ACTIVE" "XINERAMA-QUERY-SCREENS")) -(in-package "XINERAMA") +(in-package #:xlib/xinerama)
(define-extension "XINERAMA")
===================================== src/clx/xrender.lisp → src/clx/extensions/xrender.lisp ===================================== --- a/src/clx/xrender.lisp +++ b/src/clx/extensions/xrender.lisp @@ -3,8 +3,7 @@ ;;; Title: The X Render Extension ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann unk6@rz.uni-karlsruhe.de -#+cmu -(ext:file-comment "$Id: xrender.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") +;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $ ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2002, 2003 by Gilbert Baumann @@ -128,6 +127,8 @@ render-query-version ;; render-query-picture-formats render-fill-rectangle + render-triangles + render-trapezoids render-composite render-create-glyph-set render-reference-glyph-set @@ -196,6 +197,24 @@ ;; We do away with the distinction between pict-format and ;; picture-format-info. That is we cache picture-format-infos.
+(defstruct picture-format + display + (id 0 :type (unsigned-byte 29)) + type + depth + red-byte + green-byte + blue-byte + alpha-byte + colormap) + +(def-clx-class (glyph-set (:copier nil) + ) + (id 0 :type resource-id) + (display nil :type (or null display)) + (plist nil :type list) ; Extension hook + (format)) + (defstruct render-info major-version minor-version @@ -298,17 +317,6 @@ by every function, which attempts to generate RENDER requests."
;;; picture format
-(defstruct picture-format - display - (id 0 :type (unsigned-byte 29)) - type - depth - red-byte - green-byte - blue-byte - alpha-byte - colormap) - (defmethod print-object ((object picture-format) stream) (let ((abbrev (with-output-to-string (bag) @@ -517,13 +525,15 @@ by every function, which attempts to generate RENDER requests." (let ((display (picture-display picture))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreePicture+) - (picture picture)))) + (picture picture)) + (deallocate-resource-id display (picture-id picture) 'picture)))
(defun render-free-glyph-set (glyph-set) (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphSet+) - (glyph-set glyph-set)))) + (glyph-set glyph-set)) + (deallocate-resource-id display (glyph-set-id glyph-set) 'glyph-set)))
(defun render-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) @@ -570,16 +580,16 @@ by every function, which attempts to generate RENDER requests." (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFillRectangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad + (render-op op) + (pad8 0) + (pad16 0) (resource-id (picture-id picture)) (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) (int16 x1) (int16 y1) (card16 w) (card16 h))))
;; fill rectangles, colors.
-(defun render-triangles-1 (picture op source src-x src-y format coord-sequence) +(defun render-triangles (picture op source src-x src-y format coord-sequence) ;; For performance reasons we do a special typecase on (simple-array ;; (unsigned-byte 32) (*)), so that it'll be possible to have high ;; performance rasters. @@ -587,17 +597,18 @@ by every function, which attempts to generate RENDER requests." '(let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTriangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - (picture-format format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) )))) + (labels ((funk (x) (ash x 16))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderTriangles+) + (render-op op) + (pad8 0) + (pad16 0) + (resource-id (picture-id source)) + (resource-id (picture-id picture)) + (picture-format format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32 :transform #'funk) coord-sequence)))))) (typecase coord-sequence ((simple-array (unsigned-byte 32) (*)) (locally @@ -694,7 +705,7 @@ by every function, which attempts to generate RENDER requests." (data +X-RenderSetPictureFilter+) (resource-id (picture-id picture)) (card16 (length filter)) - (card16 0) ;pad + (pad16 0) ((sequence :format card8) (map 'vector #'char-code filter)))))
@@ -705,25 +716,26 @@ by every function, which attempts to generate RENDER requests." ) ||#
-(defun render-trapezoids-1 (picture op source src-x src-y mask-format coord-sequence) +(defun render-trapezoids (picture op source src-x src-y mask-format coord-sequence) ;; coord-sequence is top bottom - ;; line-1-x1 line-1-y1 line-1-x2 line-1-y2 - ;; line-2-x1 line-2-y1 line-2-x2 line-2-y2 ... + ;; left-x1 left-y1 left-x2 left-y2 + ;; right-x1 right-y1 right-x2 right-y2 ... ;; (let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTrapezoids+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - ((or (member :none) picture-format) mask-format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) ))) + (labels ((funk (x) (ash x 16))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderTrapezoids+) + (render-op op) + (pad8 0) + (pad16 0) + (resource-id (picture-id source)) + (resource-id (picture-id picture)) + ((or (member :none) picture-format) mask-format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32 :transform #'funk) coord-sequence)))))
(defun render-composite (op source mask dest @@ -735,9 +747,9 @@ by every function, which attempts to generate RENDER requests." (synchronise-picture-state dest) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderComposite+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad + (render-op op) + (pad8 0) + (pad16 0) (resource-id (picture-id source)) (resource-id (if mask (picture-id mask) 0)) (resource-id (picture-id dest)) @@ -750,13 +762,6 @@ by every function, which attempts to generate RENDER requests." (card16 width) (card16 height))))
-(def-clx-class (glyph-set (:copier nil) - ) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - (format)) - (defun render-create-glyph-set (format &key glyph-set) (let ((display (picture-format-display format))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) @@ -803,14 +808,16 @@ by every function, which attempts to generate RENDER requests." (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCompositeGlyphs8+) (render-op alu) - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (picture source) (picture dest) ((or (member :none) picture-format) mask-format) (glyph-set glyph-set) (int16 src-x) (int16 src-y) (card8 (- end start)) ;length of glyph elt - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (int16 dest-x) (int16 dest-y) ;dx, dy ((sequence :format card8) sequence))))
@@ -832,7 +839,8 @@ by every function, which attempts to generate RENDER requests." (data ,opcode) (length request-length) (render-op ,alu) - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (picture ,source) (picture ,dest) ((or (member :none) picture-format) ,mask-format) @@ -931,17 +939,27 @@ by every function, which attempts to generate RENDER requests." (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (let* ((byte-per-line (* 4 (ceiling - (* w (picture-format-depth (glyph-set-format glyph-set))) - 32))) - (request-length (+ 28 - (* h byte-per-line)))) + (let* ((padded-bytes-per-line + (index* (index-ceiling + (index* w (picture-format-depth + (glyph-set-format glyph-set))) + 32) + 4)) + (request-bytes + (index+ 28 (index* h padded-bytes-per-line))) + (max-bytes-per-request + (index* (index- (display-max-request-length display) 6) 4))) + ;; INV: we can do better – if at least one scanline of the + ;; image fits in the request, we may render glyph in a loop + ;; like it's done in a function `put-image' in `image.lisp'. + (when (> request-bytes max-bytes-per-request) + (error "Glyph won't fit in a single request")) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphs+) - (length (ceiling request-length 4)) + (length (ceiling request-bytes 4)) (glyph-set glyph-set) - (card32 1) ;number glyphs - (card32 id) ;id + (card32 1) ;number glyphs + (card32 id) ;id (card16 w) (card16 h) (int16 x-origin) @@ -952,7 +970,7 @@ by every function, which attempts to generate RENDER requests." (setf (buffer-boffset display) (advance-buffer-offset 28)) (let ((im (create-image :width w :height h :depth 8 :data data))) (write-image-z display im 0 0 w h - byte-per-line ;padded bytes per line + padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)) ))) )))
(defun render-add-glyph-from-picture (glyph-set picture @@ -1153,3 +1171,21 @@ by every function, which attempts to generate RENDER requests." (card16 x) (card16 y)) cursor))) + +(defun render-create-anim-cursor (cursors delays) + "Create animated cursor. cursors length must be the same as delays length." + (let ((display (cursor-display (first cursors)))) + (ensure-render-initialized display) + (let* ((cursor (make-cursor :display display)) + (cid (allocate-resource-id display cursor 'cursor)) + (cursors-length (length cursors)) + (cursors-delays (make-list (* 2 (length cursors))))) + (setf (xlib:cursor-id cursor) cid) + (dotimes (i cursors-length) + (setf (elt cursors-delays (* 2 i)) (cursor-id (elt cursors i)) + (elt cursors-delays (1+ (* 2 i))) (elt delays i))) + (xlib::with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderCreateAnimCursor+) + (resource-id cid) + ((sequence :format card32) cursors-delays)) + cursor)))
===================================== src/clx/xtest.lisp → src/clx/extensions/xtest.lisp ===================================== --- a/src/clx/xtest.lisp +++ b/src/clx/extensions/xtest.lisp @@ -10,7 +10,7 @@ ;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard ;;; * Add the missing (declare (type ...
-(defpackage :xtest +(defpackage #:xlib/xtest (:use :common-lisp :xlib) (:import-from :xlib #:data @@ -44,7 +44,7 @@ #:fake-key-event #:grab-control))
-(in-package :xtest) +(in-package #:xlib/xtest)
(define-extension "XTEST")
===================================== src/clx/xvidmode.lisp → src/clx/extensions/xvidmode.lisp ===================================== --- a/src/clx/xvidmode.lisp +++ b/src/clx/extensions/xvidmode.lisp @@ -35,9 +35,6 @@ ;;; constructed as well as to indentify any obsolete/wrong ;;; functions I made.
-#+cmu -(ext:file-comment "$Id: xvidmode.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib)
(export '(mode-info @@ -176,6 +173,14 @@ (error "screen ~A not found in display ~A" screen display) position)))
+(declaim (inline __card32->card16__)) +(defun __card32->card16__ (i) + (declare (type card32 i)) + #+clx-little-endian + (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) + #-clx-little-endian + (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; public XFree86-VidMode Extension routines ;;;; @@ -723,11 +728,3 @@ x and y keyword parameters value (zero will be theire default value)." (setf (svref v (incf index)) w1 (svref v (incf index)) w2)))) v))) - -(declaim (inline __card32->card16__)) -(defun __card32->card16__ (i) - (declare (type card32 i)) - #+clx-little-endian - (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) - #-clx-little-endian - (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i))))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/c8ebc741ea5a442b55d13170d...
--- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/c8ebc741ea5a442b55d13170d... You're receiving this email because of your account on gitlab.common-lisp.net.