[Ecls-list] [PATCH] Sync CLX to crhodes darcs tree at http://common-lisp.net/~crhodes/clx. Add extensions to build process.
Julian Stecklina
js at alien8.de
Sun Mar 14 17:27:05 UTC 2010
---
src/clx/clx.asd | 4 +-
src/clx/demo/hello.lisp | 4 +-
src/clx/screensaver.lisp | 69 ++++++++++++++++++++++++++++++++++
src/clx/text.lisp | 27 ++++++-------
src/clx/xinerama.lisp | 93 ++++++++++++++++++++++++++++++++++++++++++++++
src/clx/xrender.lisp | 4 +-
src/compile.lsp.in | 10 +++++
7 files changed, 191 insertions(+), 20 deletions(-)
create mode 100644 src/clx/screensaver.lisp
create mode 100644 src/clx/xinerama.lisp
diff --git a/src/clx/clx.asd b/src/clx/clx.asd
index e83e611..a1ad6fb 100644
--- a/src/clx/clx.asd
+++ b/src/clx/clx.asd
@@ -74,7 +74,9 @@
(:file "glx")
(:file "gl" :depends-on ("glx"))
(:file "dpms")
- (:file "xtest")))
+ (:file "xtest")
+ (:file "screensaver")
+ (:file "xinerama")))
(:module demo
:default-component-class example-source-file
:components
diff --git a/src/clx/demo/hello.lisp b/src/clx/demo/hello.lisp
index 8b1a710..a3fbd88 100644
--- a/src/clx/demo/hello.lisp
+++ b/src/clx/demo/hello.lisp
@@ -2,13 +2,13 @@
(in-package :xlib)
-(defun hello-world (&optional host &rest args &key (string "Hello World") (font "fixed"))
+(defun hello-world (host &rest args &key (string "Hello World") (font "fixed"))
;; CLX demo, says STRING using FONT in its own window on HOST
(let ((display nil)
(abort t))
(unwind-protect
(progn
- (setq display (if host (open-display host) (open-default-display)))
+ (setq display (open-display host))
(multiple-value-prog1
(let* ((screen (display-default-screen display))
(black (screen-black-pixel screen))
diff --git a/src/clx/screensaver.lisp b/src/clx/screensaver.lisp
new file mode 100644
index 0000000..3605d03
--- /dev/null
+++ b/src/clx/screensaver.lisp
@@ -0,0 +1,69 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*-
+;;; ---------------------------------------------------------------------------
+;;; Title: X11 MIT Screensaver extension
+;;; Created: 2005-08-28 01:41
+;;; Author: Istvan Marko <mi-clx at kismala.com>
+;;; ---------------------------------------------------------------------------
+;;; (c) copyright 2005 by Istvan Marko
+
+;;;
+;;; Permission is granted to any individual or institution to use,
+;;; copy, modify, and distribute this software, provided that this
+;;; complete copyright and permission notice is maintained, intact, in
+;;; all copies and supporting documentation.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+;;;
+
+;;; Description:
+;;;
+;;; This is a partial interface to the MIT-SCREEN-SAVER
+;;; extension. Only the ScreenSaverQueryVersion and
+;;; ScreenSaverQueryInfo requests are implemented because I couldn't
+;;; think of a use for the rest. In fact, the only use I see for this
+;;; extension is screen-saver-get-idle which provides and easy way to
+;;; find out how long has it been since the last keyboard or mouse
+;;; activity.
+
+;;; A description of this extension can be found at
+;;; doc/hardcopy/saver/saver.PS.gz in the X11 distribution.
+
+(in-package :xlib)
+
+(export '(screen-saver-query-version
+ screen-saver-query-info
+ screen-saver-get-idle)
+ :xlib)
+
+(define-extension "MIT-SCREEN-SAVER")
+
+(defun screen-saver-query-version (display)
+ (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER")
+ nil)
+ ((data 0)
+ (card8 1) ;client major version
+ (card8 0) ;client minor version
+ (card16 0)) ; unused
+ (values
+ (card16-get 8) ; server major version
+ (card16-get 10)))) ; server minor version
+
+(defun screen-saver-query-info (display drawable)
+ (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER")
+ nil)
+ ((data 1)
+ (drawable drawable))
+ (values
+ (card8-get 1) ; state: off, on, disabled
+ (window-get 8) ; screen saver window if active
+ (card32-get 12) ; tilorsince msecs. how soon before the screen saver kicks in or how long has it been active
+ (card32-get 16) ; idle msecs
+ (card8-get 24)))) ; kind: Blanked, Internal, External
+
+(defun screen-saver-get-idle (display drawable)
+ "How long has it been since the last keyboard or mouse input"
+ (multiple-value-bind (state window tilorsince idle kind) (screen-saver-query-info display drawable)
+ (declare (ignore state window kind))
+ (values idle tilorsince)))
diff --git a/src/clx/text.lisp b/src/clx/text.lisp
index 8eb6af4..08c9973 100644
--- a/src/clx/text.lisp
+++ b/src/clx/text.lisp
@@ -70,8 +70,8 @@
(inline graphic-char-p))
(declare (clx-values integer (or null integer font) (or null integer)))
- (let ((min-char-index (xlib:font-min-char font))
- (max-char-index (xlib:font-max-char font)))
+ (let ((min-char-index (and font (xlib:font-min-char font)))
+ (max-char-index (and font (xlib:font-max-char font))))
(if (stringp src)
(do ((i src-start (index+ i 1))
(j dst-start (index+ j 1))
@@ -80,7 +80,7 @@
i)
(declare (type array-index i j))
(setf char (char->card8 (char src i)))
- (if (or (< char min-char-index) (> char max-char-index))
+ (if (and font (or (< char min-char-index) (> char max-char-index)))
(return i)
(setf (aref dst j) char)))
(do ((i src-start (index+ i 1))
@@ -92,8 +92,9 @@
(setq elt (elt src i))
(when (characterp elt) (setq elt (char->card8 elt)))
(if (or (not (integerp elt))
- (< elt min-char-index)
- (> elt max-char-index))
+ (and font
+ (< elt min-char-index)
+ (> elt max-char-index)))
(return i)
(setf (aref dst j) elt))))))
@@ -478,7 +479,7 @@
(setf (aref vector 0) elt)
(multiple-value-bind (new-start new-font translate-width)
(funcall (or translate #'translate-default)
- vector 0 1 (gcontext-font gcontext t) vector 1)
+ vector 0 1 (gcontext-font gcontext nil) vector 1)
;; Allow translate to set a new font
(when (type? new-font 'font)
(setf (gcontext-font gcontext) new-font)
@@ -549,8 +550,7 @@
(length (index- src-end src-start))
(request-length (* length 2)) ; Leave lots of room for font shifts.
(display (gcontext-display gcontext))
- ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
- (font (gcontext-font gcontext t)))
+ (font (gcontext-font gcontext nil)))
(declare (type array-index src-start src-end length)
(type (or null array-index) next-start)
(type display display))
@@ -652,8 +652,7 @@
(length (index- src-end src-start))
(request-length (* length 3)) ; Leave lots of room for font shifts.
(display (gcontext-display gcontext))
- ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
- (font (gcontext-font gcontext t))
+ (font (gcontext-font gcontext nil))
(buffer (display-tbuf16 display)))
(declare (type array-index src-start src-end length)
(type (or null array-index) next-start)
@@ -759,7 +758,7 @@
(setf (aref vector 0) elt)
(multiple-value-bind (new-start new-font translate-width)
(funcall (or translate #'translate-default)
- vector 0 1 (gcontext-font gcontext t) vector 1)
+ vector 0 1 (gcontext-font gcontext nil) vector 1)
;; Allow translate to set a new font
(when (type? new-font 'font)
(setf (gcontext-font gcontext) new-font)
@@ -836,8 +835,7 @@
(declare (clx-values (or null array-index) (or null int32)))
(do* ((display (gcontext-display gcontext))
(length (index- end start))
- ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
- (font (gcontext-font gcontext t))
+ (font (gcontext-font gcontext nil))
(font-change nil)
(new-start) (translated-width) (chunk))
(nil) ;; forever
@@ -902,8 +900,7 @@
(declare (clx-values (or null array-index) (or null int32)))
(do* ((display (gcontext-display gcontext))
(length (index- end start))
- ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
- (font (gcontext-font gcontext t))
+ (font (gcontext-font gcontext nil))
(font-change nil)
(new-start) (translated-width) (chunk)
(buffer (buffer-tbuf16 display)))
diff --git a/src/clx/xinerama.lisp b/src/clx/xinerama.lisp
new file mode 100644
index 0000000..ee688e6
--- /dev/null
+++ b/src/clx/xinerama.lisp
@@ -0,0 +1,93 @@
+;;; -*- Mode: Lisp -*-
+;;;
+;;; Copyright (C) 2008, Julian Stecklina
+;;;
+;;; ((
+;;; )) This file is COFFEEWARE. As long as you retain this notice
+;;; | |o) you can do whatever you want with this code. If you think,
+;;; |___|jgs it's worth it, you may buy the author a coffee in return.
+;;;
+;;; Description:
+;;;
+;;; This is an implementation of the XINERAMA extension. It does not
+;;; include the obsolete PanoramiX calls.
+
+(defpackage "XLIB.XINERAMA"
+ (:use "COMMON-LISP" "XLIB")
+ (:nicknames "XINERAMA")
+ (:import-from "XLIB"
+ "WITH-BUFFER-REQUEST"
+ "WITH-BUFFER-REQUEST-AND-REPLY"
+ "DATA"
+ "BOOLEAN" "BOOLEAN-GET"
+ "CARD8" "CARD8-GET"
+ "CARD16" "CARD16-GET"
+ "CARD32" "CARD32-GET"
+ "INT16" "INT16-GET")
+ (:export "SCREEN-INFO"
+ "SCREEN-INFO-NUMBER"
+ "SCREEN-INFO-X"
+ "SCREEN-INFO-Y"
+ "SCREEN-INFO-WIDTH"
+ "SCREEN-INFO-HEIGHT"
+ "XINERAMA-QUERY-VERSION"
+ "XINERAMA-IS-ACTIVE"
+ "XINERAMA-QUERY-SCREENS"))
+(in-package "XINERAMA")
+
+(define-extension "XINERAMA")
+
+(defun xinerama-opcode (display)
+ (extension-opcode display "XINERAMA"))
+
+(defconstant +major-version+ 1)
+(defconstant +minor-version+ 1)
+
+(defconstant +get-version+ 0)
+(defconstant +get-state+ 1)
+(defconstant +get-screen-count+ 2)
+(defconstant +get-screen-size+ 3)
+(defconstant +is-active+ 4)
+(defconstant +query-screens+ 5)
+
+(defstruct screen-info
+ (number 0 :type (unsigned-byte 32))
+ (x 0 :type (signed-byte 16))
+ (y 0 :type (signed-byte 16))
+ (width 0 :type (unsigned-byte 16))
+ (height 0 :type (unsigned-byte 16)))
+
+(defun xinerama-query-version (display)
+ (with-buffer-request-and-reply (display (xinerama-opcode display) nil)
+ ((data +get-version+)
+ (card8 +major-version+)
+ (card8 +minor-version+))
+ (values
+ (card16-get 8) ; server major version
+ (card16-get 10)))) ; server minor version
+
+(defun xinerama-is-active (display)
+ "Returns T, iff Xinerama is supported and active."
+ (with-buffer-request-and-reply (display (xinerama-opcode display) nil)
+ ((data +is-active+))
+ (values
+ ;; XCB says this is actually a CARD32, but why?!
+ (boolean-get 8))))
+
+(defun xinerama-query-screens (display)
+ "Returns a list of screen-info structures."
+ (with-buffer-request-and-reply (display (xinerama-opcode display) nil)
+ ((data +query-screens+))
+ (values
+ (loop
+ with index = 32
+ for number from 0 below (card32-get 8)
+ collect (prog1
+ (make-screen-info :number number
+ :x (int16-get index)
+ :y (int16-get (+ index 2))
+ :width (card16-get (+ index 4))
+ :height (card16-get (+ index 6)))
+ (incf index 8))))))
+
+;;; EOF
diff --git a/src/clx/xrender.lisp b/src/clx/xrender.lisp
index 9f6f94e..bb605da 100644
--- a/src/clx/xrender.lisp
+++ b/src/clx/xrender.lisp
@@ -704,7 +704,7 @@ by every function, which attempts to generate RENDER requests."
)
||#
-(defun render-trapezoids-1 (picture op source src-x src-y format coord-sequence)
+(defun render-trapezoids-1 (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 ...
@@ -719,7 +719,7 @@ by every function, which attempts to generate RENDER requests."
(card16 0) ;pad
(resource-id (picture-id source))
(resource-id (picture-id picture))
- (picture-format format)
+ ((or (member :none) picture-format) mask-format)
(int16 src-x)
(int16 src-y)
((sequence :format int32) coord-sequence) )))
diff --git a/src/compile.lsp.in b/src/compile.lsp.in
index e699de9..ec3bd10 100755
--- a/src/compile.lsp.in
+++ b/src/compile.lsp.in
@@ -260,6 +260,16 @@
"src:clx;manager.lisp"
"src:clx;image.lisp"
"src:clx;resource.lisp"
+ "src:clx;shape.lisp"
+ "src:clx;big-requests.lisp"
+ "src:clx;xvidmode.lisp"
+ "src:clx;xrender.lisp"
+ "src:clx;glx.lisp"
+ "src:clx;gl.lisp"
+ "src:clx;dpms.lisp"
+ "src:clx;xtest.lisp"
+ "src:clx;screensaver.lisp"
+ "src:clx;xinerama.lisp"
"build:clx;module.lisp"))
#+:msvc
(c::*cc-flags* (concatenate 'string c::*cc-flags* " -Zm150")))
--
1.6.4.4
More information about the ecl-devel
mailing list