diff --git a/clx/CHANGES b/clx/CHANGES index f666fdff88dc6cbca78e54a546c9aee0abf6f6f8..0171f5678e86bdd89374425a129bf05c9ec15c60 100644 --- a/clx/CHANGES +++ b/clx/CHANGES @@ -1,4 +1,4 @@ -$Id: CHANGES,v 1.6 2007/08/21 15:49:27 fgilham Exp $ +$Id: CHANGES,v 1.7 2009/06/17 18:22:45 rtoy Rel $ Details of changes since R5: diff --git a/clx/NEWS b/clx/NEWS index 20aa5ac9dab7136af6134a80cc9da4eb118edaf1..53e339902d5b1c814d84861d1808f3ea0776dd56 100644 --- a/clx/NEWS +++ b/clx/NEWS @@ -1,11 +1,11 @@ -*- Text -*- -$Id: NEWS,v 1.2 2009/06/11 16:03:56 rtoy Exp $ +$Id: NEWS,v 1.3 2009/06/17 18:22:45 rtoy Rel $ -- Changes in telent CLX 0.7.3, Tue Mar 28 2006 --- Support for Allegro CL (6.2 and later) (Mikel Evins) Latin 1 keysyms (Christophe Rhodes) Some protocol fixes (Douglas Crosher) -Define a RENDER-OP type (Douglas Crosher) +Define a RENDER-OP typ (Douglas Crosher) --- Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 --- @@ -56,7 +56,7 @@ has been included in demo/clipboard.lisp Bug fix: change the sizes of certain fields in a WM-SIZE-HINT to be 32 bits wide, as per the ICCCM specifications. Fixes a problem seen with -the MacOS X11 window manager, that uses very large hint values. +the MacOS X11 window manger, that uses very large hint values. (Patch from Eric Marsden) Bug fix: +POINTER-EVENT-MASK-VECTOR+ is supposed to be a vector of @@ -69,7 +69,7 @@ Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS* A change in the implementation of PROCESS-BLOCK and PROCESS-WAKEUP under multithreaded SBCL. Previous versions used queues and condition -variables, but this seems to have undesirable performance +variables, but this seems to have undesireable performance characteristics; the newer version uses a polling loop calling sched_yield() inside, which greatly improves responsiveness, but is more CPU-hungry (as perceived by top(1), at least; in theory it @@ -150,7 +150,7 @@ Implement CLX MP dependencies for SBCL: HOLDING-LOCK, PROCESS-BLOCK, etc Many bug fixes - * asking for text extents on uncached fonts could potentially deadlock + * asking for text extents on unchached fonts could potentially deadlock http://article.gmane.org/gmane.lisp.clx.devel/16 * lots of compiler warnings, style-warnings, notes cleared up @@ -160,5 +160,6 @@ Style and ANSI cleanups * Much renaming of constants from *foo* to +foo+ - * Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL - :LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs. + * Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL + :LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs. + diff --git a/clx/README b/clx/README index aa4cab7fa830dbc7b5324e123e7bb28d55f1b5ae..c24dc6853d740e5bc9f6dd75a7bbc908cd543fb8 100644 --- a/clx/README +++ b/clx/README @@ -1,4 +1,4 @@ -$Id: README,v 1.5 2009/06/11 16:03:56 rtoy Exp $ +$Id: README,v 1.6 2009/06/17 18:22:45 rtoy Rel $ This directory contains CLX, an X11 client library for Common Lisp. The code was originally taken from a CMUCL distribution, was modified somewhat in order to make it compile and run under SBCL, then @@ -38,7 +38,7 @@ your bug has been fixed already. darcs get http://verisons.telent.net/clx # version from which releases are made http://common-lisp.net/~crhodes/clx # patches merged by Christophe - http://monday-monkey.com/repos/clx/ # OpenMCL tree by Bryan O'Connor? + http://monday-monkey.com/repos/clx/ # OpenMCL tree by bryan o'connor? = Building using asdf-install diff --git a/clx/README-R5 b/clx/README-R5 index d6e7b895f6d905614aff194fc24c44b38446da99..85440b539768c21f7347aa7530ffcce383b2de30 100644 --- a/clx/README-R5 +++ b/clx/README-R5 @@ -1,4 +1,4 @@ -$Id: README-R5,v 1.1 2007/08/21 15:49:27 fgilham Exp $ +$Id: README-R5,v 1.2 2009/06/17 18:22:45 rtoy Rel $ Original CLX README, retained for historical information --- diff --git a/clx/attributes.lisp b/clx/attributes.lisp index ae042013907574fa5733dfc6f204aedf97445540..c4a92d023f48eed19512595746af1a617d12693e 100644 --- a/clx/attributes.lisp +++ b/clx/attributes.lisp @@ -41,7 +41,7 @@ ;;; the new drawable. The caches are initialized to NIL and allocated as needed. #+cmu -(ext:file-comment "$Id: attributes.lisp,v 1.7 2007/08/21 15:49:27 fgilham Exp $") +(ext:file-comment "$Id: attributes.lisp,v 1.8 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) @@ -69,14 +69,14 @@ (defmacro state-geometry-changes (state) `(fifth ,state)) (defmacro drawable-equal-function () - (if (member 'drawable +clx-cached-types+) - ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's - ''drawable-equal)) + ;; Since drawables are not always cached, we must use drawable-equal + ;; to determine equality. + ''drawable-equal) (defmacro window-equal-function () - (if (member 'window +clx-cached-types+) - ''eq - ''drawable-equal)) + ;; Since windows are not always cached, we must use window-equal + ;; to determine equality. + ''window-equal) (defmacro with-state ((drawable) &body body) ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes @@ -498,8 +498,13 @@ (declare (clx-values (or null colormap))) (with-attributes (window :sizes 32) (let ((id (resource-id-get 28))) - (if (zerop id) nil - (lookup-colormap (window-display window) id))))) + (if (zerop id) + nil + (let ((colormap (lookup-colormap (window-display window) id))) + (unless (colormap-visual-info colormap) + (setf (colormap-visual-info colormap) + (visual-info (window-display window) (resource-id-get 8)))) + colormap))))) (defun set-window-colormap (window colormap) (change-window-attribute diff --git a/clx/big-requests.lisp b/clx/big-requests.lisp index 882691e6a13edb76058874d17154bfd8102a9500..a854866a350479932e228110cf3f2bc99ccfb50b 100644 --- a/clx/big-requests.lisp +++ b/clx/big-requests.lisp @@ -13,7 +13,7 @@ ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. #+cmu -(ext:file-comment "$Id: big-requests.lisp,v 1.1 2007/08/21 15:49:27 fgilham Exp $") +(ext:file-comment "$Id: big-requests.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") (in-package "XLIB") diff --git a/clx/buffer.lisp b/clx/buffer.lisp index f79f2b5cbf58d766314e73bdc754de3ae4b52e32..a5a38889658d2002da194d2611999bae236cf621 100644 --- a/clx/buffer.lisp +++ b/clx/buffer.lisp @@ -50,7 +50,7 @@ ;; request won't be left after aborts (e.g. control-abort on a lispm). #+cmu -(ext:file-comment "$Id: buffer.lisp,v 1.9 2007/08/21 15:49:27 fgilham Exp $") +(ext:file-comment "$Id: buffer.lisp,v 1.10 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp index 471fe8ebe117860dac158b33bdc5308dbaab14d1..a2cbcd938d64f09ea781f96917766ca6e40a1ff5 100644 --- a/clx/bufmac.lisp +++ b/clx/bufmac.lisp @@ -20,7 +20,7 @@ ;;; #+cmu -(ext:file-comment "$Id: bufmac.lisp,v 1.5 2007/08/21 15:49:27 fgilham Exp $") +(ext:file-comment "$Id: bufmac.lisp,v 1.6 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) diff --git a/clx/build-clx.lisp b/clx/build-clx.lisp index a280963f9767f11a2b3828b6ccc5d5c20da1afc1..cb8ccddaa149d397a915d60f6d83af6ad8cee811 100644 --- a/clx/build-clx.lisp +++ b/clx/build-clx.lisp @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- #+cmu -(ext:file-comment "$Id: build-clx.lisp,v 1.4 2007/08/21 15:49:27 fgilham Exp $") +(ext:file-comment "$Id: build-clx.lisp,v 1.5 2009/06/17 18:22:45 rtoy Rel $") ;;; Load this file if you want to compile CLX in its entirety. (proclaim '(optimize (speed 3) (safety 1) (space 1) diff --git a/clx/clx-module.lisp b/clx/clx-module.lisp index da96ee216a81535358a1fecd1a09ebfbf94728ce..903e1ef2222e1157a24cb7e23e2a9d6d868de6dd 100644 --- a/clx/clx-module.lisp +++ b/clx/clx-module.lisp @@ -2,7 +2,7 @@ ;;;(common-lisp:use-package (list :common-lisp)) #+cmu -(ext:file-comment "$Id: clx-module.lisp,v 1.1 2007/08/21 15:49:27 fgilham Exp $") +(ext:file-comment "$Id: clx-module.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") (provide :clx) (load "clx:defsystem.lisp") diff --git a/clx/clx.asd b/clx/clx.asd new file mode 100644 index 0000000000000000000000000000000000000000..a1ad6fbef6876e3016b4b229510c6dcf9a05d287 --- /dev/null +++ b/clx/clx.asd @@ -0,0 +1,216 @@ +;;; -*- Lisp -*- mode + +;;; Original copyright message from defsystem.lisp: + +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. +;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. +;;; +;;; 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. +;;; +;;; Texas Instruments Incorporated provides this software "as is" +;;; without express or implied warranty. +;;; +;;; Franz Incorporated provides this software "as is" without express +;;; or implied warranty. + +(defpackage :clx-system (:use :cl :asdf)) +(in-package :clx-system) + +(pushnew :clx-ansi-common-lisp *features*) + +(defclass clx-source-file (cl-source-file) ()) +(defclass xrender-source-file (clx-source-file) ()) + +;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of +;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-) +(defclass example-source-file (cl-source-file) ()) + +(defclass legacy-file (static-file) ()) + +(defsystem CLX + :depends-on (#+sbcl sb-bsd-sockets) + :version "0.7.2" + :serial t + :default-component-class clx-source-file + :components + ((:file "package") + (:file "depdefs") + (:file "clx") + #-(or openmcl allegro) (:file "dependent") + #+openmcl (:file "dep-openmcl") + #+allegro (:file "dep-allegro") + (:file "macros") + (:file "bufmac") + (:file "buffer") + (:file "display") + (:file "gcontext") + (:file "input") + (:file "requests") + (:file "fonts") + (:file "graphics") + (:file "text") + (:file "attributes") + (:file "translate") + (:file "keysyms") + (:file "manager") + (:file "image") + (:file "resource") + #+allegro + (:file "excldep" :pathname "excldep.lisp") + (:module extensions + :pathname #.(make-pathname :directory '(:relative)) + :components + ((:file "shape") + (:file "big-requests") + (:file "xvidmode") + (:xrender-source-file "xrender") + (:file "glx") + (:file "gl" :depends-on ("glx")) + (:file "dpms") + (:file "xtest") + (:file "screensaver") + (:file "xinerama"))) + (:module demo + :default-component-class example-source-file + :components + ((:file "bezier") + ;; KLUDGE: this requires "bezier" for proper operation, + ;; but we don't declare that dependency here, because + ;; asdf doesn't load example files anyway. + (:file "beziertest") + (:file "clclock") + (:file "clipboard") + (:file "clx-demos") + (:file "gl-test") + ;; FIXME: compiling this generates 30-odd spurious code + ;; deletion notes. Find out why, and either fix or + ;; workaround the problem. + (:file "mandel") + (:file "menu") + (:file "zoid"))) + (:module test + :default-component-class example-source-file + :components + ((:file "image") + ;; KLUDGE: again, this depends on "zoid" + (:file "trapezoid"))) + (:static-file "NEWS") + (:static-file "CHANGES") + (:static-file "README") + (:static-file "README-R5") + (:legacy-file "exclMakefile") + (:legacy-file "exclREADME") + (:legacy-file "exclcmac" :pathname "exclcmac.lisp") + (:legacy-file "excldepc" :pathname "excldep.c") + (:legacy-file "sockcl" :pathname "sockcl.lisp") + (:legacy-file "socket" :pathname "socket.c") + (:legacy-file "defsystem" :pathname "defsystem.lisp") + (:legacy-file "provide" :pathname "provide.lisp") + (:legacy-file "cmudep" :pathname "cmudep.lisp") + (:module manual + ;; TODO: teach asdf how to process texinfo files + :components ((:static-file "clx.texinfo"))) + (:module debug + :default-component-class legacy-file + :components + ((:file "debug" :pathname "debug.lisp") + (:file "describe" :pathname "describe.lisp") + (:file "event-test" :pathname "event-test.lisp") + (:file "keytrans" :pathname "keytrans.lisp") + (:file "trace" :pathname "trace.lisp") + (:file "util" :pathname "util.lisp"))))) + +(defmethod perform ((o load-op) (f example-source-file)) + ;; do nothing. We want to compile them when CLX is compiled, but + ;; not load them when CLX is loaded. + t) + +#+sbcl +(defmethod perform :around ((o compile-op) (f xrender-source-file)) + ;; RENDER would appear to be an inherently slow protocol; further, + ;; it's not set in stone, and consequently we care less about speed + ;; than we do about correctness. + (handler-bind ((sb-ext:compiler-note #'muffle-warning)) + (call-next-method))) + +#+sbcl +(defmethod perform :around ((o compile-op) (f clx-source-file)) + ;; our CLX library should compile without WARNINGs, and ideally + ;; without STYLE-WARNINGs. Since it currently does, let's enforce + ;; it here so that we can catch regressions easily. + (let ((on-warnings (operation-on-warnings o)) + (on-failure (operation-on-failure o))) + (unwind-protect + (progn + (setf (operation-on-warnings o) :error + (operation-on-failure o) :error) + ;; a variety of accessors, such as AREF-CARD32, are not + ;; declared INLINE. Without this (non-ANSI) + ;; static-type-inference behaviour, SBCL emits an extra 100 + ;; optimization notes (roughly one fifth of all of the + ;; notes emitted). Since the internals are unlikely to + ;; change much, and certainly the internals should stay in + ;; sync, enabling this extension is a win. (Note that the + ;; use of this does not imply that applications using CLX + ;; calls that expand into calls to these accessors will be + ;; optimized in the same way). + (let ((sb-ext:*derive-function-types* t) + (sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c)) + (sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext))) + ;; deeply unportable stuff, this. I will be shot. We + ;; want to enable the dynamic-extent declarations in CLX. + (when (and sadx (sb-c::policy-quality-name-p sadx)) + ;; no way of setting it back short of yet more yukky stuff + (proclaim `(optimize (,sadx 3)))) + (if sadx-var + (progv (list sadx-var) (list t) + (call-next-method)) + (call-next-method)))) + (setf (operation-on-warnings o) on-warnings + (operation-on-failure o) on-failure)))) + +#+sbcl +(defmethod perform :around (o (f clx-source-file)) + ;; SBCL signals an error if DEFCONSTANT is asked to redefine a + ;; constant unEQLly. For CLX's purposes, however, we are defining + ;; structured constants (lists and arrays) not for EQLity, but for + ;; the purposes of constant-folding operations such as (MEMBER FOO + ;; +BAR+), so it is safe to abort the redefinition provided the + ;; structured data is sufficiently equal. + (handler-bind + ((sb-ext:defconstant-uneql + (lambda (c) + ;; KLUDGE: this really means "don't warn me about + ;; efficiency of generic array access, please" + (declare (optimize (sb-ext:inhibit-warnings 3))) + (let ((old (sb-ext:defconstant-uneql-old-value c)) + (new (sb-ext:defconstant-uneql-new-value c))) + (typecase old + (list (when (equal old new) (abort c))) + (string (when (and (typep new 'string) + (string= old new)) + (abort c))) + (simple-vector + (when (and (typep new 'simple-vector) + (= (length old) (length new)) + (every #'eql old new)) + (abort c))) + (array + (when (and (typep new 'array) + (equal (array-dimensions old) + (array-dimensions new)) + (equal (array-element-type old) + (array-element-type new)) + (dotimes (i (array-total-size old) t) + (unless (eql (row-major-aref old i) + (row-major-aref new i)) + (return nil)))) + (abort c)))))))) + (call-next-method))) diff --git a/clx/clx.lisp b/clx/clx.lisp index 3cde49313f62658bd3db4684e48c45d2945c8c70..02c18f62f56fd84607f5bd1b037ea6d22dbb6475 100644 --- a/clx/clx.lisp +++ b/clx/clx.lisp @@ -77,7 +77,7 @@ ;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu. #+cmu -(ext:file-comment "$Id: clx.lisp,v 1.15 2007/08/21 15:49:27 fgilham Exp $") +(ext:file-comment "$Id: clx.lisp,v 1.16 2009/06/17 18:22:45 rtoy Rel $") ;; Note: all of the following is in the package XLIB. @@ -829,19 +829,18 @@ (getf (font-properties font) name)) (macrolet ((make-mumble-equal (type) - ;; When cached, EQ works fine, otherwise test resource id's and displays + ;; Since caching is only done for objects created by the + ;; client, we must always compare ID and display for + ;; non-identical mumbles. (let ((predicate (xintern type '-equal)) (id (xintern type '-id)) (dpy (xintern type '-display))) - (if (member type +clx-cached-types+) - `(within-definition (,type make-mumble-equal) - (declaim (inline ,predicate)) - (defun ,predicate (a b) (eq a b))) - `(within-definition (,type make-mumble-equal) - (defun ,predicate (a b) - (declare (type ,type a b)) - (and (= (,id a) (,id b)) - (eq (,dpy a) (,dpy b))))))))) + `(within-definition (,type make-mumble-equal) + (defun ,predicate (a b) + (declare (type ,type a b)) + (or (eql a b) + (and (= (,id a) (,id b)) + (eq (,dpy a) (,dpy b))))))))) (make-mumble-equal window) (make-mumble-equal pixmap) (make-mumble-equal cursor) diff --git a/clx/debug/debug.lisp b/clx/debug/debug.lisp index 82e4e38c55b5c711e925d1c90d8e7ab28b743898..7f5f11b8c429c9529bacdf12c09dbd4bff8c87f9 100644 --- a/clx/debug/debug.lisp +++ b/clx/debug/debug.lisp @@ -21,7 +21,7 @@ ;;; Created 04/09/87 14:30:41 by LaMott G. OREN #+cmu -(ext:file-comment "$Id: debug.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: debug.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/debug/describe.lisp b/clx/debug/describe.lisp index 404786f99ebfdc304b8d339586850f945b41369a..d543e80a722b55c3e54bfc3e1f4b1dae3faf7af6 100644 --- a/clx/debug/describe.lisp +++ b/clx/debug/describe.lisp @@ -21,7 +21,7 @@ ;;; Created 07/15/87 by LaMott G. OREN #cmu -(ext:file-comment "$Id: describe.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: describe.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -79,7 +79,7 @@ (string8 (format t " Bytes:~%~v@t" margin) (dotimes (k (- length (- j start))) - (format t "~a" (code-char (card8-get j))) + (format t "~a" (int-char (card8-get j))) (incf j))) (otherwise (format t " Bytes:~%~v@t" margin) diff --git a/clx/debug/event-test.lisp b/clx/debug/event-test.lisp index 8d6320873501f421c87ce0a4c6172f773248e1b1..bc08bd53568600e873e046414a0e9e414969a5c1 100644 --- a/clx/debug/event-test.lisp +++ b/clx/debug/event-test.lisp @@ -3,7 +3,7 @@ ;;; This code was intended for CLUE. --FMG #+cmu -(ext:file-comment "$Id: event-test.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: event-test.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (defpackage "XTEST" (:use :xlib :common-lisp) diff --git a/clx/debug/keytrans.lisp b/clx/debug/keytrans.lisp index 44db61c76c01609067a831ab9c5f1fad2086cd2c..fcba36033a16d09eaad2ee9c9a72817b24ab1ce4 100644 --- a/clx/debug/keytrans.lisp +++ b/clx/debug/keytrans.lisp @@ -19,22 +19,22 @@ ;;; #+cmu -(ext:file-comment "$Id: keytrans.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: keytrans.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defun list-missing-keysyms () ;; Lists explorer characters which have no keysyms (dotimes (i 256) - (unless (character->keysyms (code-char i)) - (format t "~%(define-keysym ~@c ~d)" (code-char i) i)))) + (unless (character->keysyms (int-char i)) + (format t "~%(define-keysym ~@c ~d)" (int-char i) i)))) (defun list-multiple-keysyms () ;; Lists characters with more than one keysym (dotimes (i 256) - (when (cdr (character->keysyms (code-char i))) - (format t "~%Character ~@c [~d] has keysyms" (code-char i) i) - (dolist (keysym (character->keysyms (code-char i))) + (when (cdr (character->keysyms (int-char i))) + (format t "~%Character ~@c [~d] has keysyms" (int-char i) i) + (dolist (keysym (character->keysyms (int-char i))) (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) (defun check-lowercase-keysyms () @@ -55,7 +55,7 @@ char (and lowercase (ldb (byte 8 8) lowercase)) (and lowercase (ldb (byte 8 0) lowercase)) - (code-char lowercase) + (int-char lowercase) (ldb (byte 8 8) (char-int should-be)) (ldb (byte 8 0) (char-int should-be)) should-be))) diff --git a/clx/debug/trace.lisp b/clx/debug/trace.lisp index 364a3f0f9ed4f06ee089687dc980410547af992e..dc0aa70d0348c191d5762724e30b33ce7b2fbcbf 100644 --- a/clx/debug/trace.lisp +++ b/clx/debug/trace.lisp @@ -33,7 +33,7 @@ ;;; Created 09/14/87 by LaMott G. OREN #+cmu -(ext:file-comment "$Id: trace.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: trace.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/debug/util.lisp b/clx/debug/util.lisp index 471be6d4e38fd02ce46d5d3473bd44e0dd1a7bdf..62457ded5e2b43a16c238fa35f398a0ed6981252 100644 --- a/clx/debug/util.lisp +++ b/clx/debug/util.lisp @@ -21,7 +21,7 @@ ;;; Created 04/09/87 14:30:41 by LaMott G. OREN #+cmu -(ext:file-comment "$Id: util.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: util.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -148,13 +148,12 @@ ;; Returns a list of windows in the order that they are printed. (declare (arglist window) (type window window) - (clx-values (list window))) + (values (list window))) (let ((props (mapcar #'(lambda (prop) (multiple-value-bind (data type format) (get-property window prop) (case type - (:string (setq data (map 'string #'code-char data))) - (:utf8_string (setq data (map 'string #'code-char data)))) + (:string (setq data (coerce data 'string)))) (list prop format type data))) (list-properties window))) (result (list window))) diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp index ce67e3f5c97a82948d0f86a777bb4031fa7dce73..ad34fbaa99905d052ea6c8a9c296c4d0d12e97a8 100644 --- a/clx/defsystem.lisp +++ b/clx/defsystem.lisp @@ -34,7 +34,7 @@ ;;; sbcl #+cmu -(ext:file-comment "$Id: defsystem.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: defsystem.lisp,v 1.9 2009/06/17 18:22:45 rtoy Rel $") #+(or Genera Minima sbcl ecl) (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/clx/demo/bezier.lisp b/clx/demo/bezier.lisp index 6028679f36f0ab5c23500b7748f77fae1b27778c..f5776115445a67ab97dfe72a4fa8bbd078dbd9ea 100644 --- a/clx/demo/bezier.lisp +++ b/clx/demo/bezier.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: bezier.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: bezier.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/demo/beziertest.lisp b/clx/demo/beziertest.lisp index 6569fc2b99188df050f12c3f90ba2d7b9284a31c..f564bc9ef86e57efea43980eedec42372a29679e 100644 --- a/clx/demo/beziertest.lisp +++ b/clx/demo/beziertest.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: beziertest.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: beziertest.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -60,11 +60,11 @@ ;; we don't need to worry about overflows. (let ((factor (ash (min width height) 5))) (dotimes (i (length lines)) - (setf (svref lines i) - (ash (* (svref lines i) factor) -16))) + (setf (aref lines i) + (ash (* (aref lines i) factor) -16))) (dotimes (i (length curves)) - (setf (svref curves i) - (ash (* (svref curves i) factor) -16)))) + (setf (aref curves i) + (ash (* (aref curves i) factor) -16)))) (map-window win) ; Map the window ;; Handle events diff --git a/clx/demo/clclock.lisp b/clx/demo/clclock.lisp index 9ad9a8b7ac60b11be9a26ae2161d3cdfa9030341..bf9db76b09fdad101e69236bdd8f4a59445e527d 100644 --- a/clx/demo/clclock.lisp +++ b/clx/demo/clclock.lisp @@ -1,5 +1,5 @@ #+cmu -(ext:file-comment "$Id: clclock.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: clclock.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage "XCLCLOCK" (:use "CL") diff --git a/clx/demo/clipboard.lisp b/clx/demo/clipboard.lisp index 19c50581226b7e3b5aff2bec92208df6ef80c35b..c544a09d600d47d115fdb228e34ff77dd243f30f 100644 --- a/clx/demo/clipboard.lisp +++ b/clx/demo/clipboard.lisp @@ -60,7 +60,7 @@ ;;; DEALINGS IN THE SOFTWARE. #+cmu -(ext:file-comment "$Id: clipboard.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: clipboard.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage "CLIPBOARD" (:use "CL" "XLIB") diff --git a/clx/demo/clx-demos.lisp b/clx/demo/clx-demos.lisp index 442b82e7a8e33240095062c40e3235139481d239..4f08d8d5f0f63179fd6c8b38209da1428fd9a26a 100644 --- a/clx/demo/clx-demos.lisp +++ b/clx/demo/clx-demos.lisp @@ -7,7 +7,7 @@ ;;; #+cmu -(ext:file-comment "$Id: clx-demos.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: clx-demos.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage :demos (:use :common-lisp) (:export do-all-demos demo)) @@ -32,17 +32,14 @@ (defvar *white-pixel* nil) (defvar *window* nil) -(defvar *delay* .01) ; This is necessary on current hardware to make the demos run slow enough - ; to actually see something. - (defmacro defdemo (fun-name demo-name args x y width height doc &rest forms) `(progn (defun ,fun-name ,args ,doc (unless *display* -;; #+:cmu -;; (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or cmu sbcl allegro) + #+:cmu + (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) + #+(or sbcl allegro clisp) (progn (setf *display* (xlib::open-default-display)) (setf *screen* (xlib:display-default-screen *display*))) @@ -174,8 +171,7 @@ (+ 4 (random (truncate width 3))) (+ 4 (random (truncate height 3))) t)) - (xlib:display-force-output *display*) - (sleep *delay*))) + (xlib:display-force-output *display*))) (xlib:free-gcontext gcontext) (xlib:free-pixmap pixmap))) @@ -306,8 +302,7 @@ (setf (svref next-line 1) (+ y1 dy1)) (setf (svref next-line 2) (+ x2 dx2)) (setf (svref next-line 3) (+ y2 dy2)) - (xlib:display-force-output *display*) - (sleep *delay*)))))) + (xlib:display-force-output *display*)))))) (defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) @@ -519,9 +514,7 @@ ,x ,y ,width ,height t)) (defmacro update-screen () - `(progn - (xlib:display-force-output *display*) - (sleep *delay*))) + `(xlib:display-force-output *display*)) ;;;; Moving disks up and down @@ -767,7 +760,7 @@ ;;; velocity since the loop terminates as a function of the y velocity. ;;; (defun bounce-window (window &optional - (x-velocity 0) (elasticity 0.85) (gravity 2)) + (x-velocity 0) (elasticity 0.85) (gravity 2)) (unless (< 0 elasticity 1) (error "Elasticity must be between 0 and 1.")) (unless (plusp gravity) @@ -782,43 +775,41 @@ (declare (fixnum top-of-window-at-bottom left-of-window-at-right y-velocity)) (loop - (when (= prev-neg-velocity 0) (return t)) - (let ((negative-velocity (minusp y-velocity))) - (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (sleep *delay*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) - (when (and negative-velocity (>= y-velocity 0)) - (setf negative-velocity nil)) - (let ((next-x (+ x x-velocity))) - (declare (fixnum next-x)) - (when (or (> next-x left-of-window-at-right) - (< next-x 0)) - (setq x-velocity (- (truncate (* elasticity x-velocity))))) - (setq x next-x)) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (sleep *delay*)))))))) + (when (= prev-neg-velocity 0) (return t)) + (let ((negative-velocity (minusp y-velocity))) + (loop + (let ((next-y (+ y y-velocity)) + (next-y-velocity (+ y-velocity gravity))) + (declare (fixnum next-y next-y-velocity)) + (when (> next-y top-of-window-at-bottom) + (cond + (number-problems + (setf y-velocity (incf prev-neg-velocity))) + (t + (setq y-velocity + (- (truncate (* elasticity y-velocity)))) + (when (= y-velocity prev-neg-velocity) + (incf y-velocity) + (setf number-problems t)) + (setf prev-neg-velocity y-velocity))) + (setf y top-of-window-at-bottom) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*) + (return)) + (setq y-velocity next-y-velocity) + (setq y next-y)) + (when (and negative-velocity (>= y-velocity 0)) + (setf negative-velocity nil)) + (let ((next-x (+ x x-velocity))) + (declare (fixnum next-x)) + (when (or (> next-x left-of-window-at-right) + (< next-x 0)) + (setq x-velocity (- (truncate (* elasticity x-velocity))))) + (setq x next-x)) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*)))))))) ;;; Change the name of this when DEMO is not so stupid. ;;; @@ -932,7 +923,6 @@ (decf y-off (ash y-dir 1)) (setf y-dir (- y-dir)))) (xlib:draw-rectangles window gcontext rectangles t) - (sleep *delay*) (xlib:display-force-output display)))) (xlib:free-gcontext gcontext))) @@ -1053,8 +1043,7 @@ (dotimes (i duration) (dolist (ball balls) (bounce-1-ball bounce-pixmap window gcontext ball)) - (xlib:display-force-output display) - (sleep *delay*)) + (xlib:display-force-output display)) (xlib:free-pixmap bounce-pixmap) (xlib:free-gcontext gcontext)))) diff --git a/clx/demo/gl-test.lisp b/clx/demo/gl-test.lisp index 453433ded05c105bd3e56e24084b394624eea1f2..d9cd3dfda8295bc1626b74c3e734288cd0cbab1c 100644 --- a/clx/demo/gl-test.lisp +++ b/clx/demo/gl-test.lisp @@ -1,5 +1,5 @@ #+cmu -(ext:file-comment "$Id: gl-test.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: gl-test.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage :gl-test (:use :common-lisp :xlib) @@ -8,7 +8,7 @@ (in-package :gl-test) -(defun test (function &key (host "") (display 0) (width 200) (height 200)) +(defun test (function &key (host "localhost") (display 1) (width 200) (height 200)) (let* ((display (open-display host :display display)) (screen (display-default-screen display)) (root (screen-root screen)) diff --git a/clx/demo/hello.lisp b/clx/demo/hello.lisp index b2a273db5fb3eeab46792ace9fbf7f363b80fcc4..8ede2221f134829c59104e50a5a6f3c3368ed1ab 100644 --- a/clx/demo/hello.lisp +++ b/clx/demo/hello.lisp @@ -1,7 +1,7 @@ ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- #+cmu -(ext:file-comment "$Id: hello.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: hello.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/demo/mandel.lisp b/clx/demo/mandel.lisp index a877191f4a6cd7896e30a3f57b462a0e75b7e24e..f094b4a9c3cde455117298907038bd1694061931 100644 --- a/clx/demo/mandel.lisp +++ b/clx/demo/mandel.lisp @@ -1,5 +1,5 @@ #+cmu -(ext:file-comment "$Id: mandel.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") +(ext:file-comment "$Id: mandel.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage "XMANDEL" (:use "CL") diff --git a/clx/demo/menu.lisp b/clx/demo/menu.lisp index 821635610680ffceb1e633d0f43fd58a5e1d6af7..5de1d07267b318c1b41e52059502eb78f27d6c9d 100644 --- a/clx/demo/menu.lisp +++ b/clx/demo/menu.lisp @@ -16,9 +16,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id") - (in-package :xlib) @@ -306,7 +303,7 @@ (parent-width 400) (parent-height 400) (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) -;; :override-redirect :on + :override-redirect :on :x 100 :y 100 :width parent-width :height parent-height :background bg-color diff --git a/clx/demo/zoid.lisp b/clx/demo/zoid.lisp index a3bf4cef26b0e89e8a51a797debeb4c17f5d1ddb..0a313059f2f89f23c769c34aad6b01bc9dd111ab 100644 --- a/clx/demo/zoid.lisp +++ b/clx/demo/zoid.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id") - (in-package :xlib) (export '(draw-filled-trapezoids diff --git a/clx/dep-allegro.lisp b/clx/dep-allegro.lisp index ffc26a6966541e164470e559a5b9181e6e0fa19b..37def9aca6e70714d54a0ae344baf035fbc297df 100644 --- a/clx/dep-allegro.lisp +++ b/clx/dep-allegro.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: dep-allegro.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: dep-allegro.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) diff --git a/clx/dep-openmcl.lisp b/clx/dep-openmcl.lisp index c9b994a0c659d67daa51d4ff862755b5dd561104..94d8670e340dc57e8dd6acd04f47c0c1978653a9 100644 --- a/clx/dep-openmcl.lisp +++ b/clx/dep-openmcl.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: dep-openmcl.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: dep-openmcl.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) @@ -556,17 +556,16 @@ ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server -(defparameter ccl::*x-server-unix-socket-format-string* "/tmp/.X11-unix/X~d") - (defun open-x-stream (host display protocol) (declare (ignore protocol)) - (if (or (string= host "") (string= host "unix")) + (let ((local-socket-path (unix-socket-path-from-host host display))) + (if local-socket-path (ccl::make-socket :connect :active :address-family :file - :remote-filename (format nil ccl::*x-server-unix-socket-format-string* display)) + :remote-filename local-socket-path) (ccl::make-socket :connect :active :remote-host host - :remote-port (+ 6000 display)))) + :remote-port (+ 6000 display))))) ;;; BUFFER-READ-DEFAULT - read data from the X stream diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp index 79c97178a759dc3bd78f7efeeba6ffea94f63edd..bce7c5e7036d55792302d2bb51397ff2045ea54c 100644 --- a/clx/depdefs.lisp +++ b/clx/depdefs.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: depdefs.lisp,v 1.8 2007/08/22 03:58:59 fgilham Exp $") +(ext:file-comment "$Id: depdefs.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -674,3 +674,23 @@ used, since NIL is the empty list.") (:return-type :signed-32bit)) (host :simple-string) (display :signed-32bit)) + + +;;----------------------------------------------------------------------------- +;; Finding the server socket +;;----------------------------------------------------------------------------- + +;; These are here because dep-openmcl.lisp and dependent.lisp both need them +(defconstant +X-unix-socket-path+ + "/tmp/.X11-unix/X" + "The location of the X socket") + +(defun unix-socket-path-from-host (host display) + "Return the name of the unix domain socket for host and display, or +nil if a network socket should be opened." + (cond ((or (string= host "") (string= host "unix")) + (format nil "~A~D" +X-unix-socket-path+ display)) + #+darwin + ((and (> (length host) 10) (string= host "tmp/launch" :end1 10)) + (format nil "/~A:~D" host display)) + (t nil))) diff --git a/clx/display.lisp b/clx/display.lisp index 5cf54a991ae85a2184a2ec4e22e782be77072599..9460c0b13cd4ce7b6542ba469e8b9501d962ddcb 100644 --- a/clx/display.lisp +++ b/clx/display.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: display.lisp,v 1.13 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: display.lisp,v 1.14 2009/06/17 18:22:46 rtoy Exp $") (in-package :xlib) @@ -133,6 +133,24 @@ (values best-name best-data))))))) (values "" ""))) +(defmacro with-display ((display &key timeout inline) + &body body) + ;; This macro is for use in a multi-process environment. It + ;; provides exclusive access to the local display object for + ;; multiple request generation. It need not provide immediate + ;; exclusive access for replies; that is, if another process is + ;; waiting for a reply (while not in a with-display), then + ;; synchronization need not (but can) occur immediately. Except + ;; where noted, all routines effectively contain an implicit + ;; with-display where needed, so that correct synchronization is + ;; always provided at the interface level on a per-call basis. + ;; Nested uses of this macro will work correctly. This macro does + ;; not prevent concurrent event processing; see with-event-queue. + `(with-buffer (,display + ,@(and timeout `(:timeout ,timeout)) + ,@(and inline `(:inline ,inline))) + ,@body)) + ;; ;; Resource id management ;; @@ -149,40 +167,59 @@ (type mask32 mask)))))) (defun resourcealloc (display) - ;; Allocate a resource-id for in DISPLAY + ;; Allocate a resource-id for use in DISPLAY (declare (type display display)) (declare (clx-values resource-id)) - (dpb (incf (display-resource-id-count display)) - (display-resource-id-byte display) - (display-resource-id-base display))) + (loop for next-count upfrom (1+ (display-resource-id-count display)) + repeat (1+ (display-resource-id-mask display)) + as id = (dpb next-count + (display-resource-id-byte display) + (display-resource-id-base display)) + unless (nth-value 1 (gethash id (display-resource-id-map display))) + do (setf (display-resource-id-count display) next-count) + (setf (gethash id (display-resource-id-map display)) t) + (return-from resourcealloc id)) + ;; internal consistency check + (assert (= (hash-table-count (display-resource-id-map display)) + (1+ (display-resource-id-mask display)))) + ;; tell the user what's gone wrong + (error 'resource-ids-exhausted)) (defmacro allocate-resource-id (display object type) ;; Allocate a resource-id for OBJECT in DISPLAY - (if (member (eval type) +clx-cached-types+) - `(let ((id (funcall (display-xid ,display) ,display))) - (save-id ,display id ,object) - id) - `(funcall (display-xid ,display) ,display))) + `(with-display (,display) + ,(if (member (eval type) +clx-cached-types+) + `(let ((id (funcall (display-xid ,display) ,display))) + (save-id ,display id ,object) + id) + `(funcall (display-xid ,display) ,display)))) (defmacro deallocate-resource-id (display id type) + (declare (ignore type)) ;; Deallocate a resource-id for OBJECT in DISPLAY - (when (member (eval type) +clx-cached-types+) - `(deallocate-resource-id-internal ,display ,id))) + `(deallocate-resource-id-internal ,display ,id)) (defun deallocate-resource-id-internal (display id) - (remhash id (display-resource-id-map display))) + (with-display (display) + (remhash id (display-resource-id-map display)))) (defun lookup-resource-id (display id) ;; Find the object associated with resource ID (gethash id (display-resource-id-map display))) (defun save-id (display id object) - ;; Register a resource-id from another display. + ;; cache the object associated with ID for this display. (declare (type display display) (type integer id) (type t object)) (declare (clx-values object)) - (setf (gethash id (display-resource-id-map display)) object)) + ;; we can't cache objects from other clients, because they may + ;; become invalid without us being told about that. + (let ((base (display-resource-id-base display)) + (mask (display-resource-id-mask display))) + (when (= (logandc2 id mask) base) + (setf (gethash id (display-resource-id-map display)) object)) + object)) ;; Define functions to find the CLX data types given a display and resource-id ;; If the data type is being cached, look there first. @@ -279,24 +316,6 @@ ;; ;; Display functions ;; -(defmacro with-display ((display &key timeout inline) - &body body) - ;; This macro is for use in a multi-process environment. It - ;; provides exclusive access to the local display object for - ;; multiple request generation. It need not provide immediate - ;; exclusive access for replies; that is, if another process is - ;; waiting for a reply (while not in a with-display), then - ;; synchronization need not (but can) occur immediately. Except - ;; where noted, all routines effectively contain an implicit - ;; with-display where needed, so that correct synchronization is - ;; always provided at the interface level on a per-call basis. - ;; Nested uses of this macro will work correctly. This macro does - ;; not prevent concurrent event processing; see with-event-queue. - `(with-buffer (,display - ,@(and timeout `(:timeout ,timeout)) - ,@(and inline `(:inline ,inline))) - ,@body)) - (defmacro with-event-queue ((display &key timeout inline) &body body &environment env) ;; exclusive access to event queue @@ -369,41 +388,38 @@ gethostname(3) - is used instead." ;; if any, is assumed to come from the environment somehow. (declare (type integer display)) (declare (clx-values display)) - - (let ((protocol - (if (member host '("" "unix") :test #'equal) - :local - protocol))) - ;; Get the authorization mechanism from the environment. Handle the - ;; special case of a host name of "" and "unix" which means the - ;; protocol is :local - (when (null authorization-name) - (multiple-value-setq (authorization-name authorization-data) - (get-best-authorization host display protocol))) - ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. - (let* ((stream (open-x-stream host display protocol)) - (disp (make-buffer *output-buffer-size* #'make-display-internal - :host host :display display - :output-stream stream :input-stream stream)) - (ok-p nil)) - (unwind-protect - (progn - (display-connect disp - :authorization-name authorization-name - :authorization-data authorization-data) - (setf (display-authorization-name disp) authorization-name) - (setf (display-authorization-data disp) authorization-data) - (initialize-resource-allocator disp) - (initialize-predefined-atoms disp) - (initialize-extensions disp) - (when (assoc "BIG-REQUESTS" (display-extension-alist disp) - :test #'string=) - (enable-big-requests disp)) - (setq ok-p t)) - (unless ok-p (close-display disp :abort t))) - disp)) - ) - + ;; Get the authorization mechanism from the environment. Handle the + ;; special case of a host name of "" and "unix" which means the + ;; protocol is :local + (when (null authorization-name) + (multiple-value-setq (authorization-name authorization-data) + (get-best-authorization host + display + (if (member host '("" "unix") :test #'equal) + :local + protocol)))) + ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. + (let* ((stream (open-x-stream host display protocol)) + (disp (make-buffer *output-buffer-size* #'make-display-internal + :host host :display display + :output-stream stream :input-stream stream)) + (ok-p nil)) + (unwind-protect + (progn + (display-connect disp + :authorization-name authorization-name + :authorization-data authorization-data) + (setf (display-authorization-name disp) authorization-name) + (setf (display-authorization-data disp) authorization-data) + (initialize-resource-allocator disp) + (initialize-predefined-atoms disp) + (initialize-extensions disp) + (when (assoc "BIG-REQUESTS" (display-extension-alist disp) + :test #'string=) + (enable-big-requests disp)) + (setq ok-p t)) + (unless ok-p (close-display disp :abort t))) + disp)) (defun display-force-output (display) ; Output is normally buffered, this forces any buffered output to the server. @@ -419,10 +435,10 @@ gethostname(3) - is used instead." (defun display-connect (display &key authorization-name authorization-data) (with-buffer-output (display :sizes (8 16)) (card8-put - 0 - (ecase (display-byte-order display) - (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First - (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First + 0 + (ecase (display-byte-order display) + (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First + (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First (card16-put 2 *protocol-major-version*) (card16-put 4 *protocol-minor-version*) (card16-put 6 (length authorization-name)) @@ -437,112 +453,112 @@ gethostname(3) - is used instead." (let ((reply-buffer nil)) (declare (type (or null reply-buffer) reply-buffer)) (unwind-protect - (progn - (setq reply-buffer (allocate-reply-buffer #x1000)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (buffer-input display buffer-bbuf 0 8) - (let ((success (boolean-get 0)) - (reason-length (card8-get 1)) - (major-version (card16-get 2)) - (minor-version (card16-get 4)) - (total-length (card16-get 6)) - vendor-length - num-roots - num-formats) - (declare (ignore total-length)) - (unless success - (x-error 'connection-failure - :major-version major-version - :minor-version minor-version - :host (display-host display) - :display (display-display display) - :reason - (progn (buffer-input display buffer-bbuf 0 reason-length) - (string-get reason-length 0 :reply-buffer reply-buffer)))) - (buffer-input display buffer-bbuf 0 32) - (setf (display-protocol-major-version display) major-version) - (setf (display-protocol-minor-version display) minor-version) - (setf (display-release-number display) (card32-get 0)) - (setf (display-resource-id-base display) (card32-get 4)) - (setf (display-resource-id-mask display) (card32-get 8)) - (setf (display-motion-buffer-size display) (card32-get 12)) - (setq vendor-length (card16-get 16)) - (setf (display-max-request-length display) (card16-get 18)) - (setq num-roots (card8-get 20)) - (setq num-formats (card8-get 21)) - ;; Get the image-info - (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) - (let ((format (display-bitmap-format display))) - (declare (type bitmap-format format)) - (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) - (setf (bitmap-format-unit format) (card8-get 24)) - (setf (bitmap-format-pad format) (card8-get 25))) - (setf (display-min-keycode display) (card8-get 26)) - (setf (display-max-keycode display) (card8-get 27)) - ;; 4 bytes unused - ;; Get the vendor string - (buffer-input display buffer-bbuf 0 (lround vendor-length)) - (setf (display-vendor-name display) - (string-get vendor-length 0 :reply-buffer reply-buffer)) - ;; Initialize the pixmap formats - (dotimes (i num-formats) ;; loop gathering pixmap formats - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 8) - (push (make-pixmap-format :depth (card8-get 0) - :bits-per-pixel (card8-get 1) - :scanline-pad (card8-get 2)) - ; 5 unused bytes - (display-pixmap-formats display))) - (setf (display-pixmap-formats display) - (nreverse (display-pixmap-formats display))) - ;; Initialize the screens - (dotimes (i num-roots) - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 40) - (let* ((root-id (card32-get 0)) - (root (make-window :id root-id :display display)) - (root-visual (card32-get 32)) - (default-colormap-id (card32-get 4)) - (default-colormap + (progn + (setq reply-buffer (allocate-reply-buffer #x1000)) + (with-buffer-input (reply-buffer :sizes (8 16 32)) + (buffer-input display buffer-bbuf 0 8) + (let ((success (boolean-get 0)) + (reason-length (card8-get 1)) + (major-version (card16-get 2)) + (minor-version (card16-get 4)) + (total-length (card16-get 6)) + vendor-length + num-roots + num-formats) + (declare (ignore total-length)) + (unless success + (x-error 'connection-failure + :major-version major-version + :minor-version minor-version + :host (display-host display) + :display (display-display display) + :reason + (progn (buffer-input display buffer-bbuf 0 reason-length) + (string-get reason-length 0 :reply-buffer reply-buffer)))) + (buffer-input display buffer-bbuf 0 32) + (setf (display-protocol-major-version display) major-version) + (setf (display-protocol-minor-version display) minor-version) + (setf (display-release-number display) (card32-get 0)) + (setf (display-resource-id-base display) (card32-get 4)) + (setf (display-resource-id-mask display) (card32-get 8)) + (setf (display-motion-buffer-size display) (card32-get 12)) + (setq vendor-length (card16-get 16)) + (setf (display-max-request-length display) (card16-get 18)) + (setq num-roots (card8-get 20)) + (setq num-formats (card8-get 21)) + ;; Get the image-info + (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) + (let ((format (display-bitmap-format display))) + (declare (type bitmap-format format)) + (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) + (setf (bitmap-format-unit format) (card8-get 24)) + (setf (bitmap-format-pad format) (card8-get 25))) + (setf (display-min-keycode display) (card8-get 26)) + (setf (display-max-keycode display) (card8-get 27)) + ;; 4 bytes unused + ;; Get the vendor string + (buffer-input display buffer-bbuf 0 (lround vendor-length)) + (setf (display-vendor-name display) + (string-get vendor-length 0 :reply-buffer reply-buffer)) + ;; Initialize the pixmap formats + (dotimes (i num-formats) ;; loop gathering pixmap formats + (declare (ignorable i)) + (buffer-input display buffer-bbuf 0 8) + (push (make-pixmap-format :depth (card8-get 0) + :bits-per-pixel (card8-get 1) + :scanline-pad (card8-get 2)) + ; 5 unused bytes + (display-pixmap-formats display))) + (setf (display-pixmap-formats display) + (nreverse (display-pixmap-formats display))) + ;; Initialize the screens + (dotimes (i num-roots) + (declare (ignorable i)) + (buffer-input display buffer-bbuf 0 40) + (let* ((root-id (card32-get 0)) + (root (make-window :id root-id :display display)) + (root-visual (card32-get 32)) + (default-colormap-id (card32-get 4)) + (default-colormap (make-colormap :id default-colormap-id :display display)) - (screen + (screen (make-screen - :root root - :default-colormap default-colormap - :white-pixel (card32-get 8) - :black-pixel (card32-get 12) - :event-mask-at-open (card32-get 16) - :width (card16-get 20) - :height (card16-get 22) - :width-in-millimeters (card16-get 24) - :height-in-millimeters (card16-get 26) - :min-installed-maps (card16-get 28) - :max-installed-maps (card16-get 30) - :backing-stores (member8-get 36 :never :when-mapped :always) - :save-unders-p (boolean-get 37) - :root-depth (card8-get 38))) - (num-depths (card8-get 39)) - (depths nil)) - ;; Save root window for event reporting - (save-id display root-id root) - (save-id display default-colormap-id default-colormap) - ;; Create the depth AList for a screen, (depth . visual-infos) - (dotimes (j num-depths) - (declare (ignorable j)) - (buffer-input display buffer-bbuf 0 8) - (let ((depth (card8-get 0)) - (num-visuals (card16-get 2)) - (visuals nil)) ;; 4 bytes unused - (dotimes (k num-visuals) - (declare (ignorable k)) - (buffer-input display buffer-bbuf 0 24) - (let* ((visual (card32-get 0)) - (visual-info (make-visual-info + :root root + :default-colormap default-colormap + :white-pixel (card32-get 8) + :black-pixel (card32-get 12) + :event-mask-at-open (card32-get 16) + :width (card16-get 20) + :height (card16-get 22) + :width-in-millimeters (card16-get 24) + :height-in-millimeters (card16-get 26) + :min-installed-maps (card16-get 28) + :max-installed-maps (card16-get 30) + :backing-stores (member8-get 36 :never :when-mapped :always) + :save-unders-p (boolean-get 37) + :root-depth (card8-get 38))) + (num-depths (card8-get 39)) + (depths nil)) + ;; Save root window for event reporting + (save-id display root-id root) + (save-id display default-colormap-id default-colormap) + ;; Create the depth AList for a screen, (depth . visual-infos) + (dotimes (j num-depths) + (declare (ignorable j)) + (buffer-input display buffer-bbuf 0 8) + (let ((depth (card8-get 0)) + (num-visuals (card16-get 2)) + (visuals nil)) ;; 4 bytes unused + (dotimes (k num-visuals) + (declare (ignorable k)) + (buffer-input display buffer-bbuf 0 24) + (let* ((visual (card32-get 0)) + (visual-info (make-visual-info :id visual :display display :class (member8-get 4 :static-gray :gray-scale - :static-color :pseudo-color - :true-color :direct-color) + :static-color :pseudo-color + :true-color :direct-color) :bits-per-rgb (card8-get 5) :colormap-entries (card16-get 6) :red-mask (card32-get 8) @@ -550,16 +566,16 @@ gethostname(3) - is used instead." :blue-mask (card32-get 16) ;; 4 bytes unused ))) - (push visual-info visuals) - (when (funcall (resource-id-map-test) root-visual visual) - (setf (screen-root-visual-info screen) - (setf (colormap-visual-info default-colormap) - visual-info))))) - (push (cons depth (nreverse visuals)) depths))) - (setf (screen-depths screen) (nreverse depths)) - (push screen (display-roots display)))) - (setf (display-roots display) (nreverse (display-roots display))) - (setf (display-default-screen display) (first (display-roots display)))))) + (push visual-info visuals) + (when (funcall (resource-id-map-test) root-visual visual) + (setf (screen-root-visual-info screen) + (setf (colormap-visual-info default-colormap) + visual-info))))) + (push (cons depth (nreverse visuals)) depths))) + (setf (screen-depths screen) (nreverse depths)) + (push screen (display-roots display)))) + (setf (display-roots display) (nreverse (display-roots display))) + (setf (display-default-screen display) (first (display-roots display)))))) (when reply-buffer (deallocate-reply-buffer reply-buffer)))) display) diff --git a/clx/dpms.lisp b/clx/dpms.lisp index 61d0ba719a6fd095c4cdbbb47789e987d351020f..669dd516a8c28789ae766596ad7c0eccf62a7305 100644 --- a/clx/dpms.lisp +++ b/clx/dpms.lisp @@ -14,7 +14,7 @@ ;;;; provided ``as is'' without express or implied warranty. #+cmu -(ext:file-comment "$Id: dpms.lisp,v 1.2 2007/08/22 03:59:07 fgilham Exp $") +(ext:file-comment "$Id: dpms.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (defpackage :dpms (:use :common-lisp) diff --git a/clx/exclMakefile b/clx/exclMakefile index 3890d23a40ad423032fb25f1518126401a8e8d31..a31a468f3c102f9d362681abbaaf7d258cd50434 100644 --- a/clx/exclMakefile +++ b/clx/exclMakefile @@ -2,7 +2,7 @@ # Makefile for CLX # (X11 R4.4 release, Franz Allegro Common Lisp version) # -# $Id: exclMakefile,v 1.4 2007/08/21 15:49:28 fgilham Exp $ +# $Id: exclMakefile,v 1.5 2009/06/17 18:22:46 rtoy Rel $ # # ************************************************************************* diff --git a/clx/exclREADME b/clx/exclREADME index 2ecd2b9b0a0857ca9fa5e1af88d0c602c11e609f..98966a3df17b163e752084a5d9b3bfe07a3ed296 100644 --- a/clx/exclREADME +++ b/clx/exclREADME @@ -1,4 +1,4 @@ -$Id: exclREADME,v 1.4 2007/08/21 15:49:28 fgilham Exp $ +$Id: exclREADME,v 1.5 2009/06/17 18:22:46 rtoy Rel $ This file contains instructions on how to make CLX work with Franz Common Lisp. CLX should work on any machine that supports Allegro Common diff --git a/clx/exclcmac.lisp b/clx/exclcmac.lisp new file mode 100644 index 0000000000000000000000000000000000000000..04fd20af87020531a2341a6b0cf82dff28a9aad0 --- /dev/null +++ b/clx/exclcmac.lisp @@ -0,0 +1,260 @@ +;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- +;;; +;;; CLX -- exclcmac.cl +;;; This file provides for inline expansion of some functions. +;;; +;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca. +;;; +;;; 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. +;;; +;;; Franz Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +;; +;; Type predicates +;; +(excl:defcmacro card8p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) + +(excl:defcmacro card16p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) + +(excl:defcmacro int8p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) + +(excl:defcmacro int16p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) + +;; Card29p, card32p, int32p are too large to expand inline + + +;; +;; Type transformers +;; +(excl:defcmacro card8->int8 (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + ,(declare-bufmac) + (declare (type card8 ,xx)) + (the int8 (if (logbitp 7 ,xx) + (the int8 (- ,xx #x100)) + ,xx))))) +(excl:defcmacro int8->card8 (x) + `(locally ,(declare-bufmac) + (the card8 (ldb (byte 8 0) (the int8 ,x))))) + +(excl:defcmacro card16->int16 (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + ,(declare-bufmac) + (declare (type card16 ,xx)) + (the int16 (if (logbitp 15 ,xx) + (the int16 (- ,xx #x10000)) + ,xx))))) + +(excl:defcmacro int16->card16 (x) + `(locally ,(declare-bufmac) + (the card16 (ldb (byte 16 0) (the int16 ,x))))) + +(excl:defcmacro card32->int32 (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + ,(declare-bufmac) + (declare (type card32 ,xx)) + (the int32 (if (logbitp 31 ,xx) + (the int32 (- ,xx #x100000000)) + ,xx))))) + +(excl:defcmacro int32->card32 (x) + `(locally ,(declare-bufmac) + (the card32 (ldb (byte 32 0) (the int32 ,x))))) + +(excl:defcmacro char->card8 (char) + `(locally ,(declare-bufmac) + (the card8 (char-code (the string-char ,char))))) + +(excl:defcmacro card8->char (card8) + `(locally ,(declare-bufmac) + (the string-char (code-char (the card8 ,card8))))) + + +;; +;; Array accessors and setters +;; +(excl:defcmacro aref-card8 (a i) + `(locally ,(declare-bufmac) + (the card8 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-byte)))) + +(excl:defcmacro aset-card8 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-byte) + (the card8 ,v)))) + +(excl:defcmacro aref-int8 (a i) + `(locally ,(declare-bufmac) + (the int8 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-byte)))) + +(excl:defcmacro aset-int8 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-byte) + (the int8 ,v)))) + +(excl:defcmacro aref-card16 (a i) + `(locally ,(declare-bufmac) + (the card16 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-word)))) + +(excl:defcmacro aset-card16 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-word) + (the card16 ,v)))) + +(excl:defcmacro aref-int16 (a i) + `(locally ,(declare-bufmac) + (the int16 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-word)))) + +(excl:defcmacro aset-int16 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-word) + (the int16 ,v)))) + +(excl:defcmacro aref-card32 (a i) + `(locally ,(declare-bufmac) + (the card32 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long)))) + +(excl:defcmacro aset-card32 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long) + (the card32 ,v)))) + +(excl:defcmacro aref-int32 (a i) + `(locally ,(declare-bufmac) + (the int32 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-long)))) + +(excl:defcmacro aset-int32 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-long) + (the int32 ,v)))) + +(excl:defcmacro aref-card29 (a i) + ;; Don't need to mask bits here since X protocol guarantees top bits zero + `(locally ,(declare-bufmac) + (the card29 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long)))) + +(excl:defcmacro aset-card29 (v a i) + ;; I also assume here Lisp is passing a number that fits in 29 bits. + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long) + (the card29 ,v)))) + +;; +;; Font accessors +;; +(excl:defcmacro font-id (font) + ;; Get font-id, opening font if needed + (let ((f (gensym))) + `(let ((,f ,font)) + (or (font-id-internal ,f) + (open-font-internal ,f))))) + +(excl:defcmacro font-font-info (font) + (let ((f (gensym))) + `(let ((,f ,font)) + (or (font-font-info-internal ,f) + (query-font ,f))))) + +(excl:defcmacro font-char-infos (font) + (let ((f (gensym))) + `(let ((,f ,font)) + (or (font-char-infos-internal ,f) + (progn (query-font ,f) + (font-char-infos-internal ,f)))))) + + +;; +;; Miscellaneous +;; +(excl:defcmacro current-process () + `(the (or mp::process null) (and mp::*scheduler-stack-group* + mp::*current-process*))) + +(excl:defcmacro process-wakeup (process) + (let ((proc (gensym))) + `(let ((.pw-curproc. mp::*current-process*) + (,proc ,process)) + (when (and .pw-curproc. ,proc) + (if (> (mp::process-priority ,proc) + (mp::process-priority .pw-curproc.)) + (mp::process-allow-schedule ,proc)))))) + +(excl:defcmacro buffer-new-request-number (buffer) + (let ((buf (gensym))) + `(let ((,buf ,buffer)) + (declare (type buffer ,buf)) + (setf (buffer-request-number ,buf) + (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) + + diff --git a/clx/excldep.c b/clx/excldep.c index 5b96a44d280d115feb284d089c8d19cc1b2e8174..5bf47a78342b7ccf100aa1a82a367938c0dfe44c 100644 --- a/clx/excldep.c +++ b/clx/excldep.c @@ -3,7 +3,7 @@ */ /* - * $Id: excldep.c,v 1.3 2007/08/21 15:49:28 fgilham Exp $ + * $Id: excldep.c,v 1.4 2009/06/17 18:22:46 rtoy Rel $ */ /* diff --git a/clx/excldep.lisp b/clx/excldep.lisp index 93ee776bc49a3e0104d422a69039940cccbde534..b5ea9c5b69a76ce22fa44868219b741c0dc78286 100644 --- a/clx/excldep.lisp +++ b/clx/excldep.lisp @@ -14,7 +14,7 @@ ;;; #+cmu -(ext:file-comment "$Id: excldep.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: excldep.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/fonts.lisp b/clx/fonts.lisp index 5a84b6698037bf46846bff5410a833088acc100a..a9225fa4ddffe6b45f3166a8573e69bebc175f98 100644 --- a/clx/fonts.lisp +++ b/clx/fonts.lisp @@ -17,7 +17,7 @@ ;;; #+cmu -(ext:file-comment "$Id: fonts.lisp,v 1.6 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: fonts.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp index 5039ae3fce1c189f629901ddcfa968639fab9c74..052d16b3e1d196673095d025f8de3ace2960e26b 100644 --- a/clx/gcontext.lisp +++ b/clx/gcontext.lisp @@ -43,7 +43,7 @@ ;;; environment. #+cmu -(ext:file-comment "$Id: gcontext.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: gcontext.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/generalock.lisp b/clx/generalock.lisp index aa1a6fbe97b557ca70bee0692194a17da1a06053..21c25705e3cec0f61bfab4872c6d3cb03101b7ff 100644 --- a/clx/generalock.lisp +++ b/clx/generalock.lisp @@ -11,7 +11,7 @@ ;;; express or implied warranty. #+cmu -(ext:file-comment "$Id: generalock.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: generalock.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $") (defflavor xlib::clx-lock () (simple-recursive-normal-lock) (:init-keywords :flavor)) diff --git a/clx/gl.lisp b/clx/gl.lisp index 391af3f2168633c9d5ea089736eb0a079c2e2e13..1d7582d1def0ef4daac13eec9b364ce61907e20e 100644 --- a/clx/gl.lisp +++ b/clx/gl.lisp @@ -1,5 +1,5 @@ #+cmu -(ext:file-comment "$Id: gl.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: gl.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage :gl (:use :common-lisp :xlib) diff --git a/clx/glx.lisp b/clx/glx.lisp index 9903d68c3902c53a23cd0d301e41c9b357f6db66..b5c275035c51c73f4fb00c127d797871b26084be 100644 --- a/clx/glx.lisp +++ b/clx/glx.lisp @@ -1,5 +1,5 @@ #+cmu -(ext:file-comment "$Id: glx.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: glx.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage :glx (:use :common-lisp :xlib) diff --git a/clx/graphics.lisp b/clx/graphics.lisp index 53f09fc74c5222af1aa37ce7b5d298b6cecc9175..b9498489ad1e56616489013dd0e0332d39fe4735 100644 --- a/clx/graphics.lisp +++ b/clx/graphics.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: graphics.lisp,v 1.6 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: graphics.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/image.lisp b/clx/image.lisp index d578c265c696213221a20995700ed51482ed21fe..882f8c2209a398ef69df7e217793a0d738632ff1 100644 --- a/clx/image.lisp +++ b/clx/image.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: image.lisp,v 1.12 2007/08/22 03:59:16 fgilham Exp $") +(ext:file-comment "$Id: image.lisp,v 1.13 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/input.lisp b/clx/input.lisp index c1547b0a9cc67d07402fd2af535f227c9427cbcd..7ee2adc6cc843ffa42cc2b6f7ef29a4b6af7f901 100644 --- a/clx/input.lisp +++ b/clx/input.lisp @@ -26,7 +26,7 @@ ;;; 12/10/87 LGO Created #+cmu -(ext:file-comment "$Id: input.lisp,v 1.11 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: input.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -1780,6 +1780,13 @@ (format stream "inconsistent-parameters:~{ ~s~}" (inconsistent-parameters-parameters condition))))) +(define-condition resource-ids-exhausted (x-error) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "All X resource IDs are in use.")))) + (defun get-error-key (display error-code) (declare (type display display) (type array-index error-code)) diff --git a/clx/keysyms.lisp b/clx/keysyms.lisp index 2a62d2b2a7c56bd06271ada9ab54d86484ace7d0..f63f5d09d0a3d79131ce8d7fa212f9773041dc0a 100644 --- a/clx/keysyms.lisp +++ b/clx/keysyms.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: keysyms.lisp,v 1.5 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: keysyms.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/macros.lisp b/clx/macros.lisp index 0652bc105657faee9d16a9b39ab83c0fa91fc8af..cbf28d0c94c6cfc18044b86a74ad0b5ced349d53 100644 --- a/clx/macros.lisp +++ b/clx/macros.lisp @@ -26,7 +26,7 @@ ;;; This is built on top of BUFFER #+cmu -(ext:file-comment "$Id: macros.lisp,v 1.7 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: macros.lisp,v 1.8 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -337,6 +337,10 @@ ((index) (declare (ignore index)) nil) ((index value) (declare (ignore index value)) nil)) +(define-accessor pad32 (32) + ((index) (declare (ignore index)) nil) + ((index value) (declare (ignore index value)) nil)) + (define-accessor bit-vector256 (256) ;; used for key-maps ;; REAL-INDEX parameter provided so the default index can be over-ridden. diff --git a/clx/manager.lisp b/clx/manager.lisp index 545fdf18a0969ca455436bcb2d809f42e98ec73d..326223abbff20be24709a995f3867dde79c6f393 100644 --- a/clx/manager.lisp +++ b/clx/manager.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: manager.lisp,v 1.9 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: manager.lisp,v 1.10 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -64,7 +64,10 @@ (when value (let* ((name-len (position 0 (the (vector card8) value))) (name (subseq (the (vector card8) value) 0 name-len)) - (class (subseq (the (vector card8) value) (1+ name-len) (1- (length value))))) + (class + (when name-len + (subseq (the (vector card8) value) (1+ name-len) + (position 0 (the (vector card8) value) :start (1+ name-len)))))) (values (and (plusp (length name)) (map 'string #'card8->char name)) (and (plusp (length class)) (map 'string #'card8->char class))))))) diff --git a/clx/package.lisp b/clx/package.lisp index d483ebacac9066afae3bbc6836f91a6004622fc4..90665f38f8b8c064a965f9edce011ee4b270dab5 100644 --- a/clx/package.lisp +++ b/clx/package.lisp @@ -12,7 +12,7 @@ ;;; written prior permission. #+cmu -(ext:file-comment "$Id: package.lisp,v 1.8 2007/11/09 20:34:23 rtoy Exp $") +(ext:file-comment "$Id: package.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") ;;; The CLtL way diff --git a/clx/provide.lisp b/clx/provide.lisp index 78b385c85598e38931587403f31922742a3a86c2..fe59ebedcb4db07626fddc343ecd093341d6e3c9 100644 --- a/clx/provide.lisp +++ b/clx/provide.lisp @@ -15,7 +15,7 @@ ;;; #+cmu -(ext:file-comment "$Id: provide.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: provide.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $") #+cmu (cl:provide "CLX") @@ -63,5 +63,4 @@ (if *compile-clx* (compile-clx *clx-source-pathname* *clx-binary-pathname*) (load-clx *clx-binary-pathname*)) - ) diff --git a/clx/requests.lisp b/clx/requests.lisp index d2ec05b13c6f89376b2956b7aad1e445eab73126..49aeb3edfefb5a624ba522f1535c9a29fff82e7e 100644 --- a/clx/requests.lisp +++ b/clx/requests.lisp @@ -17,7 +17,7 @@ ;;; #+cmu -(ext:file-comment "$Id: requests.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: requests.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/resource.lisp b/clx/resource.lisp index aaff151dda2cca71298dfbea7bbf23e866897607..f5c1e5b18ee6389733bbd39e74543c9bb487c6e0 100644 --- a/clx/resource.lisp +++ b/clx/resource.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: resource.lisp,v 1.11 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: resource.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/screensaver.lisp b/clx/screensaver.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3605d03e5598c3f1c3e1aecc17d05c4f65779faa --- /dev/null +++ b/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@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/clx/shape.lisp b/clx/shape.lisp index 416330b78c85cb5c99532038c4dd3a2e8ec3ff12..5804a8a34824941e38b7b1eb9d57a21961ab004d 100644 --- a/clx/shape.lisp +++ b/clx/shape.lisp @@ -21,7 +21,7 @@ ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz #+cmu -(ext:file-comment "$Id: shape.lisp,v 1.2 2007/08/22 03:59:24 fgilham Exp $") +(ext:file-comment "$Id: shape.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/sockcl.lisp b/clx/sockcl.lisp index bd499fc25dc1d832ce46109a219351a8cb1d1836..b5e2ca5e1e6b00658fc93ce8df6aed40622fda04 100644 --- a/clx/sockcl.lisp +++ b/clx/sockcl.lisp @@ -24,7 +24,7 @@ ;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") #+cmu -(ext:file-comment "$Id: sockcl.lisp,v 1.3 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: sockcl.lisp,v 1.4 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/socket.c b/clx/socket.c index 3e172c61b8c4470261825f44f9b089b2e0a1541b..fcac36264b2ac1bc565e7967eb6232ef92da9cf1 100644 --- a/clx/socket.c +++ b/clx/socket.c @@ -7,7 +7,7 @@ * Compile using * % cc -c socket.c -DUNIXCONN * - * $Id: socket.c,v 1.4 2007/08/21 15:49:28 fgilham Exp $ + * $Id: socket.c,v 1.5 2009/06/17 18:22:46 rtoy Rel $ */ #include <stdio.h> diff --git a/clx/test/image.lisp b/clx/test/image.lisp index 7f6903c399f4a1ca58ada17d212f79d486a07d52..15dae1f0c2c2d51393b086e8109ef999668bd080 100644 --- a/clx/test/image.lisp +++ b/clx/test/image.lisp @@ -28,6 +28,7 @@ (defun image-test (&key + (host *image-test-host*) (nimages *image-test-nimages*) (copy *image-test-copy*) (copy-random-subimage *image-test-copy-random-subimage*) @@ -36,6 +37,7 @@ *image-test-get-image-result-type-choices*) (get-image-image-x-format-choices *image-test-get-image-image-x-format-choices*)) + (declare (ignore host)) (let* ((display nil) (abort t) (images nil)) @@ -43,12 +45,14 @@ (setq images nil) (unwind-protect (progn - (setq display (ext:open-clx-display)) + (setq display (open-default-display)) (let* ((screen (display-default-screen display)) (window (screen-root screen)) (gcontext (create-gcontext - :drawable window - :font (open-font display "fixed")))) + :foreground (screen-white-pixel screen) + :background (screen-black-pixel screen) + :drawable window + :font (open-font display "fixed")))) (dotimes (i nimages) (let ((image (image-test-get-image window @@ -91,10 +95,8 @@ (image-z :z-pixmap))) (image (get-image window :x x :y y :width width :height height :format format :result-type result-type))) - ;; XCreatePixmapCursor(3X11) says that x,y for hotspot are - ;; unsigned - ;; (setf (image-x-hot image) (- x)) - ;; (setf (image-y-hot image) (- y)) + (setf (getf (image-plist image) :root-x) x) + (setf (getf (image-plist image) :root-y) y) image)) (defun image-test-subimage-parameters (image random-subimage-p) @@ -119,6 +121,8 @@ ((or image-xy image-z) 'image-x))))) (multiple-value-bind (x y width height) (image-test-subimage-parameters image random-subimage-p) + (incf (getf (image-plist image) :root-x) x) + (incf (getf (image-plist image) :root-y) y) (copy-image image :x x :y y :width width :height height :result-type result-type)))) @@ -126,8 +130,10 @@ (multiple-value-bind (src-x src-y width height) (image-test-subimage-parameters image random-subimage-p) (let* ((border-width 1) - (x (- src-x #+nil (image-x-hot image) border-width)) - (y (- src-y #+nil (image-y-hot image) border-width))) + (root-x (getf (image-plist image) :root-x)) + (root-y (getf (image-plist image) :root-y)) + (x (+ src-x root-x (- border-width))) + (y (+ src-y root-y (- border-width)))) (unless (or (zerop width) (zerop height)) (let ((window (create-window diff --git a/clx/test/trapezoid.lisp b/clx/test/trapezoid.lisp index 7b1a571b44f73578010fe072fbc5fd8ecba8a6c2..ff959425867fa5b0ea872cb16677ee8b8a1d4660 100644 --- a/clx/test/trapezoid.lisp +++ b/clx/test/trapezoid.lisp @@ -21,9 +21,9 @@ (in-package :xlib) -(defun zoid-test (host) +(defun zoid-test () ;; Display the part picture in /extensions/test/datafile - (let* ((display (open-display host)) + (let* ((display (open-default-display)) (width 400) (height 400) (screen (display-default-screen display)) @@ -55,15 +55,15 @@ (when (zerop count) ;; Ignore all but the last exposure event (clear-area window) ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES - (poly-fill-Trapezoids window gc '(10 20 30 40 100 200)) + (draw-filled-trapezoids window gc '(10 20 30 40 100 200)) (setf (gcontext-trapezoid-alignment gc) :y) - (poly-fill-Trapezoids window gc #(10 20 30 40 100 200)) + (draw-filled-trapezoids window gc #(10 20 30 40 100 200)) (with-gcontext (gc :trapezoid-alignment :x) - (poly-fill-Trapezoids window gc '(40 50 60 70 140 240))) + (draw-filled-trapezoids window gc '(40 50 60 70 140 240))) (setf (gcontext-trapezoid-alignment gc) :x) - (poly-fill-Trapezoids window gc #(40 50 60 70 80 90)) + (draw-filled-trapezoids window gc #(40 50 60 70 80 90)) (with-gcontext (gc :trapezoid-alignment :y) - (poly-fill-Trapezoids window gc #(40 50 60 70 140 240))) + (draw-filled-trapezoids window gc #(40 50 60 70 140 240))) (draw-glyphs window gc 10 10 "Press any key to exit") ;; Returning non-nil causes event-case to exit diff --git a/clx/text.lisp b/clx/text.lisp index 6c3aa79bbe50e3330fb59e3af1ee265aefe82de2..6e3b0a478baa96fc547510fcadb72e1cfa746a7f 100644 --- a/clx/text.lisp +++ b/clx/text.lisp @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: text.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: text.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -73,8 +73,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)) @@ -83,7 +83,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)) @@ -95,8 +95,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)))))) @@ -481,7 +482,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) @@ -552,8 +553,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)) @@ -655,8 +655,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) @@ -762,7 +761,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) @@ -839,8 +838,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 @@ -905,8 +903,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/clx/translate.lisp b/clx/translate.lisp index 01506f5beccca579eeae468647fb11f32e9d9a70..1c015c7e70edcc927b79c8c2257b2870085d7d0b 100644 --- a/clx/translate.lisp +++ b/clx/translate.lisp @@ -17,7 +17,7 @@ ;;; #+cmu -(ext:file-comment "$Id: translate.lisp,v 1.5 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: translate.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) diff --git a/clx/xinerama.lisp b/clx/xinerama.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ee688e64b404e0d4c04317ac173337d3f83162f3 --- /dev/null +++ b/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/clx/xrender.lisp b/clx/xrender.lisp index e3bb1894b38e318e069d0884769c028227aabcce..a0b3b961ba6e4a8c325309ae135b6047933a2439 100644 --- a/clx/xrender.lisp +++ b/clx/xrender.lisp @@ -4,7 +4,7 @@ ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de> #+cmu -(ext:file-comment "$Id: xrender.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: xrender.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2002, 2003 by Gilbert Baumann @@ -28,14 +28,14 @@ ;; - some request are still to be implemented at all. ;; + Can they not wait? Xrender seems to be in flux as the specification -;; isn't even conforming to the actual protocol. However backwards -;; wierd that sounds. --noss +;; isn't even conforming to the acctual protocol. However backwards +;; wierd that sound. --noss ;; - we need to invent something for the color values of e.g. ;; fill-rectangles; I would prefer some generic functions, so that ;; we later can map CLIM design directly to colors. -;; - we want some convenience function to turn graphics contexts into +;; - we want some conviencene function to turn graphics contexts into ;; render pictures. --GB 2002-08-21 ;; - also: uniform-alpha-picture display alpha-value @@ -134,11 +134,7 @@ render-composite-glyphs render-add-glyph render-add-glyph-from-picture - render-free-glyphs - - - render-combine - )) + render-free-glyphs)) (pushnew :clx-ext-render *features*) @@ -214,7 +210,7 @@ (defun ensure-render-initialized (display) "Ensures that the RENDER extension is initialized. Should be called -by every function that attempts to generate RENDER requests." +by every function, which attempts to generate RENDER requests." ;; xxx locking? (unless (display-render-info display) (let ((q (make-render-info))) @@ -269,9 +265,8 @@ by every function that attempts to generate RENDER requests." res)) (defun find-window-picture-format (window) - "Find the picture format that matches the given window." - (let* ((cm (window-colormap window)) - (vi (colormap-visual-info cm)) + "Find the picture format which matches the given window." + (let* ((vi (window-visual-info window)) (display (window-display window))) (ensure-render-initialized display) (case (visual-info-class vi) @@ -342,13 +337,43 @@ by every function that attempts to generate RENDER requests." (define-accessor render-op (8) ((index) `(member8-get ,index :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum)) + :out :out-reverse :atop :atop-reverse :xor :add :saturate + '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh + :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over + :disjoint-over-reverse :disjoint-in :disjoint-in-reverse + :disjoint-out :disjoint-out-reverse :disjoint-atop + :disjoint-atop-reverse :disjoint-xor + '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh + '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh + :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over + :conjoint-over-reverse :conjoint-in :conjoint-in-reverse + :conjoint-out :conjoint-out-reverse :conjoint-atop + :conjoint-atop-reverse :conjoint-xor)) ((index thing) `(member8-put ,index ,thing :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum))) + :out :out-reverse :atop :atop-reverse :xor :add :saturate + '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh + :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over + :disjoint-over-reverse :disjoint-in :disjoint-in-reverse + :disjoint-out :disjoint-out-reverse :disjoint-atop + :disjoint-atop-reverse :disjoint-xor + '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh + '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh + :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over + :conjoint-over-reverse :conjoint-in :conjoint-in-reverse + :conjoint-out :conjoint-out-reverse :conjoint-atop + :conjoint-atop-reverse :conjoint-xor))) (deftype render-op () '(member :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum))) + :out :out-reverse :atop :atop-reverse :xor :add :saturate + :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over + :disjoint-over-reverse :disjoint-in :disjoint-in-reverse + :disjoint-out :disjoint-out-reverse :disjoint-atop + :disjoint-atop-reverse :disjoint-xor + :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over + :conjoint-over-reverse :conjoint-in :conjoint-in-reverse + :conjoint-out :conjoint-out-reverse :conjoint-atop + :conjoint-atop-reverse :conjoint-xor))) ;; Now these pictures objects are like graphics contexts. I was about ;; to introduce a synchronous mode, realizing that the RENDER protocol @@ -421,9 +446,9 @@ by every function that attempts to generate RENDER requests." ,index)) (%render-change-picture-clip-rectangles picture (aref (picture-%values picture) ,index)) - (setf (aref (picture-%values picture) ,index) - (aref (picture-%server-values picture) - ,index)))) + (setf (aref (picture-%server-values picture) ,index) + (aref (picture-%values picture) ,index)))) + (setf (picture-%changed-p picture) nil))) (defun render-create-picture @@ -680,7 +705,7 @@ by every function that 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 ... @@ -695,7 +720,7 @@ by every function that 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) ))) @@ -1040,17 +1065,17 @@ by every function that attempts to generate RENDER requests." (render-fill-rectangle px.pic :src (list #x8000 #x0000 #x8000 #xFFFF) 0 0 256 256) - ;; render-combine simply does not work - (render-combine :src pic pic px.pic - 350 350 350 350 0 0 256 256) + + (render-composite :src pic pic px.pic + 350 350 350 350 0 0 256 256) ;; (render-fill-rectangle px.pic :over (list #x8000 #x8000 #x8000 #x8000) 0 0 100 100) - (render-combine :src - px.pic px.pic pic - 0 0 0 0 350 350 - 256 256) + (render-composite :src + px.pic px.pic pic + 0 0 0 0 350 350 + 256 256) (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800) (display-finish-output dpy)) (close-display dpy)))) @@ -1079,23 +1104,22 @@ by every function that attempts to generate RENDER requests." (xlib:draw-point px px.gc x y) )) (xlib:clear-area win) - (let ((q(render-create-picture px - :format - (first (find-matching-picture-formats - dpy - :depth 32 - :alpha 8 :red 8 :green 8 :blue 8)) - :component-alpha :on - :repeat :off - ))) - (render-combine op - q - q - pic - 0 0 - 0 0 - 100 100 - 400 400)) + (let ((q (render-create-picture px + :format + (first (find-matching-picture-formats + dpy + :depth 32 + :alpha 8 :red 8 :green 8 :blue 8)) + :component-alpha :on + :repeat :off))) + (render-composite op + q + q + pic + 0 0 + 0 0 + 100 100 + 400 400)) (let () ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200) (display-finish-output dpy))) diff --git a/clx/xtest.lisp b/clx/xtest.lisp new file mode 100644 index 0000000000000000000000000000000000000000..587a845b8d4b321c2d4eb113d2a5e32e044469ef --- /dev/null +++ b/clx/xtest.lisp @@ -0,0 +1,154 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- +;;; +;;; Implementation of the XTest extension as described by +;;; http://www.x.org/docs/Xext/xtest.pdf +;;; +;;; Written by Lionel Flandrin <lionel.flandrin@gmail.com> in july +;;; 2008 and placed in the public domain. +;;; +;;; TODO: +;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard +;;; * Add the missing (declare (type ... + +(defpackage :xtest + (:use :common-lisp :xlib) + (:import-from :xlib + #:data + #:card8 + #:card8-get + #:card16 + #:card16-get + #:card32 + #:card32-get + #:extension-opcode + #:define-extension + #:gcontext + #:resource-id + #:window-id + #:cursor + #:make-cursor + #:with-buffer-request-and-reply + #:with-buffer-request + #:display) + (:export + ;; Constants + #:+major-version+ + #:+minor-version+ + + ;; Functions + #:set-gc-context-of-gc + #:get-version + #:compare-cursor + #:fake-motion-event + #:fake-button-event + #:fake-key-event + #:grab-control)) + +(in-package :xtest) + +(define-extension "XTEST") + +(defmacro opcode (display) + `(extension-opcode ,display "XTEST")) + +;;; The version we implement +(defconstant +major-version+ 2) +(defconstant +minor-version+ 2) + +(defconstant +none+ 0) +(defconstant +current-cursor+ 1) + +;;; XTest opcodes +(defconstant +get-version+ 0) +(defconstant +compare-cursor+ 1) +(defconstant +fake-input+ 2) +(defconstant +grab-control+ 3) + +;;; Fake events +(defconstant +fake-key-press+ 2) +(defconstant +fake-key-release+ 3) +(defconstant +fake-button-press+ 4) +(defconstant +fake-button-release+ 5) +(defconstant +fake-motion-notify+ 6) + +;;; Client operations +(defun set-gc-context-of-gc (gcontext gcontext-id) + (declare (type gcontext gcontext) + (type resource-id gcontext-id)) + (setf (gcontext-id gcontext) gcontext-id)) + +;;; Server requests +(defun get-version (display &optional (major +major-version+) (minor +minor-version+)) + "Returns the major and minor version of the server's XTest implementation" + (declare (type display display)) + (with-buffer-request-and-reply (display (opcode display) nil) + ((data +get-version+) + (card8 major) + (card16 minor)) + (values (card8-get 1) + (card16-get 8)))) + +(defun compare-cursor (display window &optional (cursor-id +current-cursor+)) + (declare (type display display) + (type resource-id cursor-id) + (type window window)) + (with-buffer-request-and-reply (display (opcode display) nil) + ((data +compare-cursor+) + (resource-id (window-id window)) + (resource-id cursor-id)) + (values (card8-get 1)))) + +(defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0)) + "Move the mouse pointer at coordinates (x, y). If :relative is t, +the movement is relative to the pointer's current position" + (declare (type display display)) + (with-buffer-request (display (opcode display)) + (data +fake-input+) + (card8 +fake-motion-notify+) + (card8 (if relative 1 0)) + (pad16 0) + (card32 delay) + (card32 root-window-id) + (pad32 0 0) + (card16 x) + (card16 y) + (pad32 0 0))) + +(defun fake-button-event (display button pressed &key (delay 0)) + "Send a fake button event (button pressed or released) to the +server. Most of the time, button 1 is the left one, 2 the middle and 3 +the right one but it's not always the case." + (declare (type display display)) + (with-buffer-request (display (opcode display)) + (data +fake-input+) + (card8 (if pressed +fake-button-press+ +fake-button-release+)) + (card8 button) + (pad16 0) + (card32 delay) + (pad32 0 0 0 0 0 0))) + +(defun fake-key-event (display keycode pressed &key (delay 0)) + "Send a fake key event (key pressed or released) to the server based +on its keycode." + (declare (type display display)) + (with-buffer-request (display (opcode display)) + (data +fake-input+) + (card8 (if pressed +fake-key-press+ +fake-key-release+)) + (card8 keycode) + (pad16 0) + (card32 delay) + (pad32 0 0 0 0 0 0))) + +(defun grab-control (display grab?) + "Make the client grab the server, that is allow it to make requests +even when another client grabs the server." + (declare (type display display)) + (with-buffer-request (display (opcode display)) + (data +grab-control+) + (card8 (if grab? 1 0)) + (pad8 0) + (pad16 0))) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; End: diff --git a/clx/xvidmode.lisp b/clx/xvidmode.lisp index 9f13d0f980721b11a888dbfbb797b5ba0aa7b5d6..a58b38b078e274118949a86c535d8623d3877a10 100644 --- a/clx/xvidmode.lisp +++ b/clx/xvidmode.lisp @@ -36,7 +36,7 @@ ;;; functions I made. #+cmu -(ext:file-comment "$Id: xvidmode.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") +(ext:file-comment "$Id: xvidmode.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) @@ -439,7 +439,7 @@ invalid." (defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0)) (declare (type display dpy) (type screen scr) - (type (single-float 0.100 10.000) red green blue)) + (type (single-float 0.100f0 10.000f0) red green blue)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma+) (card16 (screen-position scr dpy))