diff --git a/src/clx/README-CMUCL b/src/clx/README-CMUCL index d0fead6c71212df86e9dbdffa5f48da0dc19890e..f08c5c7caa9ec9c0cf0bf26894f5974e0ac6f872 100644 --- a/src/clx/README-CMUCL +++ b/src/clx/README-CMUCL @@ -1,40 +1,9 @@ -$Id: README-CMUCL,v 1.2 2009/06/11 16:03:56 rtoy Rel $ +This is an import of Telent-CLX from the fork +https://github.com/sharplispers/clx, version +6e39a0df2a0a1d083166f405d4b8bbc463d54d85. -This is an import of Telent-CLX as of 0.7.3. +All (almost?) files are included. A few changes to fix bugs related +to CMUCL have been added, as well as the CVS id. I've tried to make +few changes so it will be easy to merge again when desired. -All files are included. A few changes to fix bugs related to CMUCL -have been added, as well as the CVS id. I've tried to make few -changes so it will be easy to merge again when desired. - -The following files from this directory are compiled and loaded by -CMUCL when it builds utilities: - -clx-library.lisp -package.lisp -depdefs.lisp -clx.lisp -dependent.lisp -macros.lisp -bufmac.lisp -buffer.lisp -display.lisp -gcontext.lisp -input.lisp -requests.lisp -fonts.lisp -graphics.lisp -text.lisp -attributes.lisp -translate.lisp -keysyms.lisp -manager.lisp -image.lisp -resource.lisp -shape.lisp -big-requests.lisp -xvidmode.lisp -xrender.lisp -glx.lisp -gl.lisp -dpms.lisp -provide.lisp +See src/tools/clxcom.lisp to see what files are compiled. diff --git a/src/clx/attributes.lisp b/src/clx/attributes.lisp index c4a92d023f48eed19512595746af1a617d12693e..613abda304a8c3bc9525e1c0018b44af2d91bb41 100644 --- a/src/clx/attributes.lisp +++ b/src/clx/attributes.lisp @@ -40,9 +40,6 @@ ;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including ;;; the new drawable. The caches are initialized to NIL and allocated as needed. -#+cmu -(ext:file-comment "$Id: attributes.lisp,v 1.8 2009/06/17 18:22:45 rtoy Rel $") - (in-package :xlib) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -519,13 +516,11 @@ window (error "~S can only be set" 'window-cursor)) -(defun set-window-cursor (window cursor) +(defun (setf window-cursor) (cursor window) (change-window-attribute window 14 (encode-type (or (member :none) cursor) cursor)) cursor) -(defsetf window-cursor set-window-cursor) - (defun window-colormap-installed-p (window) (declare (type window window)) (declare (clx-values generalized-boolean)) diff --git a/src/clx/buffer.lisp b/src/clx/buffer.lisp index a5a38889658d2002da194d2611999bae236cf621..dd71190e255d1e65f43c2f1a27bbaa89126df0c0 100644 --- a/src/clx/buffer.lisp +++ b/src/clx/buffer.lisp @@ -49,9 +49,6 @@ ;; a point after a complete request. This is to ensure that a partial ;; request won't be left after aborts (e.g. control-abort on a lispm). -#+cmu -(ext:file-comment "$Id: buffer.lisp,v 1.10 2009/06/17 18:22:45 rtoy Rel $") - (in-package :xlib) (defconstant +requestsize+ 160) ;; Max request size (excluding variable length requests) @@ -71,7 +68,6 @@ ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.with-buffer-body. () ,@body)) - #+clx-ansi-common-lisp (declare (dynamic-extent #'.with-buffer-body.)) (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) (let ((buf (if (or (symbolp buffer) (constantp buffer)) @@ -90,13 +86,10 @@ (declare (type display buffer) (type (or null number) timeout) (type function function) - #+clx-ansi-common-lisp (dynamic-extent function) ;; FIXME: This is probably more a bug in SBCL (logged as ;; bug #243) - (ignorable timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) + (ignorable timeout)) (with-buffer (buffer :timeout timeout :inline t) (funcall function))) @@ -288,10 +281,7 @@ (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) + (dynamic-extent request-function)) (with-buffer (display :inline t) (multiple-value-prog1 (progn @@ -303,10 +293,7 @@ (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) + (dynamic-extent request-function)) (multiple-value-prog1 (progn (when gc-force (force-gcontext-changes-internal gc-force)) @@ -324,10 +311,7 @@ (declare (type display display) (type generalized-boolean multiple-reply)) (declare (type function request-function reply-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function reply-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function reply-function)) + (dynamic-extent request-function reply-function)) (let ((pending-command nil) (reply-buffer nil)) (declare (type (or null pending-command) pending-command) @@ -498,11 +482,10 @@ (type array-index nitems start index) (type (or null sequence) data) (type (or null (function (,totype) t)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (if transform (flet ((,ntrans (v) (funcall transform (,transformer v)))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) + (declare (dynamic-extent #',ntrans)) (,reader reply-buffer result-type nitems #',ntrans data start index)) (,reader reply-buffer result-type nitems #',transformer data start index))))) @@ -529,8 +512,7 @@ (type array-index nitems start index) (type list data) (type (function (,type) t) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-buffer-input (reply-buffer :sizes (,size) :index index) (do* ((j nitems (index- j 1)) (list (nthcdr start data) (cdr list)) @@ -557,10 +539,7 @@ (type array-index nitems start index) (type (simple-array card8 (*)) data)) (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) @@ -590,10 +569,7 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card8) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) @@ -611,8 +587,7 @@ (type array-index nitems start index) (type (or null sequence) data) (type (or null (function (,type) t)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (let ((result (or data (make-sequence result-type nitems)))) (typecase result (list @@ -667,10 +642,7 @@ (type array-index nitems start index) (type (simple-array card16 (*)) data)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) @@ -703,10 +675,7 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card16) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) @@ -752,10 +721,7 @@ (type array-index nitems start index) (type (simple-array card32 (*)) data)) (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) @@ -788,10 +754,7 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card32) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) @@ -819,11 +782,10 @@ (type sequence data) (type array-index boffset start end) (type (or null (function (t) ,fromtype)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (if transform (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) + (declare (dynamic-extent #',ntrans)) (,writer buffer boffset data start end #',ntrans)) (,writer buffer boffset data start end #',transformer))))) @@ -852,8 +814,7 @@ (type list data) (type array-index boffset start end) (type (function (t) ,type) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (writing-buffer-chunks ,type ((list (nthcdr start data))) ((type list list)) @@ -905,10 +866,7 @@ (type (simple-array card8 (*)) data) (type array-index boffset start end)) (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 ((index start)) @@ -939,10 +897,7 @@ (type vector data) (type array-index boffset start end)) (declare (type (function (t) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks card8 ((index start)) @@ -960,8 +915,7 @@ (type sequence data) (type array-index boffset start end) (type (or null (function (t) ,type)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (typecase data (list (if transform @@ -1020,10 +974,7 @@ (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) @@ -1066,10 +1017,7 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) @@ -1122,10 +1070,7 @@ (type (simple-array int16 (*)) data) (type array-index boffset start end)) (declare (type (function (int16) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 ((index start)) @@ -1168,10 +1113,7 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks int16 ((index start)) @@ -1224,10 +1166,7 @@ (type (simple-array card32 (*)) data) (type array-index boffset start end)) (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 ((index start)) @@ -1270,10 +1209,7 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks card32 ((index start)) @@ -1362,10 +1298,7 @@ (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) @@ -1399,10 +1332,7 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) diff --git a/src/clx/bufmac.lisp b/src/clx/bufmac.lisp index a2cbcd938d64f09ea781f96917766ca6e40a1ff5..1e002b824dfa240e93c10b6bd2858ab36f44bb8c 100644 --- a/src/clx/bufmac.lisp +++ b/src/clx/bufmac.lisp @@ -19,9 +19,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: bufmac.lisp,v 1.6 2009/06/17 18:22:45 rtoy Rel $") - (in-package :xlib) ;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them. diff --git a/src/clx/build-clx.lisp b/src/clx/build-clx.lisp index cb8ccddaa149d397a915d60f6d83af6ad8cee811..76b3299ea82ce418a3ae2bc21b65469ee5b4c3cf 100644 --- a/src/clx/build-clx.lisp +++ b/src/clx/build-clx.lisp @@ -1,8 +1,5 @@ ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- -#+cmu -(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) (compilation-speed 0))) diff --git a/src/clx/clx-module.lisp b/src/clx/clx-module.lisp index 903e1ef2222e1157a24cb7e23e2a9d6d868de6dd..e72651fc85659dc7269a585694d3266404c05290 100644 --- a/src/clx/clx-module.lisp +++ b/src/clx/clx-module.lisp @@ -1,9 +1,5 @@ ;;;(in-package :xlib) ;;;(common-lisp:use-package (list :common-lisp)) - -#+cmu -(ext:file-comment "$Id: clx-module.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") - (provide :clx) (load "clx:defsystem.lisp") -(load-clx (translate-logical-pathname "CLX:")) +(load-clx (translate-logical-pathname "CLX:")) \ No newline at end of file diff --git a/src/clx/clx.lisp b/src/clx/clx.lisp index 02c18f62f56fd84607f5bd1b037ea6d22dbb6475..2795556245ead84d7ab108abaf9540554e968659 100644 --- a/src/clx/clx.lisp +++ b/src/clx/clx.lisp @@ -76,9 +76,6 @@ ;;; objects, and the additional functionality to match the C Xlib is still in ;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu. -#+cmu -(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. (in-package :xlib) @@ -86,7 +83,7 @@ (pushnew :clx *features*) (pushnew :xlib *features*) -(defparameter *version* "Telent CLX 0.7.3 + CMUCL mods, based on MIT R5.02") +(defparameter *version* "MIT R5.02") (pushnew :clx-mit-r4 *features*) (pushnew :clx-mit-r5 *features*) @@ -162,20 +159,6 @@ (deftype card4 () '(unsigned-byte 4)) -#-clx-ansi-common-lisp -(deftype real (&optional (min '*) (max '*)) - (labels ((convert (limit floatp) - (typecase limit - (number (if floatp (float limit 0s0) (rational limit))) - (list (map 'list #'convert limit)) - (otherwise limit)))) - `(or (float ,(convert min t) ,(convert max t)) - (rational ,(convert min nil) ,(convert max nil))))) - -#-clx-ansi-common-lisp -(deftype base-char () - 'string-char) - ; Note that we are explicitly using a different rgb representation than what ; is actually transmitted in the protocol. diff --git a/src/clx/cmudep.lisp b/src/clx/cmudep.lisp index 0c10b3daa7b5210d0de2b8abed7dd993b96542b4..8624a3ee36a7db24680ce3f817fe7f355a13b9c1 100644 --- a/src/clx/cmudep.lisp +++ b/src/clx/cmudep.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: src/clx/cmudep.lisp $") + "$Header: /loaclhost/usr/local/src/cvs/clx/cmudep.lisp,v 1.1 2000/07/02 19:19:46 dan Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/src/clx/defsystem.lisp b/src/clx/defsystem.lisp index ad34fbaa99905d052ea6c8a9c296c4d0d12e97a8..74b5a2c3318ec8a7f24f06fbe70c72ad0291efde 100644 --- a/src/clx/defsystem.lisp +++ b/src/clx/defsystem.lisp @@ -20,7 +20,6 @@ ;;; implied warranty. ;;; #+ features used in this file -;;; clx-ansi-common-lisp ;;; lispm ;;; genera ;;; minima @@ -33,26 +32,15 @@ ;;; CMU ;;; sbcl -#+cmu -(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) - (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*)) - -#+(and Genera clx-ansi-common-lisp) +#+Genera (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) -#-(or clx-ansi-common-lisp cmu) -(lisp:in-package :user) - #+cmu (lisp:in-package "XLIB") #+cmu (export 'load-clx) -#+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) @@ -378,7 +366,7 @@ :version (pathname-version source-path))) (binary-path (merge-pathnames binary-pathname-defaults path)) - #+clx-ansi-common-lisp (*compile-verbose* t) + (*compile-verbose* t) (*load-verbose* t)) ;; Make sure source-path and binary-path file types are distinct so @@ -448,9 +436,8 @@ ;; Now compile and load all the files. ;; Defer compiler warnings until everything's compiled, if possible. - (#+(or clx-ansi-common-lisp CMU) with-compilation-unit + (with-compilation-unit #+lcl3.0 lucid::with-deferred-warnings - #-(or lcl3.0 clx-ansi-common-lisp CMU) progn () (compile-and-load "package") diff --git a/src/clx/demo/bezier.lisp b/src/clx/demo/bezier.lisp index f5776115445a67ab97dfe72a4fa8bbd078dbd9ea..fca439b0020bdbbe0c1c889e259c79054c86ab16 100644 --- a/src/clx/demo/bezier.lisp +++ b/src/clx/demo/bezier.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: bezier.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export 'draw-curves) diff --git a/src/clx/demo/beziertest.lisp b/src/clx/demo/beziertest.lisp index f564bc9ef86e57efea43980eedec42372a29679e..a8b2c2feb82092a6bc966e91a6b03bc4c9f04553 100644 --- a/src/clx/demo/beziertest.lisp +++ b/src/clx/demo/beziertest.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: beziertest.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) diff --git a/src/clx/demo/clclock.lisp b/src/clx/demo/clclock.lisp index bf9db76b09fdad101e69236bdd8f4a59445e527d..c5413dadca04c1bfa1d85d75dbb0b407e2d8dcdf 100644 --- a/src/clx/demo/clclock.lisp +++ b/src/clx/demo/clclock.lisp @@ -1,11 +1,8 @@ -#+cmu -(ext:file-comment "$Id: clclock.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "XCLCLOCK" +(defpackage #:xlib-demo/clclock (:use "CL") (:export "CLOCK")) -(in-package "XCLCLOCK") +(in-package #:xlib-demo/clclock) (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) diff --git a/src/clx/demo/clipboard.lisp b/src/clx/demo/clipboard.lisp index c544a09d600d47d115fdb228e34ff77dd243f30f..803ebfeb62a2c41761a1ecd1796223548d926d57 100644 --- a/src/clx/demo/clipboard.lisp +++ b/src/clx/demo/clipboard.lisp @@ -59,14 +59,11 @@ ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. -#+cmu -(ext:file-comment "$Id: clipboard.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "CLIPBOARD" +(defpackage #:xlib-demo/clipboard (:use "CL" "XLIB") (:export "MAIN")) -(in-package "CLIPBOARD") +(in-package #:xlib-demo/clipboard) ;;; This is "traditional" XLIB style; I don't really know if it's the ;;; best way -- in developing this program, style of XLIB programming diff --git a/src/clx/demo/clx-demos.lisp b/src/clx/demo/clx-demos.lisp index 4f08d8d5f0f63179fd6c8b38209da1428fd9a26a..0179e538ba9e4b9836bb5e76546ed0387e5f2ca4 100644 --- a/src/clx/demo/clx-demos.lisp +++ b/src/clx/demo/clx-demos.lisp @@ -6,13 +6,10 @@ ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. ;;; -#+cmu -(ext:file-comment "$Id: clx-demos.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :demos (:use :common-lisp) +(defpackage #:xlib-demo/demos (:use :common-lisp) (:export do-all-demos demo)) -(in-package :demos) +(in-package :xlib-demo/demos) ;;;; Graphic demos wrapper macro. @@ -39,11 +36,11 @@ (unless *display* #+:cmu (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp) + #+(or sbcl allegro clisp lispworks) (progn (setf *display* (xlib::open-default-display)) (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp) + #-(or cmu sbcl allegro clisp lispworks) (progn ;; Portable method (setf *display* (xlib:open-display (machine-instance))) diff --git a/src/clx/demo/gl-test.lisp b/src/clx/demo/gl-test.lisp index d9cd3dfda8295bc1626b74c3e734288cd0cbab1c..543cc8cd49d95dfeebd81af765f2845946dc3b39 100644 --- a/src/clx/demo/gl-test.lisp +++ b/src/clx/demo/gl-test.lisp @@ -1,11 +1,8 @@ -#+cmu -(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) +(defpackage #:xlib-demo/gl-test + (:use :common-lisp :xlib :xlib/gl) (:export "TEST" "CLX-TEST")) -(in-package :gl-test) +(in-package #:xlib-demo/gl-test) (defun test (function &key (host "localhost") (display 1) (width 200) (height 200)) @@ -16,19 +13,19 @@ (unwind-protect (progn ;;; Inform the server about us. - (glx::client-info display) - (let* ((visual (glx:choose-visual screen '(:glx-rgba + (xlib/glx::client-info display) + (let* ((visual (xlib/glx:choose-visual screen '(:glx-rgba (:glx-red-size 1) (:glx-green-size 1) (:glx-blue-size 1) :glx-double-buffer))) - (colormap (create-colormap (glx:visual-id visual) root)) + (colormap (create-colormap (xlib/glx:visual-id visual) root)) (window (create-window :parent root :x 10 :y 10 :width width :height height :class :input-output :background (screen-black-pixel screen) :border (screen-black-pixel screen) - :visual (glx:visual-id visual) + :visual (xlib/glx:visual-id visual) :depth 24 :colormap colormap :event-mask '(:structure-notify :exposure))) @@ -44,16 +41,16 @@ :min-width width :min-height height :initial-state :normal) - (setf ctx (glx:create-context screen (glx:visual-id visual))) + (setf ctx (xlib/glx:create-context screen (xlib/glx:visual-id visual))) (map-window window) - (glx:make-current window ctx) + (xlib/glx:make-current window ctx) (funcall function display window) (unmap-window window) (free-gcontext gc))) - (when ctx (glx:destroy-context ctx)) + (when ctx (xlib/glx:destroy-context ctx)) (close-display display)))) @@ -62,76 +59,76 @@ (defun no-floats (display window) (declare (ignore display window)) - (gl:color-3s #x7fff #x7fff 0) - (gl:begin gl:+polygon+) - (gl:vertex-2s 0 0) - (gl:vertex-2s 1 0) - (gl:vertex-2s 1 1) - (gl:vertex-2s 0 1) - (gl:end) - (glx:swap-buffers) + (color-3s #x7fff #x7fff 0) + (begin +polygon+) + (vertex-2s 0 0) + (vertex-2s 1 0) + (vertex-2s 1 1) + (vertex-2s 0 1) + (end) + (xlib/glx:swap-buffers) (sleep 5)) (defun anim (display window) (declare (ignore display window)) - (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) - (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) - (gl:line-width 2.0s0) + (ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) + (clear-color 0.0s0 0.0s0 0.0s0 0.0s0) + (line-width 2.0s0) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn - (gl:clear gl:+color-buffer-bit+) - (gl:push-matrix) - (gl:translate-f 0.5s0 0.5s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:translate-f -0.5s0 -0.5s0 0.0s0) - (gl:begin gl:+polygon+ #-(and) gl:+line-loop+) - (gl:color-3ub 255 0 0) - (gl:vertex-2f 0.25s0 0.25s0) - (gl:color-3ub 0 255 0) - (gl:vertex-2f 0.75s0 0.25s0) - (gl:color-3ub 0 0 255) - (gl:vertex-2f 0.75s0 0.75s0) - (gl:color-3ub 255 255 255) - (gl:vertex-2f 0.25s0 0.75s0) - (gl:end) - (gl:pop-matrix) - (glx:swap-buffers) + (clear +color-buffer-bit+) + (push-matrix) + (translate-f 0.5s0 0.5s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (translate-f -0.5s0 -0.5s0 0.0s0) + (begin +polygon+ #-(and) +line-loop+) + (color-3ub 255 0 0) + (vertex-2f 0.25s0 0.25s0) + (color-3ub 0 255 0) + (vertex-2f 0.75s0 0.25s0) + (color-3ub 0 0 255) + (vertex-2f 0.75s0 0.75s0) + (color-3ub 255 255 255) + (vertex-2f 0.25s0 0.75s0) + (end) + (pop-matrix) + (xlib/glx:swap-buffers) (sleep 0.02))) (sleep 3)) (defun anim/list (display window) (declare (ignore display window)) - (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) - (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) - (let ((list (gl:gen-lists 1))) - (gl:new-list list gl:+compile+) - (gl:begin gl:+polygon+) - (gl:color-3ub 255 0 0) - (gl:vertex-2f 0.25s0 0.25s0) - (gl:color-3ub 0 255 0) - (gl:vertex-2f 0.75s0 0.25s0) - (gl:color-3ub 0 0 255) - (gl:vertex-2f 0.75s0 0.75s0) - (gl:color-3ub 255 255 255) - (gl:vertex-2f 0.25s0 0.75s0) - (gl:end) - (glx:render) - (gl:end-list) + (ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) + (clear-color 0.0s0 0.0s0 0.0s0 0.0s0) + (let ((list (gen-lists 1))) + (new-list list +compile+) + (begin +polygon+) + (color-3ub 255 0 0) + (vertex-2f 0.25s0 0.25s0) + (color-3ub 0 255 0) + (vertex-2f 0.75s0 0.25s0) + (color-3ub 0 0 255) + (vertex-2f 0.75s0 0.75s0) + (color-3ub 255 255 255) + (vertex-2f 0.25s0 0.75s0) + (end) + (xlib/glx:render) + (end-list) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn - (gl:clear gl:+color-buffer-bit+) - (gl:push-matrix) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:call-list list) - (gl:pop-matrix) - (glx:swap-buffers) + (clear +color-buffer-bit+) + (push-matrix) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (call-list list) + (pop-matrix) + (xlib/glx:swap-buffers) (sleep 0.02)))) (sleep 3)) @@ -148,101 +145,101 @@ (r1 (/ (- outer-radius tooth-depth) 2.0s0)) (r2 (/ (+ outer-radius tooth-depth) 2.0s0)) (da (/ (* 2.0s0 +pi+) teeth 4.0s0))) - (gl:shade-model gl:+flat+) - (gl:normal-3f 0.0s0 0.0s0 1.0s0) + (shade-model +flat+) + (normal-3f 0.0s0 0.0s0 1.0s0) ;; Front face. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (when (< i teeth) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0))))) - (gl:end) + (end) ;; Draw front sides of teeth. - (gl:begin gl:+quads+) + (begin +quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)))) - (gl:end) + (end) - (gl:normal-3f 0.0s0 0.0s0 -1.0s0) + (normal-3f 0.0s0 0.0s0 -1.0s0) ;; Draw back face. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) (when (< i teeth) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0))))) - (gl:end) + (end) ;; Draw back sides of teeth. - (gl:begin gl:+quads+) + (begin +quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)))) - (gl:end) + (end) ;; Draw outward faces of teeth. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) @@ -250,118 +247,118 @@ (len (sqrt (+ (* u u) (* v v))))) (setf u (/ u len) v (/ v len)) - (gl:normal-3f v u 0.0s0) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (normal-3f v u 0.0s0) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) - (gl:normal-3f (cos angle) (sin angle) 0.0s0) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (normal-3f (cos angle) (sin angle) 0.0s0) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) (setf u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da))))) v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) - (gl:normal-3f v (- u) 0.0s0) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (normal-3f v (- u) 0.0s0) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:normal-3f (cos angle) (sin angle) 0.0s0)))) + (normal-3f (cos angle) (sin angle) 0.0s0)))) - (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) + (vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) + (vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) - (gl:end) + (end) - (gl:shade-model gl:+smooth+) + (shade-model +smooth+) ;; Draw inside radius cylinder. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) - (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) - (gl:end))) + (normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) + (end))) (defun draw (gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) - (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) + (clear (logior +color-buffer-bit+ +depth-buffer-bit+)) - (gl:push-matrix) - (gl:rotate-f view-rotx 1.0s0 0.0s0 0.0s0) - (gl:rotate-f view-roty 0.0s0 1.0s0 0.0s0) - (gl:rotate-f view-rotz 0.0s0 0.0s0 1.0s0) + (push-matrix) + (rotate-f view-rotx 1.0s0 0.0s0 0.0s0) + (rotate-f view-roty 0.0s0 1.0s0 0.0s0) + (rotate-f view-rotz 0.0s0 0.0s0 1.0s0) - (gl:push-matrix) - (gl:translate-f -3.0s0 -2.0s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-1) - (gl:pop-matrix) + (push-matrix) + (translate-f -3.0s0 -2.0s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (call-list gear-1) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f 3.1s0 -2.0s0 0.0s0) - (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-2) - (gl:pop-matrix) + (push-matrix) + (translate-f 3.1s0 -2.0s0 0.0s0) + (rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) + (call-list gear-2) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f -3.1s0 4.2s0 0.0s0) - (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-3) - (gl:pop-matrix) + (push-matrix) + (translate-f -3.1s0 4.2s0 0.0s0) + (rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) + (call-list gear-3) + (pop-matrix) - (gl:pop-matrix)) + (pop-matrix)) (defun reshape (width height) - (gl:viewport 0 0 width height) + (viewport 0 0 width height) (let ((h (coerce (/ height width) 'double-float))) - (gl:matrix-mode gl:+projection+) - (gl:load-identity) - (gl:frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) + (matrix-mode +projection+) + (load-identity) + (frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) - (gl:matrix-mode gl:+modelview+) - (gl:load-identity) - (gl:translate-f 0.0s0 0.0s0 -40.0s0)) + (matrix-mode +modelview+) + (load-identity) + (translate-f 0.0s0 0.0s0 -40.0s0)) (defun init () (let (gear-1 gear-2 gear-3) - ;;(gl:light-fv gl:+light0+ gl:+position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) - ;;(gl:enable gl:+cull-face+) - ;;(gl:enable gl:+lighting+) - ;;(gl:enable gl:+light0+) - ;;(gl:enable gl:+depth-test+) + ;;(light-fv +light0+ +position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) + ;;(enable +cull-face+) + ;;(enable +lighting+) + ;;(enable +light0+) + ;;(enable +depth-test+) ;; Make the gears. - (setf gear-1 (gl:gen-lists 1)) - (gl:new-list gear-1 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (setf gear-1 (gen-lists 1)) + (new-list gear-1 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (gl:end-list) + (end-list) - (setf gear-2 (gl:gen-lists 1)) - (gl:new-list gear-2 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) + (setf gear-2 (gen-lists 1)) + (new-list gear-2 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) - (gl:end-list) + (end-list) - (setf gear-3 (gl:gen-lists 1)) - (gl:new-list gear-3 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) + (setf gear-3 (gen-lists 1)) + (new-list gear-3 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) - (gl:end-list) + (end-list) - ;;(gl:enable gl:+normalize+) + ;;(enable +normalize+) (values gear-1 gear-2 gear-3))) @@ -369,31 +366,31 @@ (defun gears* (display window) (declare (ignore display window)) - (gl:enable gl:+cull-face+) - (gl:enable gl:+lighting+) - (gl:enable gl:+light0+) - (gl:enable gl:+normalize+) - (gl:enable gl:+depth-test+) + (enable +cull-face+) + (enable +lighting+) + (enable +light0+) + (enable +normalize+) + (enable +depth-test+) (reshape 300 300) - ;;(gl:light-fv gl:+light0+ gl:+position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) + ;;(light-fv +light0+ +position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) (let (list) (declare (ignore list)) #-(and) (progn - (setf list (gl:gen-lists 1)) - (gl:new-list list gl:+compile+) - ;;(gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (setf list (gen-lists 1)) + (new-list list +compile+) + ;;(material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (glx:render) - (gl:end-list)) + (xlib/glx:render) + (end-list)) (loop ;;for angle from 0.0s0 below 361.0s0 by 1.0s0 - with angle single-float = 0.0s0 + with angle of-type single-float = 0.0s0 with dt = 0.004s0 repeat 2500 do (progn @@ -402,39 +399,39 @@ (when (< 3600.0s0 angle) (decf angle 3600.0s0)) - (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) + (clear (logior +color-buffer-bit+ +depth-buffer-bit+)) - (gl:push-matrix) - (gl:rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) + (push-matrix) + (rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) - (gl:push-matrix) - (gl:translate-f -3.0s0 -2.0s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (push-matrix) + (translate-f -3.0s0 -2.0s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f 3.1s0 -2.0s0 0.0s0) - (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) + (push-matrix) + (translate-f 3.1s0 -2.0s0 0.0s0) + (rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f -3.1s0 4.2s0 0.0s0) - (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) + (push-matrix) + (translate-f -3.1s0 4.2s0 0.0s0) + (rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:pop-matrix) + (pop-matrix) - (glx:swap-buffers) + (xlib/glx:swap-buffers) ;;(sleep 0.025) ))) @@ -472,7 +469,7 @@ (decf angle 3600.0s0)) (draw gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) - (glx:swap-buffers) + (xlib/glx:swap-buffers) (incf frames) diff --git a/src/clx/demo/hello.lisp b/src/clx/demo/hello.lisp index 8ede2221f134829c59104e50a5a6f3c3368ed1ab..a3fbd88d827042a80aaa16833d3560c2892aa56e 100644 --- a/src/clx/demo/hello.lisp +++ b/src/clx/demo/hello.lisp @@ -1,8 +1,5 @@ ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- -#+cmu -(ext:file-comment "$Id: hello.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) diff --git a/src/clx/demo/mandel.lisp b/src/clx/demo/mandel.lisp index f094b4a9c3cde455117298907038bd1694061931..008797417481e7ef2aa3e516691ac21be84664a2 100644 --- a/src/clx/demo/mandel.lisp +++ b/src/clx/demo/mandel.lisp @@ -1,11 +1,8 @@ -#+cmu -(ext:file-comment "$Id: mandel.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "XMANDEL" +(defpackage #:xlib-demo/mandel (:use "CL") (:export "NEW-WINDOW" "EVENT-LOOP")) -(in-package "XMANDEL") +(in-package #:xlib-demo/mandel) (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) diff --git a/src/clx/dep-allegro.lisp b/src/clx/dep-allegro.lisp index 37def9aca6e70714d54a0ae344baf035fbc297df..365d279df96df883dec1789b978a5d508ef089f2 100644 --- a/src/clx/dep-allegro.lisp +++ b/src/clx/dep-allegro.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: dep-allegro.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") - (in-package :xlib) (proclaim '(declaration array-register)) @@ -866,7 +863,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) #-lispm @@ -877,7 +874,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) @@ -1033,12 +1030,10 @@ (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) -#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp)) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) @@ -1061,33 +1056,8 @@ (ext::disable-clx-event-handling disp))) (error condx))) -#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (define-condition x-error (error) ()) - ;;----------------------------------------------------------------------------- ;; HOST hacking @@ -1276,38 +1246,6 @@ Returns a list of (host display-number screen protocol)." (setq *temp-gcontext-cache* nil) nil) - - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - ) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE @@ -1324,7 +1262,6 @@ Returns a list of (host display-number screen protocol)." ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) diff --git a/src/clx/dep-lispworks.lisp b/src/clx/dep-lispworks.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6adcc5aefc35e08c7e362df30e6ab9d3e33d3472 --- /dev/null +++ b/src/clx/dep-lispworks.lisp @@ -0,0 +1,1407 @@ +;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- + +;; This file contains some of the system dependent code for CLX + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; 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. +;;; + +(in-package :xlib) + +#-(or lispworks6 lispworks7) +(error "Sorry, your ~S lisp version ~S is not currently supported. ~ + Patches are welcome." + (lisp-implementation-type) (lisp-implementation-version)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(proclaim '(declaration array-register)) + +;;; The size of the output buffer. Must be a multiple of 4. +(defparameter *output-buffer-size* 8192) + +;;; Number of seconds to wait for a reply to a server request +(defparameter *reply-timeout* nil) + +(defconstant +word-0+ 0) +(defconstant +word-1+ 1) + +(defconstant +long-0+ 0) +(defconstant +long-1+ 1) +(defconstant +long-2+ 2) +(defconstant +long-3+ 3) + +;;; Set some compiler-options for often used code + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 + "Speed compiler option for buffer code.") + (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 + "Safety compiler option for buffer code.") + (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 + "Debug compiler option for buffer code>") + (defun declare-bufmac () + `(declare (optimize + (speed ,+buffer-speed+) + (safety ,+buffer-safety+) + (debug ,+buffer-debug+)))) + ;; It's my impression that in lucid there's some way to make a + ;; declaration called fast-entry or something that causes a function + ;; to not do some checking on args. Sadly, we have no lucid manuals + ;; here. If such a declaration is available, it would be a good + ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ + ;; is 0. + (defun declare-buffun () + `(declare (optimize + (speed ,+buffer-speed+) + (safety ,+buffer-safety+) + (debug ,+buffer-debug+))))) + +(declaim (inline card8->int8 int8->card8 + card16->int16 int16->card16 + card32->int32 int32->card32)) + +(defun card8->int8 (x) + (declare (type card8 x)) + (declare (clx-values int8)) + #.(declare-buffun) + (the int8 (if (logbitp 7 x) + (the int8 (- x #x100)) + x))) + +(defun int8->card8 (x) + (declare (type int8 x)) + (declare (clx-values card8)) + #.(declare-buffun) + (the card8 (ldb (byte 8 0) x))) + +(defun card16->int16 (x) + (declare (type card16 x)) + (declare (clx-values int16)) + #.(declare-buffun) + (the int16 (if (logbitp 15 x) + (the int16 (- x #x10000)) + x))) + +(defun int16->card16 (x) + (declare (type int16 x)) + (declare (clx-values card16)) + #.(declare-buffun) + (the card16 (ldb (byte 16 0) x))) + +(defun card32->int32 (x) + (declare (type card32 x)) + (declare (clx-values int32)) + #.(declare-buffun) + (the int32 (if (logbitp 31 x) + (the int32 (- x #x100000000)) + x))) + +(defun int32->card32 (x) + (declare (type int32 x)) + (declare (clx-values card32)) + #.(declare-buffun) + (the card32 (ldb (byte 32 0) x))) + +(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) + +(defun aref-card8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card8)) + #.(declare-buffun) + (the card8 (aref a i))) + +(defun aset-card8 (v a i) + (declare (type card8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a i) v)) + +(defun aref-int8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int8)) + #.(declare-buffun) + (card8->int8 (aref a i))) + +(defun aset-int8 (v a i) + (declare (type int8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a i) (int8->card8 v))) + +(defun aref-card16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card16)) + #.(declare-buffun) + (the card16 + (logior (the card16 + (ash (the card8 (aref a (index+ i +word-1+))) 8)) + (the card8 + (aref a (index+ i +word-0+)))))) + +(defun aset-card16 (v a i) + (declare (type card16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-int16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int16)) + #.(declare-buffun) + (the int16 + (logior (the int16 + (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) + (the card8 + (aref a (index+ i +word-0+)))))) + +(defun aset-int16 (v a i) + (declare (type int16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-card32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card32)) + #.(declare-buffun) + (the card32 + (logior (the card32 + (ash (the card8 (aref a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) + +(defun aset-card32 (v a i) + (declare (type card32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-int32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int32)) + #.(declare-buffun) + (the int32 + (logior (the int32 + (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) + +(defun aset-int32 (v a i) + (declare (type int32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-card29 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card29)) + #.(declare-buffun) + (the card29 + (logior (the card29 + (ash (the card8 (aref a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) + +(defun aset-card29 (v a i) + (declare (type card29 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + v) + +(defsetf aref-card8 (a i) (v) + `(aset-card8 ,v ,a ,i)) + +(defsetf aref-int8 (a i) (v) + `(aset-int8 ,v ,a ,i)) + +(defsetf aref-card16 (a i) (v) + `(aset-card16 ,v ,a ,i)) + +(defsetf aref-int16 (a i) (v) + `(aset-int16 ,v ,a ,i)) + +(defsetf aref-card32 (a i) (v) + `(aset-card32 ,v ,a ,i)) + +(defsetf aref-int32 (a i) (v) + `(aset-int32 ,v ,a ,i)) + +(defsetf aref-card29 (a i) (v) + `(aset-card29 ,v ,a ,i)) + +;;; Other random conversions + +(defun rgb-val->card16 (value) + ;; Short floats are good enough + (declare (type rgb-val value)) + (declare (clx-values card16)) + #.(declare-buffun) + ;; Convert VALUE from float to card16 + (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) + +(defun card16->rgb-val (value) + ;; Short floats are good enough + (declare (type card16 value)) + (declare (clx-values short-float)) + #.(declare-buffun) + ;; Convert VALUE from card16 to float + (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) + +(defun radians->int16 (value) + ;; Short floats are good enough + (declare (type angle value)) + (declare (clx-values int16)) + #.(declare-buffun) + (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) + +(defun int16->radians (value) + ;; Short floats are good enough + (declare (type int16 value)) + (declare (clx-values short-float)) + #.(declare-buffun) + (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) + +;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI +;;; is irrational, there can't be a precise rational representation. In +;;; particular, the different float approximations will always be /=. This +;;; causes problems with type checking, because people might compute an +;;; argument in any precision. What we do is discard all the excess precision +;;; in the value, and see if the protocol encoding falls in the desired range +;;; (64'ths of a degree.) +;;; +(deftype angle () '(satisfies anglep)) + +(defun anglep (x) + (and (typep x 'real) + (<= (* -360 64) (radians->int16 x) (* 360 64)))) + + +;;----------------------------------------------------------------------------- +;; Character transformation +;;----------------------------------------------------------------------------- + +;;; This stuff transforms chars to ascii codes in card8's and back. +;;; You might have to hack it a little to get it to work for your machine. + +(declaim (inline char->card8 card8->char)) + +(macrolet ((char-translators () + (let ((alist + `(;; The normal ascii codes for the control characters. + ,@`((#\Return . 13) + (#\Linefeed . 10) + (#\Rubout . 127) + (#\Page . 12) + (#\Tab . 9) + (#\Backspace . 8) + (#\Newline . 10) + (#\Space . 32)) + ;; The rest of the common lisp charater set with the normal + ;; ascii codes for them. + (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) + (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) + (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) + (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) + (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) + (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) + (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) + (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) + (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) + (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) + (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) + (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) + (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) + (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) + (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) + (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) + (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) + (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) + (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) + (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) + (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) + (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) + (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) + (#\} . 125) (#\~ . 126)))) + + (cond ((dolist (pair alist nil) + (when (not (= (char-code (car pair)) (cdr pair))) + (return t))) + + `(progn + (defconstant *char-to-card8-translation-table* + ',(let ((array (make-array + (let ((max-char-code 255)) + (dolist (pair alist) + (setq max-char-code + (max max-char-code + (char-code (car pair))))) + (1+ max-char-code)) + :element-type 'card8))) + (dotimes (i (length array)) + (setf (aref array i) (mod i 256))) + (dolist (pair alist) + (setf (aref array (char-code (car pair))) + (cdr pair))) + array)) + + (defconstant *card8-to-char-translation-table* + ',(let ((array (make-array 256))) + (dotimes (i (length array)) + (setf (aref array i) (code-char i))) + (dolist (pair alist) + (setf (aref array (cdr pair)) (car pair))) + array)) + + (progn + (defun char->card8 (char) + (declare (type base-char char)) + #.(declare-buffun) + (the card8 (aref (the (simple-array card8 (*)) + *char-to-card8-translation-table*) + (the array-index (char-code char))))) + + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the base-char + (or (aref (the simple-vector *card8-to-char-translation-table*) + card8) + (error "Invalid CHAR code ~D." card8)))) + ) + + (dotimes (i 256) + (unless (= i (char->card8 (card8->char i))) + (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" + (list i + (card8->char i) + (char->card8 (card8->char i)))) + (return nil))) + + (dotimes (i (length *char-to-card8-translation-table*)) + (let ((char (code-char i))) + (unless (eql char (card8->char (char->card8 char))) + (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" + (list char + (char->card8 char) + (card8->char (char->card8 char)))) + (return nil)))))) + (t + `(progn + (defun char->card8 (char) + (declare (type base-char char)) + #.(declare-buffun) + (the card8 (char-code char))) + + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the base-char (code-char card8))) + )))))) + (char-translators)) + + +;;----------------------------------------------------------------------------- +;; Process Locking +;; +;; Common-Lisp doesn't provide process locking primitives, so we define +;; our own here, based on Zetalisp primitives. Holding-Lock is very +;; similar to with-lock on The TI Explorer, and a little more efficient +;; than with-process-lock on a Symbolics. +;;----------------------------------------------------------------------------- + +;;; MAKE-PROCESS-LOCK: Creating a process lock. + +(defun make-process-lock (name) + (mp:make-lock :name name)) + +;;; HOLDING-LOCK: Execute a body of code with a lock held. + +;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN +;;; passes its timeout to the holding-lock macro, so any timeout you want to +;;; work for event-listen you should do for holding-lock. + +;; If you're not sharing DISPLAY objects within a multi-processing +;; shared-memory environment, this is sufficient + +(defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) + (declare (ignore display)) + `(mp:with-lock (,lock ,whostate ,timeout) + ,@body)) + +;;; WITHOUT-ABORTS + +;;; If you can inhibit asynchronous keyboard aborts inside the body of this +;;; macro, then it is a good idea to do this. This macro is wrapped around +;;; request writing and reply reading to ensure that requests are atomically +;;; written and replies are atomically read from the stream. + +(defmacro without-aborts (&body body) + `(progn ,@body)) + +;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. +;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's +;;; value changes. + +(defun process-block (whostate predicate &rest predicate-args) + (declare (dynamic-extent predicate-args)) + (apply #'mp:process-wait whostate predicate predicate-args)) + +;;; PROCESS-WAKEUP: Check some other process' wait function. + +(declaim (inline process-wakeup)) + +(defun process-wakeup (process) + (declare (ignore process)) + (mp:process-allow-scheduling)) + +;;; CURRENT-PROCESS: Return the current process object for input locking and +;;; for calling PROCESS-WAKEUP. + +(declaim (inline current-process)) + +(defun current-process () + (mp:get-current-process)) + +;;; WITHOUT-INTERRUPTS -- provide for atomic operations. + +(defvar *without-interrupts-sic-lock* + (mp:make-lock :name "Lock simulating *without-interrupts*")) + +(defmacro without-interrupts (&body body) + `(mp:with-lock (*without-interrupts-sic-lock*) + ,@body)) + +;;; CONDITIONAL-STORE: + +(defvar *conditional-store-lock* + (mp:make-lock :name "Conditional store lock")) + +(defmacro conditional-store (place old-value new-value) + `(mp:with-lock (*conditional-store-lock*) + (cond ((eq ,place ,old-value) + (setf ,place ,new-value) + t)))) + +;;;---------------------------------------------------------------------------- +;;; IO Error Recovery +;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. +;;; It prevents multiple mindless errors when the network craters. +;;; +;;;---------------------------------------------------------------------------- + +(defmacro wrap-buf-output ((buffer) &body body) + ;; Error recovery wrapper + `(unless (buffer-dead ,buffer) + ,@body)) + +(defmacro wrap-buf-input ((buffer) &body body) + (declare (ignore buffer)) + ;; Error recovery wrapper + `(progn ,@body)) + + +;;;---------------------------------------------------------------------------- +;;; System dependent IO primitives +;;; Functions for opening, reading writing forcing-output and closing +;;; the stream to the server. +;;;---------------------------------------------------------------------------- + +;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X +;;; server + +;;; NOTE: OPEN-UNIX-STREAM and HOST-ADDRESS implementation are borrowed from +;;; http://www.bew.org.uk/Lisp/ +;;; Original license of UNIX Domain Socket support for LispWorks: +;;; +;;; Copyright 2001, Barry Wilkes <bew@bcs.org.uk> +;;; uk.org.bew.comm-ext, an extension to the network interface for LispWorks/Linux +;;; +;;; uk.org.bew.comm-ext is licensed under the terms of the Lisp Lesser GNU +;;; Public License (http://opensource.franz.com/preamble.html), known as +;;; the LLGPL. The LLGPL consists of a preamble (see above URL) and the +;;; LGPL. Where these conflict, the preamble takes precedence. +;;; uk.org.bew.comm-ext is referenced in the preamble as the "LIBRARY." + +;;; NOTE: %CREATE-UNIX-DOMAIN-SOCKET implementation ideas are borrowed from +;;; http://common-lisp.net/project/cl-net-snmp/lispworks.html +;;; Original license of LispWorks-UDP: +;;; +;;; The MIT License +;;; +;;; Copyright (c) 2007-2008, Chun Tian (binghe) +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +;;; THE SOFTWARE. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +max-unix-path-length+ + #+darwin 104 #-darwin 108)) + +(fli:define-c-struct %sockaddr-un + #+darwin (sun-len (:unsigned :byte)) + (sun-family (:unsigned #+darwin :byte #-darwin :short)) + (sun-path (:c-array (:unsigned :byte) #.+max-unix-path-length+))) + +(defun %create-unix-domain-socket (pathname error) + (let ((sock-fd (comm::socket comm::*socket_af_unix* comm::*socket_sock_stream* comm::*socket_pf_unspec*))) + (if (null sock-fd) + (and error (error "Failed to create unix domain socket at ~S." pathname)) + + (fli:with-dynamic-foreign-objects ((sock-addr (:struct %sockaddr-un))) + (let ((pathname-string (namestring (translate-logical-pathname (truename pathname))))) + (fli:fill-foreign-object sock-addr :byte 0) + + (let* ((code (ef:encode-lisp-string pathname-string :utf-8)) + (len (length code))) + (fli:with-foreign-slots (#+darwin sun-len sun-family) sock-addr + #+darwin (setf sun-len (+ len 2)) + (setf sun-family comm::*socket_af_unix*)) + (fli:replace-foreign-array (fli:foreign-slot-pointer sock-addr 'sun-path) + code + :start1 0 :end1 (min len +max-unix-path-length+)) + (setf (fli:foreign-aref (fli:foreign-slot-pointer sock-addr 'sun-path) + (min len (1- +max-unix-path-length+))) 0))) + + (if (comm::connect sock-fd + (fli:copy-pointer sock-addr :type '(:struct comm::sockaddr)) + (fli:pointer-element-size sock-addr)) + sock-fd + (progn + (comm::close-socket sock-fd) + (and error (error "Failed to connect unix domain socket at ~S." pathname)))))))) + +(defun open-unix-stream (service &key + (direction :io) + (element-type 'base-char) + (errorp t)) + (let ((socket (%create-unix-domain-socket service errorp))) + (when socket + (make-instance 'comm:socket-stream + :socket socket + :element-type element-type + :direction direction)))) + +(defun open-x-stream (host display protocol) + (declare (ignore protocol) + (type (integer 0) display)) + + (if (or (null host) (string= host "") (string= host "unix")) + (open-unix-stream (unix-socket-path-from-host host display) + :direction :io + :element-type '(unsigned-byte 8) + :errorp t) + + (comm:open-tcp-stream host (+ *x-tcp-port* display) + :direction :io + :element-type '(unsigned-byte 8) + :errorp t))) + +;;; BUFFER-READ-DEFAULT - read data from the X stream + +(defun buffer-read-default (display vector start end timeout) + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null fixnum) timeout)) + #.(declare-buffun) + + (cond ((and (eql timeout 0) + (not (listen (display-input-stream display)))) + :timeout) + (t + (read-sequence vector + (display-input-stream display) + :start start + :end end) + nil))) + +;;; BUFFER-WRITE-DEFAULT - write data to the X stream + +(defun buffer-write-default (vector display start end) + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + + (write-sequence vector (display-output-stream display) :start start :end end) + nil) + +;;; buffer-force-output-default - force output to the X stream + +(defun buffer-force-output-default (display) + ;; The default buffer force-output function for use with common-lisp streams + (declare (type display display)) + + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + + (unless (null stream) + (force-output stream)))) + +;;; BUFFER-CLOSE-DEFAULT - close the X stream + +(defun buffer-close-default (display &key abort) + ;; The default buffer close function for use with common-lisp streams + (declare (type display display)) + #.(declare-buffun) + + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + + (unless (null stream) + (close stream :abort abort)))) + +;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the +;;; buffer. This is called in read-input between requests, so that a process +;;; waiting for input is abortable when between requests. Should return +;;; :TIMEOUT if it times out, NIL otherwise. + +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout)) + + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + + (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + (t + (if (sys:wait-for-input-streams-returning-first + (list stream) :timeout timeout) + nil + :timeout))))) + +;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the +;;; buffer. This should never block, so it can be called from the scheduler. + +(defun buffer-listen-default (display) + (declare (type display display)) + + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + + (if (null stream) + t + (listen stream)))) + + +;;;---------------------------------------------------------------------------- +;;; System dependent speed hacks +;;;---------------------------------------------------------------------------- + +;; +;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. +;; If your lisp doesn't have stack-lists, and you're worried about +;; consing garbage, you may want to re-write this to allocate and +;; initialize lists from a resource. +;; +(defmacro with-stack-list ((var &rest elements) &body body) + ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) + ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) + ;; except that the list produced by MAPCAR resides on the stack and + ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. + `(let ((,var (list ,@elements))) + (declare (type cons ,var) + (dynamic-extent ,var)) + ,@body)) + +(defmacro with-stack-list* ((var &rest elements) &body body) + ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) + ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) + ;; except that the list produced by MAPCAR resides on the stack and + ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. + `(let ((,var (list* ,@elements))) + (declare (type cons ,var) + (dynamic-extent ,var)) + ,@body)) + +(declaim (inline buffer-replace)) + +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type buffer-bytes buf1 buf2) + (type array-index start1 end1 start2)) + (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) + +(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) + &body body) + (let ((local-state (gensym)) + (resets nil)) + (dolist (index indexes) + (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) + resets)) + `(unwind-protect + (progn + ,@body) + (let ((,local-state (gcontext-local-state ,gc))) + (declare (type gcontext-state ,local-state)) + ,@resets + (setf (svref ,local-state ,ts-index) 0)) + (when ,temp-gc + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (deallocate-gcontext-state ,saved-state)))) + + +;;;---------------------------------------------------------------------------- +;;; How much error detection should CLX do? +;;; Several levels are possible: +;;; +;;; 1. Do the equivalent of check-type on every argument. +;;; +;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format +;;; strings generated by check-type. +;;; +;;; 3. Do error checking only on arguments that are likely to have errors +;;; (like keyword names) +;;; +;;; 4. Do error checking only where not doing so may dammage the envirnment +;;; on a non-tagged machine (i.e. when storing into a structure that has +;;; been passed in) +;;; +;;; 5. No extra error detection code. On lispm's, ASET may barf trying to +;;; store a non-integer into a number array. +;;; +;;; How extensive should the error checking be? For example, if the server +;;; expects a CARD16, is is sufficient for CLX to check for integer, or +;;; should it also check for non-negative and less than 65536? +;;;---------------------------------------------------------------------------- + +;; The +TYPE-CHECK?+ constant controls how much error checking is done. +;; Possible values are: +;; NIL - Don't do any error checking +;; t - Do the equivalent of checktype on every argument +;; :minimal - Do error checking only where errors are likely + +;;; This controls macro expansion, and isn't changable at run-time You will +;;; probably want to set this to nil if you want good performance at +;;; production time. +(defconstant +type-check?+ nil) + +;; TYPE? is used to allow the code to do error checking at a different level from +;; the declarations. It also does some optimizations for systems that don't have +;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. +;; include range checks. You can modify TYPE? to do less extensive checking +;; for these types if you desire. + +;; +;; ### This comment is a lie! TYPE? is really also used for run-time type +;; dispatching, not just type checking. -- Ram. + +(defmacro type? (object type) + `(typep ,object ,type)) + +;; X-TYPE-ERROR is the function called for type errors. +;; If you want lots of checking, but are concerned about code size, +;; this can be made into a macro that ignores some parameters. + +(defun x-type-error (object type &optional error-string) + (x-error 'x-type-error + :datum object + :expected-type type + :type-string error-string)) + + +;;----------------------------------------------------------------------------- +;; Error handlers +;; Hack up KMP error signaling using zetalisp until the real thing comes +;; along +;;----------------------------------------------------------------------------- + +(defun default-error-handler (display error-key &rest key-vals + &key asynchronous &allow-other-keys) + (declare (type generalized-boolean asynchronous) + (dynamic-extent key-vals)) + ;; The default display-error-handler. + ;; It signals the conditions listed in the DISPLAY file. + (if asynchronous + (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) + (apply #'x-error error-key :display display :error-key error-key key-vals))) + +(defun x-error (condition &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'error condition keyargs)) + +(defun x-cerror (proceed-format-string condition &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'cerror proceed-format-string condition keyargs)) + +;; version 15 of Pitman error handling defines the syntax for define-condition to be: +;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] +;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) +;; or (:report exp) + +(define-condition x-error (error) ()) + + +;;----------------------------------------------------------------------------- +;; HOST hacking +;;----------------------------------------------------------------------------- + +(defun host-address (host &optional (family :internet)) + ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type stringable host) + (type (or null (member :internet :decnet :chaos) card8) family)) + (declare (values list)) + (labels ((no-host-error () + (error "Unknown host ~S" host)) + (no-address-error () + (error "Host ~S has no ~S address" host family))) + (let ((addr (comm:get-host-entry (string host) :fields '(:address)))) + (when (not addr) + (no-host-error)) + (ecase family + ((:internet 0) + (list :internet + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr))))))) + + +;;----------------------------------------------------------------------------- +;; Whether to use closures for requests or not. +;;----------------------------------------------------------------------------- + +;;; If this macro expands to non-NIL, then request and locking code is +;;; compiled in a much more compact format, as the common code is shared, and +;;; the specific code is built into a closure that is funcalled by the shared +;;; code. If your compiler makes efficient use of closures then you probably +;;; want to make this expand to T, as it makes the code more compact. + +(defmacro use-closures () + nil) + +(defun clx-macroexpand (form env) + (macroexpand form env)) + + +;;----------------------------------------------------------------------------- +;; Resource stuff +;;----------------------------------------------------------------------------- + +;;; Utilities + +(defun getenv (name) + (hcl:getenv name)) + +(defun get-host-name () + "Return the same hostname as gethostname(3) would" + ;; machine-instance probably works on a lot of lisps, but clisp is not + ;; one of them + (machine-instance)) + +(defun homedir-file-pathname (name) + (merge-pathnames (user-homedir-pathname) (pathname name))) + +;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if +;;; a resource manager isn't running. + +(defun default-resources-pathname () + (homedir-file-pathname ".Xdefaults")) + +;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the +;;; defaults have been loaded. + +(defun resources-pathname () + (or (let ((string (getenv "XENVIRONMENT"))) + (and string + (pathname string))) + (homedir-file-pathname + (concatenate 'string ".Xdefaults-" (get-host-name))))) + +;;; AUTHORITY-PATHNAME - The pathname of the authority file. + +(defun authority-pathname () + (or (let ((xauthority (getenv "XAUTHORITY"))) + (and xauthority + (pathname xauthority))) + (homedir-file-pathname ".Xauthority"))) + +;;; this particular defaulting behaviour is typical to most Unices, I think + +(defun get-default-display (&optional display-name) + "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY +if it is NIL. Display names have the format + + [protocol/] [hostname] : [:] displaynumber [.screennumber] + +There are two special cases in parsing, to match that done in the Xlib +C language bindings + + - If the hostname is ``unix'' or the empty string, any supplied + protocol is ignored and a connection is made using the :local + transport. + + - If a double colon separates hostname from displaynumber, the + protocol is assumed to be decnet. + +Returns a list of (host display-number screen protocol)." + (let* ((name (or display-name + (getenv "DISPLAY") + (error "DISPLAY environment variable is not set"))) + (slash-i (or (position #\/ name) -1)) + (colon-i (position #\: name :start (1+ slash-i))) + (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) + (host (subseq name (1+ slash-i) colon-i)) + (dot-i (and colon-i (position #\. name :start colon-i))) + (display (when colon-i + (parse-integer name + :start (if decnet-colon-p + (+ colon-i 2) + (1+ colon-i)) + :end dot-i))) + (screen (when dot-i + (parse-integer name :start (1+ dot-i)))) + (protocol + (cond ((or (string= host "") (string-equal host "unix")) :local) + (decnet-colon-p :decnet) + ((> slash-i -1) (intern + (string-upcase (subseq name 0 slash-i)) + :keyword)) + (t :internet)))) + (list host (or display 0) (or screen 0) protocol))) + + +;;----------------------------------------------------------------------------- +;; GC stuff +;;----------------------------------------------------------------------------- + +(defun gc-cleanup () + (declare (special *event-free-list* + *pending-command-free-list* + *reply-buffer-free-lists* + *gcontext-local-state-cache* + *temp-gcontext-cache*)) + (setq *event-free-list* nil) + (setq *pending-command-free-list* nil) + (when (boundp '*reply-buffer-free-lists*) + (fill *reply-buffer-free-lists* nil)) + (setq *gcontext-local-state-cache* nil) + (setq *temp-gcontext-cache* nil) + nil) + + +;;----------------------------------------------------------------------------- +;; DEFAULT-KEYSYM-TRANSLATE +;;----------------------------------------------------------------------------- + +;;; If object is a character, char-bits are set from state. +;;; +;;; [the following isn't implemented (should it be?)] +;;; If object is a list, it is an alist with entries: +;;; (base-char [modifiers] [mask-modifiers]) +;;; When MODIFIERS are specified, this character translation +;;; will only take effect when the specified modifiers are pressed. +;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. +;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. +;;; In ambiguous cases, the most specific translation is used. + +(defun default-keysym-translate (display state object) + (declare (type display display) + (type card16 state) + (type t object) + (ignore display state) + (clx-values t)) + object) + + +;;----------------------------------------------------------------------------- +;; Image stuff +;;----------------------------------------------------------------------------- + +;;; Types + +(deftype pixarray-1-element-type () + 'bit) + +(deftype pixarray-4-element-type () + '(unsigned-byte 4)) + +(deftype pixarray-8-element-type () + '(unsigned-byte 8)) + +(deftype pixarray-16-element-type () + '(unsigned-byte 16)) + +(deftype pixarray-24-element-type () + '(unsigned-byte 24)) + +(deftype pixarray-32-element-type () + '(unsigned-byte 32)) + +(deftype pixarray-1 () + '(array pixarray-1-element-type (* *))) + +(deftype pixarray-4 () + '(array pixarray-4-element-type (* *))) + +(deftype pixarray-8 () + '(array pixarray-8-element-type (* *))) + +(deftype pixarray-16 () + '(array pixarray-16-element-type (* *))) + +(deftype pixarray-24 () + '(array pixarray-24-element-type (* *))) + +(deftype pixarray-32 () + '(array pixarray-32-element-type (* *))) + +(deftype pixarray () + '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) + +(deftype bitmap () + 'pixarray-1) + +;;; WITH-UNDERLYING-SIMPLE-VECTOR + +#+sbcl +(defmacro with-underlying-simple-vector + ((variable element-type pixarray) &body body) + (declare (ignore element-type)) + `(#+cmu kernel::with-array-data #+sbcl sb-kernel:with-array-data + ((,variable ,pixarray) (start) (end)) + (declare (ignore start end)) + ,@body)) + +#+openmcl +(defmacro with-underlying-simple-vector ((variable element-type pixarray) + &body body) + (declare (ignore element-type)) + `(let* ((,variable (ccl::array-data-and-offset ,pixarray))) + ,@body)) + +;;; These are used to read and write pixels from and to CARD8s. + +;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. + +(defmacro read-image-load-byte (size position integer) + (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) + `(the (unsigned-byte ,size) + (ldb (byte ,size ,position) + (the card8 ,integer)))) + +;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from +;;; the appropriate number of CARD8s. + +(defmacro read-image-assemble-bytes (&rest bytes) + (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) + (let ((it (first bytes)) + (count 0)) + (dolist (byte (rest bytes)) + (setq it + `(dpb (the card8 ,byte) + (byte 8 ,(incf count 8)) + (the (unsigned-byte ,count) ,it)))) + `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) + +;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit +;;; pixel. + +(defmacro write-image-load-byte (position integer integer-size) + integer-size + (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) + `(the card8 + (ldb (byte 8 ,position) + (the (unsigned-byte ,integer-size) ,integer)))) + +;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit +;;; pixels. + +(defmacro write-image-assemble-bytes (&rest bytes) + (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) + (let ((size (floor 8 (length bytes))) + (it (first bytes)) + (count 0)) + (dolist (byte (rest bytes)) + (setq it `(dpb (the (unsigned-byte ,size) ,byte) + (byte ,size ,(incf count size)) + (the (unsigned-byte ,count) ,it)))) + `(the card8 ,it))) + +;;; The following table gives the bit ordering within bytes (when accessed +;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to +;;; 31, where bit 0 should be leftmost on the display. For a given byte +;;; labelled A-B, A is for the most significant bit of the byte, and B is +;;; for the least significant bit. +;;; +;;; legend: +;;; 1 scanline-unit = 8 +;;; 2 scanline-unit = 16 +;;; 4 scanline-unit = 32 +;;; M byte-order = MostSignificant +;;; L byte-order = LeastSignificant +;;; m bit-order = MostSignificant +;;; l bit-order = LeastSignificant +;;; +;;; +;;; format ordering +;;; +;;; 1Mm 00-07 08-15 16-23 24-31 +;;; 2Mm 00-07 08-15 16-23 24-31 +;;; 4Mm 00-07 08-15 16-23 24-31 +;;; 1Ml 07-00 15-08 23-16 31-24 +;;; 2Ml 15-08 07-00 31-24 23-16 +;;; 4Ml 31-24 23-16 15-08 07-00 +;;; 1Lm 00-07 08-15 16-23 24-31 +;;; 2Lm 08-15 00-07 24-31 16-23 +;;; 4Lm 24-31 16-23 08-15 00-07 +;;; 1Ll 07-00 15-08 23-16 31-24 +;;; 2Ll 07-00 15-08 23-16 31-24 +;;; 4Ll 07-00 15-08 23-16 31-24 + +;;; If you can write fast routines that can read and write pixarrays out of a +;;; buffer-bytes, do it! It makes the image code a lot faster. The +;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines +;;; return T if they can do it, NIL if they can't. + +;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s + +#+(or cmu sbcl) +(defun pixarray-element-size (pixarray) + (let ((eltype (array-element-type pixarray))) + (cond ((eq eltype 'bit) 1) + ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) + (second eltype)) + (t + (error "Invalid pixarray: ~S." pixarray))))) + +#+sbcl +(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy + height width) + (declare (type array-index source-width sx sy dest-width dx dy height width)) + #.(declare-buffun) + (sb-kernel:with-array-data ((sdata source) (sstart) (send)) + (declare (ignore send)) + (sb-kernel:with-array-data ((ddata dest) (dstart) (dend)) + (declare (ignore dend)) + (assert (and (zerop sstart) (zerop dstart))) + (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) + sx (index* sy source-width)) + (index+ src-idx source-width)) + (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) + dx (index* dy dest-width)) + (index+ dest-idx dest-width)) + (count height (1- count))) + ((zerop count)) + (declare (type array-index src-idx dest-idx count)) + (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width))))) + +#+sbcl +(defun fast-read-pixarray-using-bitblt (bbuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type (array * 2) pixarray)) + #.(declare-buffun) + (copy-bit-rect bbuf + (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) + (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 + pixarray + (index* (array-dimension pixarray 1) bits-per-pixel) + x y + height + (index* width bits-per-pixel)) + t) + +(defun fast-read-pixarray (bbuf boffset pixarray + x y width height padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type array-index boffset + padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (progn bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + (or + (let ((function + (or #+(or cmu) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-read-pixarray-using-bitblt)))) + (when function + (read-pixarray-internal + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel function + unit byte-lsb-first-p bit-lsb-first-p + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) + +;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s + +#+(or cmu sbcl) +(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (with-underlying-simple-vector (vector pixarray-24-element-type array) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24))))))) + t) + +#+(or cmu sbcl) +(defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel) + #.(declare-buffun) + (copy-bit-rect pixarray + (index* (array-dimension pixarray 1) bits-per-pixel) + x y + bbuf + (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) + (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 + height + (index* width bits-per-pixel)) + t) + +(defun fast-write-pixarray (bbuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (progn bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + (or + (let ((function + (or #+(or cmu) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-write-pixarray-using-bitblt)))) + (when function + (write-pixarray-internal + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel function + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ + unit byte-lsb-first-p bit-lsb-first-p))))) + +;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another + +(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) + (declare (type pixarray pixarray copy) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (progn pixarray copy x y width height bits-per-pixel nil) + (or + #+(or cmu) + (let* ((pixarray-padded-pixels-per-line + (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel)) + (copy-padded-pixels-per-line + (array-dimension copy 1)) + (copy-padded-bits-per-line + (* copy-padded-pixels-per-line bits-per-pixel))) + #-(or cmu) + (when (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod pixarray-padded-bits-per-line 32)) + (zerop (index-mod copy-padded-bits-per-line 32))) + (sys:bitblt boole-1 width height pixarray x y copy 0 0) + t) + #+(or cmu) + (when (index= (pixarray-element-size pixarray) + (pixarray-element-size copy) + bits-per-pixel) + (copy-bit-rect pixarray pixarray-padded-bits-per-line x y + copy copy-padded-bits-per-line 0 0 + height + (index* width bits-per-pixel)) + t)))) diff --git a/src/clx/dep-openmcl.lisp b/src/clx/dep-openmcl.lisp index 94d8670e340dc57e8dd6acd04f47c0c1978653a9..75b5fe9587ce331a65e1ecb2b95bb677041c8024 100644 --- a/src/clx/dep-openmcl.lisp +++ b/src/clx/dep-openmcl.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: dep-openmcl.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") - (in-package :xlib) (proclaim '(declaration array-register)) @@ -32,6 +29,17 @@ ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) +#-(or clx-overlapping-arrays (not clx-little-endian)) +(progn + (defconstant +word-0+ 0) + (defconstant +word-1+ 1) + + (defconstant +long-0+ 0) + (defconstant +long-1+ 1) + (defconstant +long-2+ 2) + (defconstant +long-3+ 3)) + +#-(or clx-overlapping-arrays clx-little-endian) (progn (defconstant +word-0+ 1) (defconstant +word-1+ 0) @@ -495,8 +503,12 @@ ;;; value changes. (defun process-block (whostate predicate &rest predicate-args) - (declare (dynamic-extern predicate-args)) - (apply #'ccl:process-wait whostate predicate predicate-args)) + (declare (ignore whostate)) + (declare (type function predicate)) + (loop + (when (apply predicate predicate-args) + (return)) + (ccl:process-allow-schedule))) ;;; PROCESS-WAKEUP: Check some other process' wait function. @@ -672,7 +684,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) (defmacro with-stack-list* ((var &rest elements) &body body) @@ -831,7 +843,7 @@ (declare (clx-values list)) (ecase family ((:internet nil 0) - (let* ((addr (ccl::host-as-inet-host host))) + (let* ((addr (ccl:lookup-hostname host))) (cons :internet (list (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) @@ -1116,7 +1128,7 @@ Returns a list of (host display-number screen protocol)." unit byte-lsb-first-p bit-lsb-first-p) (declare (ignore bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit - byte-lsb-first-p bit-lsp-first-p)) + byte-lsb-first-p bit-lsb-first-p)) nil) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another diff --git a/src/clx/depdefs.lisp b/src/clx/depdefs.lisp index bce7c5e7036d55792302d2bb51397ff2045ea54c..10b29acfcedafe248fd2f14af889d7489d601af3 100644 --- a/src/clx/depdefs.lisp +++ b/src/clx/depdefs.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: depdefs.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) ;;;------------------------------------------------------------------------- @@ -38,16 +35,6 @@ (lisp:rational x))) (deftype rational (&optional l u) `(lisp:rational ,l ,u))) -;;; DECLAIM - -#-clx-ansi-common-lisp -(defmacro declaim (&rest decl-specs) - (if (cdr decl-specs) - `(progn - ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) - decl-specs)) - `(proclaim ',(car decl-specs)))) - ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function. #-Genera @@ -63,18 +50,6 @@ #-(or lispm lcl3.0) (declaim (declaration arglist)) -;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has -;;; dynamic extent and therefore can be kept on the stack and not copied to -;;; the heap, even though the value is passed out of the function. - -#-(or clx-ansi-common-lisp lcl3.0) -(declaim (declaration dynamic-extent)) - -;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used. - -#-clx-ansi-common-lisp -(declaim (declaration ignorable)) - ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to ;;; indent calls to the function or macro containing the declaration. @@ -144,7 +119,7 @@ ;;; You must define this to match the real byte order. It is used by ;;; overlapping array and image code. -#+(or lispm vax little-endian Minima) +#+(or lispm vax (and (not sbcl) little-endian) Minima) (eval-when (eval compile load) (pushnew :clx-little-endian *features*)) @@ -171,6 +146,10 @@ (:big-endian) (:little-endian (pushnew :clx-little-endian *features*)))) +#+openmcl +(eval-when (:compile-toplevel :load-toplevel :execute) + #+little-endian-target (pushnew :clx-little-endian *features*)) + ;;; Steele's Common-Lisp states: "It is an error if the array specified ;;; as the :displaced-to argument does not have the same :element-type ;;; as the array being created" If this is the case on your lisp, then @@ -422,14 +401,7 @@ used, since NIL is the empty list.") (defmacro def-clx-class ((name &rest options) &body slots) (if (or (not (listp *def-clx-class-use-defclass*)) (member name *def-clx-class-use-defclass*)) - (let ((clos-package #+clx-ansi-common-lisp - (find-package :common-lisp) - #-clx-ansi-common-lisp - (or (find-package :clos) - (find-package :pcl) - (let ((lisp-pkg (find-package :lisp))) - (and (find-symbol (string 'defclass) lisp-pkg) - lisp-pkg)))) + (let ((clos-package (find-package :common-lisp)) (constructor t) (constructor-args t) (include nil) @@ -601,40 +573,6 @@ used, since NIL is the empty list.") ;; Printing routines. ;;----------------------------------------------------------------------------- -#-(or clx-ansi-common-lisp Genera) -(defun print-unreadable-object-function (object stream type identity function) - (declare #+lispm - (sys:downward-funarg function)) - (princ "#<" stream) - (when type - (let ((type (type-of object)) - (pcl-package (find-package :pcl))) - ;; Handle pcl type-of lossage - (when (and pcl-package - (symbolp type) - (eq (symbol-package type) pcl-package) - (string-equal (symbol-name type) "STD-INSTANCE")) - (setq type - (funcall (intern (symbol-name 'class-name) pcl-package) - (funcall (intern (symbol-name 'class-of) pcl-package) - object)))) - (prin1 type stream))) - (when (and type function) (princ " " stream)) - (when function (funcall function)) - (when (and (or type function) identity) (princ " " stream)) - (when identity (princ "???" stream)) - (princ ">" stream) - nil) - -#-(or clx-ansi-common-lisp Genera) -(defmacro print-unreadable-object - ((object stream &key type identity) &body body) - (if body - `(flet ((.print-unreadable-object-body. () ,@body)) - (print-unreadable-object-function - ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) - `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) - ;;----------------------------------------------------------------------------- ;; Image stuff @@ -680,7 +618,8 @@ used, since NIL is the empty list.") ;; Finding the server socket ;;----------------------------------------------------------------------------- -;; These are here because dep-openmcl.lisp and dependent.lisp both need them +;; These are here because dep-openmcl.lisp, dep-lispworks.lisp and +;; dependent.lisp need them (defconstant +X-unix-socket-path+ "/tmp/.X11-unix/X" "The location of the X socket") @@ -691,6 +630,7 @@ 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)) + ((or (and (> (length host) 10) (string= host "tmp/launch" :end1 10)) + (and (> (length host) 29) (string= host "private/tmp/com.apple.launchd" :end1 29))) (format nil "/~A:~D" host display)) (t nil))) diff --git a/src/clx/dependent.lisp b/src/clx/dependent.lisp index 24ce80cd460992753b920dfbce94b4c59921bf7d..3d4c985cd90b313f8ac4249b055d88f9bd8f2b87 100644 --- a/src/clx/dependent.lisp +++ b/src/clx/dependent.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: dependent.lisp,v 1.18 2009/06/17 18:28:11 rtoy Rel $") - (in-package :xlib) (proclaim '(declaration array-register)) @@ -692,7 +689,8 @@ (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) -#+(or cmu sbcl clisp) (progn +#+(or cmu sbcl clisp ecl) +(progn ;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI ;;; is irrational, there can't be a precise rational representation. In @@ -702,13 +700,11 @@ ;;; in the value, and see if the protocol encoding falls in the desired range ;;; (64'ths of a degree.) ;;; -(deftype angle () '(satisfies anglep)) + (deftype angle () '(satisfies anglep)) -(defun anglep (x) - (and (typep x 'real) - (<= (* -360 64) (radians->int16 x) (* 360 64)))) - -) + (defun anglep (x) + (and (typep x 'real) + (<= (* -360 64) (radians->int16 x) (* 360 64))))) ;;----------------------------------------------------------------------------- @@ -866,7 +862,7 @@ ;;; MAKE-PROCESS-LOCK: Creating a process lock. -#-(or LispM excl Minima sbcl (and cmu mp)) +#-(or LispM excl Minima sbcl (and cmu mp) (and ecl threads)) (defun make-process-lock (name) (declare (ignore name)) nil) @@ -895,6 +891,10 @@ (defun make-process-lock (name) (sb-thread:make-mutex :name name)) +#+(and ecl threads) +(defun make-process-lock (name) + (mp:make-lock :name name :recursive t)) + ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN @@ -903,7 +903,7 @@ ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient -#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) ) +#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) (and ecl threads)) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore locator display whostate timeout)) `(progn ,@body)) @@ -946,6 +946,14 @@ `(progn ,@body)) +#+(and ecl threads) +(defmacro holding-lock ((lock display &optional (whostate "CLX wait") + &key timeout) + &body body) + (declare (ignore display)) + `(mp::with-lock (,lock) + ,@body)) + #+sbcl (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) @@ -1113,7 +1121,7 @@ ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. -#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp)) +#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp) (and ecl threads)) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (or (apply predicate predicate-args) @@ -1122,19 +1130,13 @@ #+Genera (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) + (dynamic-extent predicate)) (apply #'process:block-process whostate predicate predicate-args)) #+(and lispm (not Genera)) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) + (dynamic-extent predicate)) (apply #'global:process-wait whostate predicate predicate-args)) #+excl @@ -1179,6 +1181,14 @@ (return)) (yield))) +#+(and ecl threads) +(defun process-block (whostate predicate &rest predicate-args) + (declare (ignore whostate)) + (declare (type function predicate)) + (loop + (when (apply predicate predicate-args) + (return)) + (mp:process-yield))) ;;; FIXME: the below implementation for threaded PROCESS-BLOCK using ;;; queues and condition variables might seem better, but in fact it @@ -1215,7 +1225,7 @@ (declaim (inline process-wakeup)) -#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp)) +#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp) (and ecl threads)) (defun process-wakeup (process) (declare (ignore process)) nil) @@ -1249,6 +1259,12 @@ (defun process-wakeup (process) (declare (ignore process)) (yield)) + +#+(and ecl threads) +(defun process-wakeup (process) + (declare (ignore process)) + (mp:process-yield)) + #+(or) (defun process-wakeup (process) (declare (ignore process)) @@ -1267,7 +1283,7 @@ ;;; Default return NIL, which is acceptable even if there is a scheduler. -#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp)) +#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp) (and ecl threads)) (defun current-process () nil) @@ -1288,7 +1304,7 @@ (defun current-process () (minima:current-process)) -#+(and cmu mp) +#+(or (and cmu mp) (and ecl threads)) (defun current-process () mp:*current-process*) @@ -1298,7 +1314,7 @@ ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. -#-(or lispm excl lcl3.0 Minima cmu) +#-(or lispm excl lcl3.0 Minima cmu sbcl) (defmacro without-interrupts (&body body) `(progn ,@body)) @@ -1322,6 +1338,10 @@ (defmacro without-interrupts (&body body) `(system:without-interrupts ,@body)) +#+ecl +(defmacro without-interrupts (&body body) + `(mp:without-interrupts ,@body)) + #+sbcl (defvar *without-interrupts-sic-lock* (sb-thread:make-mutex :name "lock simulating *without-interrupts*")) @@ -1544,7 +1564,25 @@ (cdr (host-address host))) :foreign-port (+ *x-tcp-port* display))) -#+CMU +#+(or sbcl ecl) +(defun open-x-stream (host display protocol) + (declare (ignore protocol) + (type (integer 0) display)) + (socket-make-stream + (let ((unix-domain-socket-path (unix-socket-path-from-host host display))) + (if unix-domain-socket-path + (let ((s (make-instance 'local-socket :type :stream))) + (socket-connect s unix-domain-socket-path) + s) + (let ((host (car (host-ent-addresses (get-host-by-name host))))) + (when host + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) + (socket-connect s host (+ 6000 display)) + s))))) + :element-type '(unsigned-byte 8) + :input t :output t :buffering :none)) + +#+cmu (defun open-x-stream (host display protocol) (let ((stream-fd (ecase protocol @@ -1585,34 +1623,6 @@ fd)))))) (system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8)))) -#+sbcl -(defun open-x-stream (host display protocol) - (declare (ignore protocol) - (type (integer 0) display)) - (let ((local-socket-path (unix-socket-path-from-host host display))) - (socket-make-stream - (if local-socket-path - (let ((s (make-instance 'local-socket :type :stream))) - (socket-connect s local-socket-path) - s) - (let ((host (car (host-ent-addresses (get-host-by-name host))))) - (when host - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) - (socket-connect s host (+ 6000 display)) - s)))) - :element-type '(unsigned-byte 8) - :input t :output t :buffering :none))) - -#+ecl -(defun open-x-stream (host display protocol) - (declare (ignore protocol) - (type (integer 0) display)) - (let (socket) - (if (or (string= host "") (string= host "unix")) ; AF_UNIX doamin socket - (sys::open-unix-socket-stream - (format nil "~A~D" +X-unix-socket-path+ display)) - (si::open-client-stream host (+ 6000 display))))) - ;;; BUFFER-READ-DEFAULT - read data from the X stream #+(or Genera explorer) @@ -1844,7 +1854,7 @@ ;;; You are STRONGLY encouraged to write a specialized version ;;; of buffer-write-default that does block transfers. -#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp) +#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp ecl) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) @@ -2113,7 +2123,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) #-lispm @@ -2124,7 +2134,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) @@ -2369,31 +2379,10 @@ (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (apply #'sys:signal condition keyargs)) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (sys:signal (apply #'zl:make-condition condition keyargs) - :proceed-types proceed-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition keyargs)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp)) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) -#+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) @@ -2416,175 +2405,8 @@ (ext::disable-clx-event-handling disp))) (error condx))) -#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+lcl3.0 -(defmacro define-condition (name parent-types &optional slots &rest args) - `(lcl:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and CMU (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(common-lisp:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and lispm (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &body options) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil)) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - `(within-definition (,name define-condition) - (zl:defflavor ,name ,slot-names ,parent-types - :initable-instance-variables - #-Genera - (:accessor-prefix ,conc-name) - #+Genera - (:conc-name ,conc-name) - #-Genera - (:outside-accessible-instance-variables ,@slot-names) - #+Genera - (:readable-instance-variables ,@slot-names)) - ,(when reporter ;; when no reporter, parent's is inherited - `(zl:defmethod #-Genera (,name :report) - #+Genera (dbg:report ,name) (stream) - ,(if (stringp reporter) - `(write-string ,reporter stream) - `(,reporter global:self stream)) - global:self)) - (zl:compile-flavor-methods ,name) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ',name))) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(zl:defflavor x-error () (global:error)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defflavor x-error - ((dbg:proceed-types '(:continue)) ; - continue-format-string) - (sys:error) - (:initable-instance-variables continue-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (scl:make-instance x-error) (&rest ignore) - (when (not (sys:variable-boundp continue-format-string)) - (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (dbg:proceed x-error :continue) () - :continue) - -#+(and Genera (not clx-ansi-common-lisp)) -(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) - (format stream continue-format-string)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (define-condition x-error (error) ()) -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defstruct x-error - report-function) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defmacro define-condition (name parent-types &body options) - ;; Define a structure that when printed displays an error message - (flet ((reporter-for-condition (name) - (xintern "." name '-reporter.))) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil) - (condition (gensym)) - (stream (gensym)) - (report-function (reporter-for-condition name))) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - (unless reporter - (setq report-function (reporter-for-condition (first parent-types)))) - `(within-definition (,name define-condition) - (defstruct (,name (:conc-name ,(intern conc-name)) - (:print-function condition-print) - (:include ,(first parent-types) - (report-function ',report-function))) - ,@slot-names) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ,(when reporter - `(defun ,report-function (,condition ,stream) - ,(if (stringp reporter) - `(write-string ,reporter ,stream) - `(,reporter ,condition ,stream)) - ,condition)) - ',name)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun condition-print (condition stream depth) - (declare (type x-error condition) - (type stream stream) - (ignore depth)) - (if *print-escape* - (print-unreadable-object (condition stream :type t)) - (funcall (x-error-report-function condition) condition stream)) - condition) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun make-condition (type &rest slot-initializations) - (declare (dynamic-extent slot-initializations)) - (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) - (symbol-package type)))) - (apply make-function slot-initializations))) - -#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(define-condition type-error (x-error) - ((datum :reader type-error-datum :initarg :datum) - (expected-type :reader type-error-expected-type :initarg :expected-type)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (type-error-expected-type condition))))) - ;;----------------------------------------------------------------------------- ;; HOST hacking @@ -2738,6 +2560,9 @@ (si:memref-int addr 3 0 :unsigned-byte)))))) (ff:free-cstruct hostent))))) +;#+sbcl +;(require :sockets) + #+CMU (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) @@ -2749,24 +2574,39 @@ (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) - (let ((hostent (ext:lookup-host-entry (string host)))) + (let ((hostent #+rwi-sockets(ext:lookup-host-entry (string host)) + #+mna-sockets(net.sbcl.sockets:look-up-host-entry + (string host)) + #+db-sockets(sockets:get-host-by-name (string host)))) (when (not hostent) (no-host-error)) (ecase family ((:internet nil 0) - (unless (= (ext::host-entry-addr-type hostent) 2) + #+rwi-sockets(unless (= (ext::host-entry-addr-type hostent) 2) + (no-address-error)) + #+mna-sockets(unless (= (net.sbcl.sockets::host-entry-addr-type hostent) 2) + (no-address-error)) + ;; the following form is for use with SBCL and Daniel + ;; Barlow's socket package + #+db-sockets(unless (sockets:host-ent-address hostent) (no-address-error)) (append (list :internet) + #+rwi-sockets (let ((addr (first (ext::host-entry-addr-list hostent)))) (list (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))))))))) - -;#+sbcl -;(require :sockets) - - + (ldb (byte 8 0) addr))) + #+mna-sockets + (let ((addr (first (net.sbcl.sockets::host-entry-addr-list hostent)))) + (list (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr))) + ;; the following form is for use with SBCL and Daniel + ;; Barlow's socket package + #+db-sockets(coerce (sockets:host-ent-address hostent) + 'list))))))) #+sbcl (defun host-address (host &optional (family :internet)) @@ -2899,10 +2739,9 @@ "Return the same hostname as gethostname(3) would" ;; machine-instance probably works on a lot of lisps, but clisp is not ;; one of them - #+(or cmu sbcl) (machine-instance) + #+(or cmu sbcl ecl) (machine-instance) ;; resources-pathname was using short-site-name for this purpose #+excl (short-site-name) - #+ecl (si:getenv "HOST") #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s))) #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented")) @@ -3001,38 +2840,6 @@ Returns a list of (host display-number screen protocol)." (si:define-gc-cleanup clx-cleanup ("CLX Cleanup") (gc-cleanup)) - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - #+ticl (ticl:*print-structure* t) - #+lucid (lucid::*print-structure* t)) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE @@ -3049,7 +2856,7 @@ Returns a list of (host display-number screen protocol)." ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) +#+lispm (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) @@ -3072,7 +2879,7 @@ Returns a list of (host display-number screen protocol)." (setf (char-bit object :hyper) 1))) object) -#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp) +#-lispm (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) diff --git a/src/clx/display.lisp b/src/clx/display.lisp index c9e1ab5e45acef0467f1fb13dad947523ac9b6c6..b96357d1a34f8126bee31a00305bf92a257d5b17 100644 --- a/src/clx/display.lisp +++ b/src/clx/display.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: display.lisp,v 1.16 2010/11/16 19:13:55 rtoy Exp $") - (in-package :xlib) ;;; Authorizaton @@ -64,7 +61,8 @@ (if (null family-id) (list nil nil nil nil nil) (let* ((address-data (read-short-length-vector stream)) - (number (parse-integer (read-short-length-string stream))) + (num-string (read-short-length-string stream)) + (number (when (string/= num-string "") (parse-integer num-string))) (name (read-short-length-string stream)) (data (read-short-length-vector stream)) (family (car (rassoc family-id *protocol-families*)))) @@ -117,10 +115,8 @@ (read-xauth-entry stream) (unless family (return)) (when (and (eql family protocol) - (or (equal host-address address) - (and (eql family :local) - (equal address "localhost"))) - (= number display) + (equal host-address address) + (or (null number) (= number display)) (let ((pos1 (position name *known-authorizations* :test #'string=))) (and pos1 @@ -328,7 +324,6 @@ ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.with-event-queue-body. () ,@body)) - #+clx-ansi-common-lisp (declare (dynamic-extent #'.with-event-queue-body.)) (with-event-queue-function ,display ,timeout #'.with-event-queue-body.)) @@ -344,12 +339,9 @@ (declare (type display display) (type (or null number) timeout) (type function function) - #+clx-ansi-common-lisp (dynamic-extent function) ;; FIXME: see SBCL bug #243 - (ignorable display timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) + (ignorable display timeout)) (with-event-queue (display :timeout timeout :inline t) (funcall function))) @@ -390,38 +382,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. diff --git a/src/clx/excldefsys.lisp b/src/clx/excldefsys.lisp index 379c4f971eef356fe9606b3cb718cbb1af99a475..abbc5dc7135111047aee6bc8d6d918ed37389bac 100644 --- a/src/clx/excldefsys.lisp +++ b/src/clx/excldefsys.lisp @@ -11,9 +11,6 @@ ;;; implied warranty. ;;; -#+cmu -(ext:file-comment "$Id") - (in-package :xlib :use '(:foreign-functions :lisp :excl)) #+allegro diff --git a/src/clx/excldep.lisp b/src/clx/excldep.lisp index b5ea9c5b69a76ce22fa44868219b741c0dc78286..940a70f7cdfb642103496a8998a09e61c2c19813 100644 --- a/src/clx/excldep.lisp +++ b/src/clx/excldep.lisp @@ -13,9 +13,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: excldep.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (eval-when (compile load eval) diff --git a/src/clx/big-requests.lisp b/src/clx/extensions/big-requests.lisp similarity index 93% rename from src/clx/big-requests.lisp rename to src/clx/extensions/big-requests.lisp index a854866a350479932e228110cf3f2bc99ccfb50b..ea566514589df07224062ce9ee57b47905a359e3 100644 --- a/src/clx/big-requests.lisp +++ b/src/clx/extensions/big-requests.lisp @@ -12,9 +12,6 @@ ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -#+cmu -(ext:file-comment "$Id: big-requests.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") - (in-package "XLIB") ;;; No new events or errors are defined by this extension. (Big diff --git a/src/clx/dpms.lisp b/src/clx/extensions/dpms.lisp similarity index 98% rename from src/clx/dpms.lisp rename to src/clx/extensions/dpms.lisp index 669dd516a8c28789ae766596ad7c0eccf62a7305..6ee33bc3a391e74842c1ecc9ca511bc7e3390443 100644 --- a/src/clx/dpms.lisp +++ b/src/clx/extensions/dpms.lisp @@ -13,10 +13,7 @@ ;;;; any purpose of the information in this document. This documentation is ;;;; provided ``as is'' without express or implied warranty. -#+cmu -(ext:file-comment "$Id: dpms.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :dpms +(defpackage #:xlib/dpms (:use :common-lisp) (:import-from :xlib "DEFINE-EXTENSION" @@ -39,7 +36,7 @@ "DPMS-FORCE-LEVEL" "DPMS-INFO")) -(in-package :dpms) +(in-package #:xlib/dpms) (define-extension "DPMS") diff --git a/src/clx/gl.lisp b/src/clx/extensions/gl.lisp similarity index 98% rename from src/clx/gl.lisp rename to src/clx/extensions/gl.lisp index 1d7582d1def0ef4daac13eec9b364ce61907e20e..241c06609d2d20370ea469834789bc9a511388d9 100644 --- a/src/clx/gl.lisp +++ b/src/clx/extensions/gl.lisp @@ -1,9 +1,6 @@ -#+cmu -(ext:file-comment "$Id: gl.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :gl +(defpackage #:xlib/gl (:use :common-lisp :xlib) - (:import-from :glx + (:import-from :xlib/glx "*CURRENT-CONTEXT*" "CONTEXT" "CONTEXT-P" @@ -1156,7 +1153,7 @@ )) -(in-package :gl) +(in-package #:xlib/gl) @@ -2138,6 +2135,27 @@ value) +#+lispworks +(progn + (defun %single-float-bits (x) + (declare (type single-float x)) + (fli:with-dynamic-foreign-objects ((bits :int32)) + (fli:with-coerced-pointer (pointer :type :lisp-single-float) bits + (setf (fli:dereference pointer) x)) + (fli:dereference bits))) + + (declaim (notinline aset-float32)) + (defun aset-float32 (value array index) + (declare (type (or short-float single-float) value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((bits (%single-float-bits (coerce value 'single-float)))) + (declare (type (unsigned-byte 32) bits)) + (aset-card32 bits array index)) + value)) + + #+sbcl (defun aset-float64 (value array index) (declare (type double-float value) @@ -2180,6 +2198,36 @@ value) +#+lispworks +(progn + (fli:define-c-struct %uint64 + (high :uint32) + (low :uint32)) + + (defun %double-float-bits (x) + (declare (type double-float x)) + (fli:with-dynamic-foreign-objects ((bits %uint64)) + (fli:with-coerced-pointer (pointer :type :lisp-double-float) bits + (setf (fli:dereference pointer) x)) + + (values (fli:foreign-slot-value bits 'low :type :uint32 :object-type '%uint64) + (fli:foreign-slot-value bits 'high :type :uint32 :object-type '%uint64)))) + + (declaim (notinline aset-float64)) + (defun aset-float64 (value array index) + (declare (type double-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (multiple-value-bind (low high) + (%double-float-bits value) + (declare (type (unsigned-byte 32) low high)) + + (aset-card32 low array index) + (aset-card32 high array (the array-index (+ index 4)))) + value)) + + (eval-when (:compile-toplevel :load-toplevel :execute) (defun byte-width (type) (ecase type @@ -2593,7 +2641,7 @@ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ - #.+max-convolution-width+) + #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) @@ -2619,7 +2667,7 @@ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ - #.+max-convolution-width+) + #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) diff --git a/src/clx/glx.lisp b/src/clx/extensions/glx.lisp similarity index 99% rename from src/clx/glx.lisp rename to src/clx/extensions/glx.lisp index b5c275035c51c73f4fb00c127d797871b26084be..35f723e07afe47781cbc7b262f74484459ae6b4e 100644 --- a/src/clx/glx.lisp +++ b/src/clx/extensions/glx.lisp @@ -1,7 +1,4 @@ -#+cmu -(ext:file-comment "$Id: glx.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :glx +(defpackage #:xlib/glx (:use :common-lisp :xlib) (:import-from :xlib "DEFINE-ACCESSOR" @@ -72,11 +69,11 @@ )) -(in-package :glx) - - -(declaim (optimize (debug 3) (safety 3))) +(in-package #:xlib/glx) +;;; Generally don't want this declamation to have load-time effects +(eval-when (:compile-toplevel) + (declaim (optimize (debug 3) (safety 3)))) (define-extension "GLX" :events (:glx-pbuffer-clobber) @@ -599,7 +596,7 @@ Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." (let* ((ctx *current-context*) (display (context-display ctx))) ;; Make sure all rendering commands are sent away. - (glx:render) + (render) (with-buffer-request (display (extension-opcode display "GLX")) (data +swap-buffers+) ;; *** GLX_CONTEXT_TAG diff --git a/src/clx/screensaver.lisp b/src/clx/extensions/screensaver.lisp similarity index 100% rename from src/clx/screensaver.lisp rename to src/clx/extensions/screensaver.lisp diff --git a/src/clx/shape.lisp b/src/clx/extensions/shape.lisp similarity index 98% rename from src/clx/shape.lisp rename to src/clx/extensions/shape.lisp index 5804a8a34824941e38b7b1eb9d57a21961ab004d..6171c67ca1efc501fbeba24a8dc39dfe16c41794 100644 --- a/src/clx/shape.lisp +++ b/src/clx/extensions/shape.lisp @@ -20,9 +20,6 @@ ;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz -#+cmu -(ext:file-comment "$Id: shape.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export '(shape-query-version diff --git a/src/clx/xinerama.lisp b/src/clx/extensions/xinerama.lisp similarity index 98% rename from src/clx/xinerama.lisp rename to src/clx/extensions/xinerama.lisp index ee688e64b404e0d4c04317ac173337d3f83162f3..3bb404c650bc704e14c8e4be2f25ea16e10cdcd2 100644 --- a/src/clx/xinerama.lisp +++ b/src/clx/extensions/xinerama.lisp @@ -12,7 +12,7 @@ ;;; This is an implementation of the XINERAMA extension. It does not ;;; include the obsolete PanoramiX calls. -(defpackage "XLIB.XINERAMA" +(defpackage #:xlib/xinerama (:use "COMMON-LISP" "XLIB") (:nicknames "XINERAMA") (:import-from "XLIB" @@ -33,7 +33,7 @@ "XINERAMA-QUERY-VERSION" "XINERAMA-IS-ACTIVE" "XINERAMA-QUERY-SCREENS")) -(in-package "XINERAMA") +(in-package #:xlib/xinerama) (define-extension "XINERAMA") diff --git a/src/clx/xrender.lisp b/src/clx/extensions/xrender.lisp similarity index 92% rename from src/clx/xrender.lisp rename to src/clx/extensions/xrender.lisp index a0b3b961ba6e4a8c325309ae135b6047933a2439..6713668c01a2ba48d85461a6e904c4b7c45f0c0f 100644 --- a/src/clx/xrender.lisp +++ b/src/clx/extensions/xrender.lisp @@ -3,8 +3,7 @@ ;;; Title: The X Render Extension ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de> -#+cmu -(ext:file-comment "$Id: xrender.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") +;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $ ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2002, 2003 by Gilbert Baumann @@ -128,6 +127,8 @@ render-query-version ;; render-query-picture-formats render-fill-rectangle + render-triangles + render-trapezoids render-composite render-create-glyph-set render-reference-glyph-set @@ -196,6 +197,24 @@ ;; We do away with the distinction between pict-format and ;; picture-format-info. That is we cache picture-format-infos. +(defstruct picture-format + display + (id 0 :type (unsigned-byte 29)) + type + depth + red-byte + green-byte + blue-byte + alpha-byte + colormap) + +(def-clx-class (glyph-set (:copier nil) + ) + (id 0 :type resource-id) + (display nil :type (or null display)) + (plist nil :type list) ; Extension hook + (format)) + (defstruct render-info major-version minor-version @@ -298,17 +317,6 @@ by every function, which attempts to generate RENDER requests." ;;; picture format -(defstruct picture-format - display - (id 0 :type (unsigned-byte 29)) - type - depth - red-byte - green-byte - blue-byte - alpha-byte - colormap) - (defmethod print-object ((object picture-format) stream) (let ((abbrev (with-output-to-string (bag) @@ -517,13 +525,15 @@ by every function, which attempts to generate RENDER requests." (let ((display (picture-display picture))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreePicture+) - (picture picture)))) + (picture picture)) + (deallocate-resource-id display (picture-id picture) 'picture))) (defun render-free-glyph-set (glyph-set) (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphSet+) - (glyph-set glyph-set)))) + (glyph-set glyph-set)) + (deallocate-resource-id display (glyph-set-id glyph-set) 'glyph-set))) (defun render-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) @@ -570,16 +580,16 @@ by every function, which attempts to generate RENDER requests." (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFillRectangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad + (render-op op) + (pad8 0) + (pad16 0) (resource-id (picture-id picture)) (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) (int16 x1) (int16 y1) (card16 w) (card16 h)))) ;; fill rectangles, colors. -(defun render-triangles-1 (picture op source src-x src-y format coord-sequence) +(defun render-triangles (picture op source src-x src-y format coord-sequence) ;; For performance reasons we do a special typecase on (simple-array ;; (unsigned-byte 32) (*)), so that it'll be possible to have high ;; performance rasters. @@ -587,17 +597,18 @@ by every function, which attempts to generate RENDER requests." '(let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTriangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - (picture-format format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) )))) + (labels ((funk (x) (ash x 16))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderTriangles+) + (render-op op) + (pad8 0) + (pad16 0) + (resource-id (picture-id source)) + (resource-id (picture-id picture)) + (picture-format format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32 :transform #'funk) coord-sequence)))))) (typecase coord-sequence ((simple-array (unsigned-byte 32) (*)) (locally @@ -694,7 +705,7 @@ by every function, which attempts to generate RENDER requests." (data +X-RenderSetPictureFilter+) (resource-id (picture-id picture)) (card16 (length filter)) - (card16 0) ;pad + (pad16 0) ((sequence :format card8) (map 'vector #'char-code filter))))) @@ -705,25 +716,26 @@ by every function, which attempts to generate RENDER requests." ) ||# -(defun render-trapezoids-1 (picture op source src-x src-y mask-format coord-sequence) +(defun render-trapezoids (picture op source src-x src-y mask-format coord-sequence) ;; coord-sequence is top bottom - ;; line-1-x1 line-1-y1 line-1-x2 line-1-y2 - ;; line-2-x1 line-2-y1 line-2-x2 line-2-y2 ... + ;; left-x1 left-y1 left-x2 left-y2 + ;; right-x1 right-y1 right-x2 right-y2 ... ;; (let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTrapezoids+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - ((or (member :none) picture-format) mask-format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) ))) + (labels ((funk (x) (ash x 16))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderTrapezoids+) + (render-op op) + (pad8 0) + (pad16 0) + (resource-id (picture-id source)) + (resource-id (picture-id picture)) + ((or (member :none) picture-format) mask-format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32 :transform #'funk) coord-sequence))))) (defun render-composite (op source mask dest @@ -735,9 +747,9 @@ by every function, which attempts to generate RENDER requests." (synchronise-picture-state dest) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderComposite+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad + (render-op op) + (pad8 0) + (pad16 0) (resource-id (picture-id source)) (resource-id (if mask (picture-id mask) 0)) (resource-id (picture-id dest)) @@ -750,13 +762,6 @@ by every function, which attempts to generate RENDER requests." (card16 width) (card16 height)))) -(def-clx-class (glyph-set (:copier nil) - ) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - (format)) - (defun render-create-glyph-set (format &key glyph-set) (let ((display (picture-format-display format))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) @@ -803,14 +808,16 @@ by every function, which attempts to generate RENDER requests." (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCompositeGlyphs8+) (render-op alu) - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (picture source) (picture dest) ((or (member :none) picture-format) mask-format) (glyph-set glyph-set) (int16 src-x) (int16 src-y) (card8 (- end start)) ;length of glyph elt - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (int16 dest-x) (int16 dest-y) ;dx, dy ((sequence :format card8) sequence)))) @@ -832,7 +839,8 @@ by every function, which attempts to generate RENDER requests." (data ,opcode) (length request-length) (render-op ,alu) - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (picture ,source) (picture ,dest) ((or (member :none) picture-format) ,mask-format) @@ -931,17 +939,27 @@ by every function, which attempts to generate RENDER requests." (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (let* ((byte-per-line (* 4 (ceiling - (* w (picture-format-depth (glyph-set-format glyph-set))) - 32))) - (request-length (+ 28 - (* h byte-per-line)))) + (let* ((padded-bytes-per-line + (index* (index-ceiling + (index* w (picture-format-depth + (glyph-set-format glyph-set))) + 32) + 4)) + (request-bytes + (index+ 28 (index* h padded-bytes-per-line))) + (max-bytes-per-request + (index* (index- (display-max-request-length display) 6) 4))) + ;; INV: we can do better – if at least one scanline of the + ;; image fits in the request, we may render glyph in a loop + ;; like it's done in a function `put-image' in `image.lisp'. + (when (> request-bytes max-bytes-per-request) + (error "Glyph won't fit in a single request")) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphs+) - (length (ceiling request-length 4)) + (length (ceiling request-bytes 4)) (glyph-set glyph-set) - (card32 1) ;number glyphs - (card32 id) ;id + (card32 1) ;number glyphs + (card32 id) ;id (card16 w) (card16 h) (int16 x-origin) @@ -952,7 +970,7 @@ by every function, which attempts to generate RENDER requests." (setf (buffer-boffset display) (advance-buffer-offset 28)) (let ((im (create-image :width w :height h :depth 8 :data data))) (write-image-z display im 0 0 w h - byte-per-line ;padded bytes per line + padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) (defun render-add-glyph-from-picture (glyph-set picture @@ -1153,3 +1171,21 @@ by every function, which attempts to generate RENDER requests." (card16 x) (card16 y)) cursor))) + +(defun render-create-anim-cursor (cursors delays) + "Create animated cursor. cursors length must be the same as delays length." + (let ((display (cursor-display (first cursors)))) + (ensure-render-initialized display) + (let* ((cursor (make-cursor :display display)) + (cid (allocate-resource-id display cursor 'cursor)) + (cursors-length (length cursors)) + (cursors-delays (make-list (* 2 (length cursors))))) + (setf (xlib:cursor-id cursor) cid) + (dotimes (i cursors-length) + (setf (elt cursors-delays (* 2 i)) (cursor-id (elt cursors i)) + (elt cursors-delays (1+ (* 2 i))) (elt delays i))) + (xlib::with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderCreateAnimCursor+) + (resource-id cid) + ((sequence :format card32) cursors-delays)) + cursor))) diff --git a/src/clx/xtest.lisp b/src/clx/extensions/xtest.lisp similarity index 98% rename from src/clx/xtest.lisp rename to src/clx/extensions/xtest.lisp index 587a845b8d4b321c2d4eb113d2a5e32e044469ef..6c543e9e1303b09adf48fdec9f1a7d09549a54ab 100644 --- a/src/clx/xtest.lisp +++ b/src/clx/extensions/xtest.lisp @@ -10,7 +10,7 @@ ;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard ;;; * Add the missing (declare (type ... -(defpackage :xtest +(defpackage #:xlib/xtest (:use :common-lisp :xlib) (:import-from :xlib #:data @@ -44,7 +44,7 @@ #:fake-key-event #:grab-control)) -(in-package :xtest) +(in-package #:xlib/xtest) (define-extension "XTEST") diff --git a/src/clx/xvidmode.lisp b/src/clx/extensions/xvidmode.lisp similarity index 99% rename from src/clx/xvidmode.lisp rename to src/clx/extensions/xvidmode.lisp index a58b38b078e274118949a86c535d8623d3877a10..783f1fa99881ff9e470d5fe5f3e5941346f948e8 100644 --- a/src/clx/xvidmode.lisp +++ b/src/clx/extensions/xvidmode.lisp @@ -35,9 +35,6 @@ ;;; constructed as well as to indentify any obsolete/wrong ;;; functions I made. -#+cmu -(ext:file-comment "$Id: xvidmode.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export '(mode-info @@ -176,6 +173,14 @@ (error "screen ~A not found in display ~A" screen display) position))) +(declaim (inline __card32->card16__)) +(defun __card32->card16__ (i) + (declare (type card32 i)) + #+clx-little-endian + (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) + #-clx-little-endian + (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; public XFree86-VidMode Extension routines ;;;; @@ -723,11 +728,3 @@ x and y keyword parameters value (zero will be theire default value)." (setf (svref v (incf index)) w1 (svref v (incf index)) w2)))) v))) - -(declaim (inline __card32->card16__)) -(defun __card32->card16__ (i) - (declare (type card32 i)) - #+clx-little-endian - (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) - #-clx-little-endian - (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) diff --git a/src/clx/fonts.lisp b/src/clx/fonts.lisp index a9225fa4ddffe6b45f3166a8573e69bebc175f98..d00e4b8a7a110ffce27ad090fb7227e2e3553d23 100644 --- a/src/clx/fonts.lisp +++ b/src/clx/fonts.lisp @@ -16,9 +16,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: fonts.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) ;; The char-info stuff is here instead of CLX because of uses of int16->card16. @@ -255,7 +252,8 @@ (setf (display-font-cache display) (delete font (display-font-cache display))) ;; Close the font (with-buffer-request (display +x-closefont+) - (resource-id id))))) + (resource-id id)) + (deallocate-resource-id display id 'font)))) (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) (declare (type display display) diff --git a/src/clx/gcontext.lisp b/src/clx/gcontext.lisp index 052d16b3e1d196673095d025f8de3ace2960e26b..23d6a22ffb69ec3844eef65d742d46fbb54ea1ab 100644 --- a/src/clx/gcontext.lisp +++ b/src/clx/gcontext.lisp @@ -42,9 +42,6 @@ ;;; because they don't run in a multi-processing shared-address space ;;; environment. -#+cmu -(ext:file-comment "$Id: gcontext.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) ;; GContext state accessors diff --git a/src/clx/generalock.lisp b/src/clx/generalock.lisp index 21c25705e3cec0f61bfab4872c6d3cb03101b7ff..cbf95a38a5e5502053b658d8db6c6421455394ea 100644 --- a/src/clx/generalock.lisp +++ b/src/clx/generalock.lisp @@ -10,9 +10,6 @@ ;;; Symbolics, Inc. provides this software "as is" without ;;; express or implied warranty. -#+cmu -(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/src/clx/graphics.lisp b/src/clx/graphics.lisp index b9498489ad1e56616489013dd0e0332d39fe4735..9f3f327ed8ab8b796cb9b07f6bc4e331d9858409 100644 --- a/src/clx/graphics.lisp +++ b/src/clx/graphics.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: graphics.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defvar *inhibit-appending* nil) diff --git a/src/clx/image.lisp b/src/clx/image.lisp index 882f8c2209a398ef69df7e217793a0d738632ff1..8eb47af3386457be4cd4a5fc0c5dcc4aa5e78f54 100644 --- a/src/clx/image.lisp +++ b/src/clx/image.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: image.lisp,v 1.13 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defmacro with-image-data-buffer ((buffer size) &body body) diff --git a/src/clx/input.lisp b/src/clx/input.lisp index 7ee2adc6cc843ffa42cc2b6f7ef29a4b6af7f901..50a448d5a119393226052c1273384841287cf7ae 100644 --- a/src/clx/input.lisp +++ b/src/clx/input.lisp @@ -25,9 +25,6 @@ ;;; ------------------------------------------------------------------------------------- ;;; 12/10/87 LGO Created -#+cmu -(ext:file-comment "$Id: input.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) ;; Event Resource @@ -391,10 +388,7 @@ (type generalized-boolean force-output-p) (dynamic-extent predicate-args)) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) + (dynamic-extent predicate)) (let ((reply-buffer nil) (token (or (current-process) (cons nil nil)))) (declare (type (or null reply-buffer) reply-buffer)) @@ -422,10 +416,7 @@ (declare (type display display) (dynamic-extent predicate-args) (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) + (dynamic-extent predicate)) (or (apply predicate predicate-args) (null (display-input-in-progress display)) (not (null (display-dead display))))) @@ -766,10 +757,7 @@ (declare (type display display) (type reply-buffer event)) (declare (type function handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg handler)) + (dynamic-extent handler)) (reading-event (event :display display :sizes (8 16 ,@get-sizes)) (funcall handler :display display @@ -1180,10 +1168,7 @@ (type (or null number) timeout) (type generalized-boolean peek-p discard-p force-output-p)) (declare (type t handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera handler)) + (dynamic-extent handler)) (event-loop (display event timeout force-output-p discard-p) (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT (event-decoder (and (index< event-code (length *event-handler-vector*)) @@ -1536,17 +1521,6 @@ (when (= code (second extension)) (return (first extension)))))) -#-(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - ((display :reader request-error-display) - (error-key :reader request-error-error-key) - (major :reader request-error-major) - (minor :reader request-error-minor) - (sequence :reader request-error-sequence) - (current-sequence :reader request-error-current-sequence) - (asynchronous :reader request-error-asynchronous)) - (:report report-request-error)) - (defun report-request-error (condition stream) (let ((error-key (request-error-error-key condition)) (asynchronous (request-error-asynchronous condition)) @@ -1561,7 +1535,6 @@ ;; Since the :report arg is evaluated as (function report-request-error) the ;; define-condition must come after the function definition. -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) (define-condition request-error (x-error) ((display :reader request-error-display :initarg :display) (error-key :reader request-error-error-key :initarg :error-key) diff --git a/src/clx/keysyms.lisp b/src/clx/keysyms.lisp index f63f5d09d0a3d79131ce8d7fa212f9773041dc0a..92fc5ec482b31357e4747292135ce423bb9c30bf 100644 --- a/src/clx/keysyms.lisp +++ b/src/clx/keysyms.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: keysyms.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) diff --git a/src/clx/macros.lisp b/src/clx/macros.lisp index cbf28d0c94c6cfc18044b86a74ad0b5ced349d53..8d9db3c8fbf47ee241dcb5e4636c2c9c0151b2af 100644 --- a/src/clx/macros.lisp +++ b/src/clx/macros.lisp @@ -25,9 +25,6 @@ ;;; This is built on top of BUFFER -#+cmu -(ext:file-comment "$Id: macros.lisp,v 1.8 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defmacro type-check (value type) @@ -88,6 +85,7 @@ ;; If no third body form is present, then these macros assume that ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. ;; these predicating puts are used by the OR accessor. + #-cmu (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) (when (cdddr get-put-macros) (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) @@ -547,10 +545,7 @@ (defun mask-get (index type-values body-function) (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + (dynamic-extent body-function)) ;; This is a function, because it must return more than one form (called by get-put-items) ;; Functions that use this must have a binding for %MASK (let* ((bit 0) @@ -581,10 +576,7 @@ (defun mask-put (index type-values body-function) (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + (dynamic-extent body-function)) ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES ;; A 32 bit value follows for each non-nil value. `((let ((%mask 0) @@ -642,10 +634,7 @@ (defun get-put-items (index type-args putp &optional body-function) (declare (type (or null function) body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + (dynamic-extent body-function)) ;; Given a lists of the form (type item item ... item) ;; Calls body-function with four arguments, a function name, ;; index, item name, and optional arguments. @@ -715,7 +704,6 @@ (declare (type display .display.)) (with-buffer-request-internal (.display. ,opcode ,@options) ,@type-args))) - #+clx-ansi-common-lisp (declare (dynamic-extent #'.request-body.)) (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) 'with-buffer-request-function-nolock @@ -755,7 +743,6 @@ (type reply-buffer .reply-buffer.)) (progn .display. .reply-buffer. nil) ,reply-body)) - #+clx-ansi-common-lisp (declare (dynamic-extent #'.request-body. #'.reply-body.)) (with-buffer-request-and-reply-function ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) diff --git a/src/clx/manager.lisp b/src/clx/manager.lisp index 326223abbff20be24709a995f3867dde79c6f393..729ba00dbe6c9d56c4cc53624a01a45e0adb832a 100644 --- a/src/clx/manager.lisp +++ b/src/clx/manager.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: manager.lisp,v 1.10 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defun wm-name (window) @@ -154,10 +151,11 @@ wm-hints) (defun decode-wm-hints (vector display) - (declare (type (simple-vector 9) vector) + (declare (type (simple-vector *) vector) (type display display)) (declare (clx-values wm-hints)) - (let ((input-hint 0) + (let ((hint-mask (1- (ash 1 29))) + (input-hint 0) (state-hint 1) (icon-pixmap-hint 2) (icon-window-hint 3) @@ -182,12 +180,12 @@ (when (logbitp icon-window-hint flags) (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) (when (logbitp icon-position-hint flags) - (setf (wm-hints-icon-x hints) (aref vector 5) - (wm-hints-icon-y hints) (aref vector 6))) + (setf (wm-hints-icon-x hints) (logand hint-mask (aref vector 5)) + (wm-hints-icon-y hints) (logand hint-mask (aref vector 6)))) (when (logbitp icon-mask-hint flags) (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) (when (and (logbitp window-group-hint flags) (> (length vector) 7)) - (setf (wm-hints-window-group hints) (aref vector 8))) + (setf (wm-hints-window-group hints) (logand hint-mask (aref vector 8)))) hints))) @@ -313,8 +311,12 @@ (setf (wm-size-hints-width-inc hints) (aref vector 9) (wm-size-hints-height-inc hints) (aref vector 10))) (when (logbitp 7 flags) - (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) - (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) + (let ((low (aref vector 12))) + (unless (zerop low) + (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) low)))) + (let ((low (aref vector 14))) + (unless (zerop low) + (setf (wm-size-hints-max-aspect hints) (/ (aref vector 13) low))))) (when (> (length vector) 15) ;; This test is for backwards compatibility since old Xlib programs ;; can set a size-hints structure that is too small. See ICCCM. @@ -323,7 +325,13 @@ (wm-size-hints-base-height hints) (aref vector 16))) (when (logbitp 9 flags) (setf (wm-size-hints-win-gravity hints) - (decode-type (member-vector +win-gravity-vector+) (aref vector 17))))) + ;; many games don't initialize win-gravity correctly, + ;; so we need to bring it to within the correct range + ;; ICCCM specifies a default gravity of NorthWest + (let ((gravity (aref vector 17))) + (if (< 0 gravity #.(length +win-gravity-vector+)) + (decode-type (member-vector +win-gravity-vector+) gravity) + :north-west))))) ;; Obsolete fields (when (or (logbitp 0 flags) (logbitp 2 flags)) (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) @@ -733,36 +741,7 @@ (get-property root property :type type :result-type result-type :start start :end end :transform transform))) -;; Implement the following: -;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) -;; (transform #'char->card8) (start 0) end) (data) -;; In order to avoid having to pass positional parameters to set-cut-buffer, -;; We've got to do the following. WHAT A PAIN... -#-clx-ansi-common-lisp -(define-setf-method cut-buffer (display &rest option-list) - (declare (dynamic-extent option-list)) - (do* ((options (copy-list option-list)) - (option options (cddr option)) - (store (gensym)) - (dtemp (gensym)) - (temps (list dtemp)) - (values (list display))) - ((endp option) - (values (nreverse temps) - (nreverse values) - (list store) - `(set-cut-buffer ,store ,dtemp ,@options) - `(cut-buffer ,@options))) - (unless (member (car option) '(:buffer :type :format :start :end :transform)) - (error "Keyword arg ~s isn't recognized" (car option))) - (let ((x (gensym))) - (push x temps) - (push (cadr option) values) - (setf (cadr option) x)))) - -(defun - #+clx-ansi-common-lisp (setf cut-buffer) - #-clx-ansi-common-lisp set-cut-buffer +(defun (setf cut-buffer) (data display &key (buffer 0) (type :STRING) (format 8) (start 0) end (transform #'char->card8)) (declare (type sequence data) diff --git a/src/clx/package.lisp b/src/clx/package.lisp index 90665f38f8b8c064a965f9edce011ee4b270dab5..655090319847465699c8ce61ad4793baed08aea2 100644 --- a/src/clx/package.lisp +++ b/src/clx/package.lisp @@ -11,238 +11,26 @@ ;;; publicity pertaining to distribution of the software without specific, ;;; written prior permission. -#+cmu -(ext:file-comment "$Id: package.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") - -;;; The CLtL way - -#-clx-ansi-common-lisp -(lisp:in-package :xlib :use '(:lisp)) - -#+(and (or kcl ibcl) (not clx-ansi-common-lisp)) -(shadow - '( - rational - )) - -#+(and CMU (not clx-ansi-common-lisp)) -(shadow '(define-condition)) - -#+(and lispm (not clx-ansi-common-lisp)) -(import - '( - sys:arglist - sys:with-stack-list - sys:with-stack-list* - )) - -#+(and Genera (not clx-ansi-common-lisp)) -(import - '( - future-common-lisp:print-unreadable-object - future-common-lisp:with-standard-io-syntax - zwei:indentation - )) - -#+(and lcl3.0 (not clx-ansi-common-lisp)) -(import - '( - lcl:arglist - lcl:dynamic-extent - lcl:type-error - lucid::type-error-datum - lucid::type-error-expected-type - )) - -#+(and excl (not clx-ansi-common-lisp)) -(import - '( - excl::arglist - excl::dynamic-extent - excl::type-error - excl::type-error-datum - excl::type-error-expected-type - )) - -#+(and allegro (not clx-ansi-common-lisp)) -(import - '( - excl::without-interrupts - )) - -#-clx-ansi-common-lisp -(export - '( - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler - display-extended-max-request-length display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y generalized-boolean get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function type-error undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom - )) - ;;; The ANSI Common Lisp way -#+(and Genera clx-ansi-common-lisp) +#+genera (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) -#+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) -#+clx-ansi-common-lisp -(defpackage xlib +(defpackage #:xlib (:use common-lisp) (:size 3000) #+(or kcl ibcl) (:shadow rational) - #+allegro (:use cltl1) #+allegro (:import-from excl without-interrupts) #+excl (:import-from excl arglist) #+Genera (:import-from zwei indentation) #+lcl3.0 (:import-from lcl arglist) #+lispm (:import-from lisp char-bit) #+lispm (:import-from sys arglist with-stack-list with-stack-list*) - #+sbcl (:use sb-bsd-sockets) + #+(or sbcl ecl) (:use sb-bsd-sockets) (:export *version* access-control access-error access-hosts activate-screen-saver add-access-host add-resource add-to-save-set @@ -389,108 +177,4 @@ wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom) - ;; Exports from xvidmode.lisp - (:export mode-info - mode-info-dotclock - mode-info-hdisplay - mode-info-hsyncstart - mode-info-hsyncend - mode-info-htotal - mode-info-hskew - mode-info-vdisplay - mode-info-vsyncstart - mode-info-vsyncend - mode-info-vtotal - mode-info-flags - mode-info-privsize - mode-info-private - make-mode-info - - xfree86-vidmode-query-version - xfree86-vidmode-set-client-version - xfree86-vidmode-get-permissions - xfree86-vidmode-mod-mode-line - xfree86-vidmode-get-mode-line - xfree86-vidmode-get-all-mode-lines - xfree86-vidmode-add-mode-line - xfree86-vidmode-delete-mode-line - xfree86-vidmode-validate-mode-line - xfree86-vidmode-get-gamma - xfree86-vidmode-set-gamma - xfree86-vidmode-get-gamma-ramp - xfree86-vidmode-set-gamma-ramp - xfree86-vidmode-get-gamma-ramp-size - xfree86-vidmode-lock-mode-switch - xfree86-vidmode-switch-to-mode - xfree86-vidmode-switch-mode - xfree86-vidmode-select-next-mode - xfree86-vidmode-select-prev-mode - xfree86-vidmode-get-monitor - xfree86-vidmode-get-viewport - xfree86-vidmode-set-viewport - xfree86-vidmode-get-dotclocks) - ;; xrender - (:export render-create-picture - render-free-picture - - render-create-glyph-set - render-reference-glyph-set - render-free-glyph-set - - render-add-glyph - render-add-glyph-from-picture - render-free-glyph - render-fill-rectangle - - picture-format-display - picture-format-id - picture-format-type - picture-format-depth - picture-format-red-byte - picture-format-green-byte - picture-format-blue-byte - picture-format-alpha-byte - picture-format-colormap - - ;; picture object - picture-repeat - picture-alpha-map - picture-alpha-x-origin - picture-alpha-y-origin - picture-clip-x-origin - picture-clip-y-origin - picture-clip-mask - picture-graphics-exposures - picture-subwindow-mode - picture-poly-edge - picture-poly-mode - picture-dither - picture-component-alpha - picture-drawable - - find-matching-picture-formats - find-window-picture-format - render-free-picture - render-free-glyph-set - render-query-version - ;; render-query-picture-formats - render-fill-rectangle - render-composite - render-create-glyph-set - render-reference-glyph-set - render-composite-glyphs - render-add-glyph - render-add-glyph-from-picture - render-free-glyphs - render-combine) - ;; Shape extension - (:export shape-query-version - shape-rectangles - shape-mask - shape-combine - shape-offset - shape-query-extents - shape-select-input - shape-input-selected-p - shape-get-rectangles)) + write-resources xatom)) diff --git a/src/clx/provide.lisp b/src/clx/provide.lisp index fe59ebedcb4db07626fddc343ecd093341d6e3c9..208e42d69755d78bb21bef8c66607ac9bb801544 100644 --- a/src/clx/provide.lisp +++ b/src/clx/provide.lisp @@ -14,24 +14,12 @@ ;;; (require :clx <pathname-of-this-file>) ;;; -#+cmu -(ext:file-comment "$Id: provide.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $") - -#+cmu -(cl:provide "CLX") - -#-cmu -(progn - -#-clx-ansi-common-lisp -(in-package :user) - -#+clx-ansi-common-lisp (in-package :common-lisp-user) -#-clx-ansi-common-lisp (provide :clx) +#-cmu +(progn (defvar *clx-source-pathname* (pathname "/src/local/clx/*.l")) @@ -63,4 +51,4 @@ (if *compile-clx* (compile-clx *clx-source-pathname* *clx-binary-pathname*) (load-clx *clx-binary-pathname*)) -) +) \ No newline at end of file diff --git a/src/clx/requests.lisp b/src/clx/requests.lisp index 49aeb3edfefb5a624ba522f1535c9a29fff82e7e..e802919977f96241e326e1fdbdc972dc11123383 100644 --- a/src/clx/requests.lisp +++ b/src/clx/requests.lisp @@ -16,9 +16,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: requests.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defun create-window (&key @@ -120,8 +117,10 @@ (defun destroy-window (window) (declare (type window window)) - (with-buffer-request ((window-display window) +x-destroywindow+) - (window window))) + (let ((display (window-display window))) + (with-buffer-request (display +x-destroywindow+) + (window window)) + (deallocate-resource-id display (window-id window) 'window))) (defun destroy-subwindows (window) (declare (type window window)) diff --git a/src/clx/resource.lisp b/src/clx/resource.lisp index f5c1e5b18ee6389733bbd39e74543c9bb487c6e0..980e22a000e505a593ff948d87cdc3ad94b858c0 100644 --- a/src/clx/resource.lisp +++ b/src/clx/resource.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: resource.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) ;; The C version of this uses a 64 entry hash table at each entry. @@ -409,20 +406,14 @@ ;; FUNCTION is called with arguments (name-list value . args) (declare (type resource-database database) (type (function (list t &rest t) t) function) - #+clx-ansi-common-lisp (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function) (dynamic-extent args)) (declare (clx-values nil)) (labels ((map-resource-internal (database function args name) (declare (type resource-database database) (type (function (list t &rest t) t) function) (type list name) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) + (dynamic-extent function)) (let ((tight (resource-database-tight database)) (loose (resource-database-loose database))) (declare (type list tight loose)) diff --git a/src/clx/sockcl.lisp b/src/clx/sockcl.lisp index b5e2ca5e1e6b00658fc93ce8df6aed40622fda04..26c0eda348242d4b888ca3d4efb1e610a922ae8b 100644 --- a/src/clx/sockcl.lisp +++ b/src/clx/sockcl.lisp @@ -23,9 +23,6 @@ ;;; Compile this file with compile-file. ;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") -#+cmu -(ext:file-comment "$Id: sockcl.lisp,v 1.4 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) ;;; The cmpinclude.h file does not have this type definition from diff --git a/src/clx/text.lisp b/src/clx/text.lisp index 6e3b0a478baa96fc547510fcadb72e1cfa746a7f..dcac2723315b8caea67fa2385172ca2e4f800c21 100644 --- a/src/clx/text.lisp +++ b/src/clx/text.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: text.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) ;; Strings are broken up into chunks of this size @@ -117,10 +114,7 @@ (declare (type sequence sequence) (type (or font gcontext) font)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values width ascent descent left right font-ascent font-descent direction (or null array-index))) @@ -224,10 +218,7 @@ (type array-index start) (type (or null array-index) end)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values integer (or null integer))) (when (type? font 'gcontext) (force-gcontext-changes font) @@ -468,10 +459,7 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) @@ -519,10 +507,7 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values (or null array-index) (or null int32))) (unless end (setq end (length sequence))) (ecase size @@ -543,10 +528,7 @@ (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + (dynamic-extent translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) @@ -645,10 +627,7 @@ (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + (dynamic-extent translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) @@ -747,10 +726,7 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) @@ -803,10 +779,7 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values (or null array-index) (or null int32))) (setf end (index-min (index+ start 255) (or end (length sequence)))) (ecase size @@ -831,10 +804,7 @@ (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + (dynamic-extent translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) @@ -896,10 +866,7 @@ (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + (dynamic-extent translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) diff --git a/src/clx/translate.lisp b/src/clx/translate.lisp index 1c015c7e70edcc927b79c8c2257b2870085d7d0b..0b0d7a8c8c55ce8ddf1e9c70d9c2647d9c737821 100644 --- a/src/clx/translate.lisp +++ b/src/clx/translate.lisp @@ -16,19 +16,22 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: translate.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym) (defun define-keysym-set (set first-keysym last-keysym) ;; Define all keysyms from first-keysym up to and including - ;; last-keysym to be in SET (returned from the keysym-set function). - ;; Signals an error if the keysym range overlaps an existing set. - (declare (type keyword set) - (type keysym first-keysym last-keysym)) + ;; last-keysym to be in the keysym set named SET. SET is a keyword + ;; (i.e., a symbol in the package named KEYWORD). When the function + ;; KEYSYM-SET is called with a keysym, the SET of the keysym set to + ;; which the keysym belongs is returned. + ;; + ;; If the range of keysyms defined by first-keysym and last-keysym + ;; overlaps the range of an existing keysym set, then an error is + ;; signaled. + (declare (type keyword set) + (type keysym first-keysym last-keysym)) (when (> first-keysym last-keysym) (rotatef first-keysym last-keysym)) (setq *keysym-sets* (delete set *keysym-sets* :key #'car)) @@ -113,10 +116,10 @@ (logand #xff (lognot (make-state-mask :lock)))) "Default keysym state mask to use during keysym-translation.") -(defun define-keysym (object keysym &key lowercase translate modifiers mask display) +(defun define-keysym (object keysym &key lowercase translate modifiers mask display) ;; Define the translation from keysym/modifiers to a (usually - ;; character) object. ANy previous keysym definition with - ;; KEYSYM and MODIFIERS is deleted before adding the new definition. + ;; character) object. Any previous keysym definition with KEYSYM + ;; and MODIFIERS is deleted before the new definition is added. ;; ;; MODIFIERS is either a modifier-mask or list containing intermixed ;; keysyms and state-mask-keys specifying when to use this diff --git a/src/tools/clxcom.lisp b/src/tools/clxcom.lisp index 90afb2bea155d593785615a763d179bd96bba89b..cae5982df1ca2c5d45ab196239c4e29fee6416b0 100644 --- a/src/tools/clxcom.lisp +++ b/src/tools/clxcom.lisp @@ -68,16 +68,16 @@ (comf "target:clx/manager" :load t) (comf "target:clx/image" :load t) (comf "target:clx/resource" :load t) - (comf "target:clx/shape" :load t) - (comf "target:clx/big-requests" :load t) - (comf "target:clx/xvidmode" :load t) - (comf "target:clx/xrender" :load t) - (comf "target:clx/glx" :load t) - (comf "target:clx/gl" :load t) - (comf "target:clx/dpms" :load t) - (comf "target:clx/screensaver" :load t) - (comf "target:clx/xinerama" :load t) - (comf "target:clx/xtest" :load t)) + (comf "target:clx/extensions/shape" :load t) + (comf "target:clx/extensions/big-requests" :load t) + (comf "target:clx/extensions/xvidmode" :load t) + (comf "target:clx/extensions/xrender" :load t) + (comf "target:clx/extensions/glx" :load t) + (comf "target:clx/extensions/gl" :load t) + (comf "target:clx/extensions/dpms" :load t) + (comf "target:clx/extensions/screensaver" :load t) + (comf "target:clx/extensions/xinerama" :load t) + (comf "target:clx/extensions/xtest" :load t)) (comf "target:code/clx-ext") (comf "target:hemlock/charmacs" :load t) (comf "target:hemlock/key-event" :load t) @@ -109,16 +109,16 @@ "target:clx/manager" "target:clx/image" "target:clx/resource" - "target:clx/shape" - "target:clx/big-requests" - "target:clx/xvidmode" - "target:clx/xrender" - "target:clx/glx" - "target:clx/gl" - "target:clx/dpms" - "target:clx/screensaver" - "target:clx/xinerama" - "target:clx/xtest" + "target:clx/extensions/shape" + "target:clx/extensions/big-requests" + "target:clx/extensions/xvidmode" + "target:clx/extensions/xrender" + "target:clx/extensions/glx" + "target:clx/extensions/gl" + "target:clx/extensions/dpms" + "target:clx/extensions/screensaver" + "target:clx/extensions/xinerama" + "target:clx/extensions/xtest" "target:code/clx-ext" "target:hemlock/charmacs" "target:hemlock/key-event"