[Git][cmucl/cmucl][rtoy-update-clx] 2 commits: Move these files extensions dir to match upstream clx.
Raymond Toy
rtoy at common-lisp.net
Sat Jan 27 17:08:32 UTC 2018
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 at 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/c8ebc741ea5a442b55d13170d211904f57857445...e6f4c98036881c82ea2b6c9542f1f59474e101e9
---
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/c8ebc741ea5a442b55d13170d211904f57857445...e6f4c98036881c82ea2b6c9542f1f59474e101e9
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20180127/02ac5f66/attachment-0001.html>
More information about the cmucl-cvs
mailing list