From 89a67b6472cd4d2f1d2211b4b3c511f1b137ea25 Mon Sep 17 00:00:00 2001 From: fgilham <fgilham> Date: Tue, 21 Aug 2007 15:49:30 +0000 Subject: [PATCH] Telent CLX import --- clx/CHANGES | 57 + clx/NEWS | 165 ++ clx/README | 113 ++ clx/README-CMUCL | 39 + clx/README-R5 | 52 + clx/attributes.lisp | 46 +- clx/big-requests.lisp | 34 + clx/buffer.lisp | 993 +++++----- clx/bufmac.lisp | 4 +- clx/build-clx.lisp | 36 + clx/clx-module.lisp | 9 + clx/clx.lisp | 211 ++- clx/cmudep.lisp | 19 + clx/debug/debug.lisp | 3 + clx/debug/describe.lisp | 5 +- clx/debug/event-test.lisp | 11 +- clx/debug/keytrans.lisp | 15 +- clx/debug/trace.lisp | 3 + clx/debug/util.lisp | 8 +- clx/defsystem.lisp | 393 +++- clx/demo/README | 30 + clx/demo/bezier.lisp | 3 + clx/demo/beziertest.lisp | 3 + clx/demo/clclock.lisp | 81 + clx/demo/clipboard.lisp | 203 ++ clx/demo/clx-demos.lisp | 1065 +++++++++++ clx/demo/gl-test.lisp | 480 +++++ clx/demo/hello.lisp | 3 + clx/demo/mandel.lisp | 561 ++++++ clx/demo/menu.lisp | 9 +- clx/demo/zoid.lisp | 3 + clx/dep-allegro.lisp | 2213 ++++++++++++++++++++++ clx/dep-openmcl.lisp | 1127 +++++++++++ clx/depdefs.lisp | 360 +++- clx/dependent.lisp | 3082 ++++++++++++++++++++++++++++--- clx/display.lisp | 551 +++--- clx/dpms.lisp | 171 ++ clx/exclMakefile | 170 ++ clx/exclREADME | 58 + clx/excldefsys.lisp | 189 ++ clx/excldep.c | 77 + clx/excldep.lisp | 438 +++++ clx/fonts.lisp | 26 +- clx/gcontext.lisp | 88 +- clx/generalock.lisp | 75 + clx/gl.lisp | 3695 +++++++++++++++++++++++++++++++++++++ clx/glx.lisp | 635 +++++++ clx/graphics.lisp | 44 +- clx/image.lisp | 211 ++- clx/input.lisp | 162 +- clx/keysyms.lisp | 278 ++- clx/macros.lisp | 318 ++-- clx/manager.lisp | 39 +- clx/package.lisp | 239 ++- clx/provide.lisp | 67 + clx/requests.lisp | 234 +-- clx/resource.lisp | 23 +- clx/shape.lisp | 195 ++ clx/sockcl.lisp | 166 ++ clx/socket.c | 155 ++ clx/test/README | 9 + clx/text.lisp | 159 +- clx/translate.lisp | 88 +- clx/xrender.lisp | 1131 ++++++++++++ clx/xvidmode.lisp | 733 ++++++++ 65 files changed, 19989 insertions(+), 1874 deletions(-) create mode 100644 clx/CHANGES create mode 100644 clx/NEWS create mode 100644 clx/README create mode 100644 clx/README-CMUCL create mode 100644 clx/README-R5 create mode 100644 clx/big-requests.lisp create mode 100644 clx/build-clx.lisp create mode 100644 clx/clx-module.lisp create mode 100644 clx/cmudep.lisp create mode 100644 clx/demo/README create mode 100644 clx/demo/clclock.lisp create mode 100644 clx/demo/clipboard.lisp create mode 100644 clx/demo/clx-demos.lisp create mode 100644 clx/demo/gl-test.lisp create mode 100644 clx/demo/mandel.lisp create mode 100644 clx/dep-allegro.lisp create mode 100644 clx/dep-openmcl.lisp create mode 100644 clx/dpms.lisp create mode 100644 clx/exclMakefile create mode 100644 clx/exclREADME create mode 100644 clx/excldefsys.lisp create mode 100644 clx/excldep.c create mode 100644 clx/excldep.lisp create mode 100644 clx/generalock.lisp create mode 100644 clx/gl.lisp create mode 100644 clx/glx.lisp create mode 100644 clx/provide.lisp create mode 100644 clx/shape.lisp create mode 100644 clx/sockcl.lisp create mode 100644 clx/socket.c create mode 100644 clx/test/README create mode 100644 clx/xrender.lisp create mode 100644 clx/xvidmode.lisp diff --git a/clx/CHANGES b/clx/CHANGES new file mode 100644 index 000000000..f666fdff8 --- /dev/null +++ b/clx/CHANGES @@ -0,0 +1,57 @@ +$Id: CHANGES,v 1.6 2007/08/21 15:49:27 fgilham Exp $ + +Details of changes since R5: + +NOTE: this file is not updated any more. Changes since checking into +version control can be found from darcs in some way shape or form. +There may however be some Dark Ages between when this file was last +updated and the version that was the initial version control checkin. + + +Changes in CLX 5.02: + +Replace LCL:ENVIRONMENT-VALUE with LCL:ENVIRONMENT-VARIABLE. + +Fix a declaration in the DEFINE-ERROR macro. + +Quote type argument to TYPE-CHECK consistently. + + +Changes in CLX 5.01: + +Support for MIT-MAGIC-COOKIE-1 authorization has been added. + +All VALUES declarations have been changed to CLX-VALUES declarations. +VALUES is a CL type name and cannot be used as a declaration name. + +All ARRAY-REGISTER declarations have been removed as Genera no longer +needs them. + +Many type declarations have been corrected or tightened up now that some +Lisps look at them. + +Print functions have been defined for bitmap and pixmap formats. + +The DISPLAY-PLIST slot will be initialized to NIL. + +When debugging, don't optimize SPEED in the buffer macros. + +Make the CARD8<->CHAR and the window manager code work for sparse +character sets (where some codes do not have corresponding characters). + +The default gcontext extension set and copy functions will take the +correct number of arguments. + +PUT-IMAGE will now work for 24-bit images. + +The buffer accessors for MEMBER8, etc., will use the standard mechanisms +for reporting type errors. + +Typographical errors in SET-WM-PROPERTIES, SET-STANDARD-COLORMAP, and +POINTER-CONTROL have been fixed. + +Symbolics systems will do lazy macroexpansion in the buffer macros. + +A variety of changes for Symbolics Minima systems have been made. + +Some system-dependent code has been added for CMU Common Lisp. diff --git a/clx/NEWS b/clx/NEWS new file mode 100644 index 000000000..8c2358f37 --- /dev/null +++ b/clx/NEWS @@ -0,0 +1,165 @@ +-*- Text -*- +$Id: NEWS,v 1.1 2007/08/21 15:49:27 fgilham Exp $ +-- Changes in telent CLX 0.7.3, Tue Mar 28 2006 --- + +Support for Allegro CL (6.2 and later) (Mikel Evins) +Latin 1 keysyms (Christophe Rhodes) +Some protocol fixes (Douglas Crosher) +Define a RENDER-OP typ (Douglas Crosher) + +--- Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 --- + +OpenMCL fixes +DPMS extension support +Xauthority ipv6 parsing fixes + +Thanks to Bryan O'Connor, Matthew Kennedy, Christophe Rhodes + +--- Changes in SBCL CLX 0.7.1, Wed Aug 24 2005 --- + +Works in SBCL 0.9.2 and newer. + +--- Changes in SBCL CLX 0.7.0, Sun May 1 2005 --- + +The SBCL support now depends on version 0.9.0 or greater. + +--- Changes in SBCL CLX 0.6.1, Mon Mar 28 2005 --- + +experimental GLX extension support (from Janis Dzerins) + +The ICCCM-compliant selection handling in demo/clipboard.lisp is now +more ICCCM-compliant. + +The implementation of the RENDER client protocol has been +enhanced. (Gilbert Baumann) + +Bug fix: CIRCULATE-NOTIFY, CIRCULATE-REQUEST and PROPERTY-NOTIFY input +event descriptions have been fixed. + +--- Changes in SBCL CLX 0.6, Tue Nov 16 2004 --- + +A port to ECL has been merged (Juan Jose Garcia Ripoll) + +With the addition of an implementation of DYNAMIC-EXTENT &REST lists +to SBCL, various functions (e.g. READ-INPUT, QUEUE-EVENT) in CLX +should cons less. + +A Texinfo version of the CLX manual has been added (in manual/), thanks +to the work of Gilbert Baumann and Shawn Betts. + +The portable-clx mailing list has been created for development discussion +and bug reports. See +http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx + +A demonstration of ICCCM-compliant selection handling for select and paste +has been included in demo/clipboard.lisp + +Bug fix: change the sizes of certain fields in a WM-SIZE-HINT to be 32 +bits wide, as per the ICCCM specifications. Fixes a problem seen with +the MacOS X11 window manger, that uses very large hint values. +(Patch from Eric Marsden) + +Bug fix: +POINTER-EVENT-MASK-VECTOR+ is supposed to be a vector of +keywords. It wasn't, but it is now. (Milan Zamazal) + +Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS* +(Milan again) + +--- Changes in SBCL CLX 0.5.4, Tue Nov 11 00:02:43 2003 --- + +A change in the implementation of PROCESS-BLOCK and PROCESS-WAKEUP +under multithreaded SBCL. Previous versions used queues and condition +variables, but this seems to have undesireable performance +characteristics; the newer version uses a polling loop calling +sched_yield() inside, which greatly improves responsiveness, but is +more CPU-hungry (as perceived by top(1), at least; in theory it +only hogs the CPU when nobody else wants it). + + +--- Changes in SBCL CLX 0.5.3, Sat Sep 6 12:14:39 UTC 2003 --- + +We allow a PIXMAP-DEPTH of 12 in clx.lisp, despite not having any +image routines for it, to allow clx to load when running under eXceed. +Image routines are unlikely to work in such circumstances. + +Bug fixes + + * ERROR idiom (xvidmode.lisp) + * Add timestamp in NEWS file + +--- Changes in SBCL CLX 0.5.2, about twenty minutes before 0.5.3 --- + +OPEN-DEFAULT-DISPLAY now takes an optional argument for the display +name, which has the same "protocol/host:display.screen" format as used +by the C libX11 (XOpenDisplay). OPEN-DISPLAY is not actively +deprecated, but is much less useful by comparison + +Inclusion of two new tests/demos (from Ingvar Mattson): + * demo/clclock: a simple clock application; + * demo/mandel: a Mandelbrot set viewer. + +Bug fixes + + * Fix bad type declarations in TEXT-EXTENTS-SERVER and + TEXT-WIDTH-SERVER (text.lisp) + * Fix FORMAT argument mismatch error in WRITE-BITMAP-FILE (image.lisp) + +--- Changes in SBCL CLX 0.5.1, Wed Jun 25 14:20:31 BST 2003 --- + +experimental RENDER extension support (from Gilbert Baumann) + note: the API to this is as yet unfinalized, as indeed the protocol + and specification appear to be in flux. Nevertheless, + feedback is welcome to the portable-clx-devel mailing list. + +Bug fixes + + * fix bugs in the image test: always draw glyphs in white on black + (not 1 on 0 -- i.e. dark red/blue on black in 24 bit truecolour); + don't abuse the X-HOT and Y-HOT slots for communicating persistent + information any more. + + * Disable the "optimized" pixarray read/write routines, on the basis + that the newly fixed image test reveals that they are broken. + + * fix type bugs in DEFINE-GCONTEXT-ACCESSOR, which previously + signalled a type error if :COPY-FUNCTION was not provided, and a + different type error if it was. + +Other notes + + * we use the SBCL extensions to the condition system to customize + compiler behaviour. As such, the system will only build without + breaking into the debugger using the supplied .asd, as we inhibit + error signalling from DEFCONSTANT; the benefits of this are easier + code sharing, as we minimize divergence within the clx source + proper from other implementations. + + * we also use an SBCL extension to maximize efficiency: we set + SB-EXT:*DERIVE-FUNCTION-TYPES* to true for the duration of the + compilation of the clx library. Should functions in CLX be + redefined in a type-incompatible way, their callers in CLX (but not + outside) will need to be recompiled. + +--- Changes in SBCL CLX 0.5, Fri May 30 01:16:34 BST 2003 --- + +XFree86-VidModeExtension extension support (courtesy of Iban Hatchondo) + +OPEN-DEFAULT-DISPLAY (opens display in $DISPLAY environment variable) exported + +Implement CLX MP dependencies for SBCL: HOLDING-LOCK, PROCESS-BLOCK, etc + +Many bug fixes + + * asking for text extents on unchached fonts could potentially deadlock + http://article.gmane.org/gmane.lisp.clx.devel/16 + + * lots of compiler warnings, style-warnings, notes cleared up + + +Style and ANSI cleanups + + * Much renaming of constants from *foo* to +foo+ + + * Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL + :LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs. + diff --git a/clx/README b/clx/README new file mode 100644 index 000000000..08ac72b4a --- /dev/null +++ b/clx/README @@ -0,0 +1,113 @@ +$Id: README,v 1.4 2007/08/21 15:49:27 fgilham Exp $ +This directory contains CLX, an X11 client library for Common +Lisp. The code was originally taken from a CMUCL distribution, was +modified somewhat in order to make it compile and run under SBCL, then +a selection of patches were added from other CLXes around the net. + += Features + + - SHAPE extension support (Gilbert Baumann) + - XFREE86-VIDMODE extension support (Iban Hatchondo) + - experimental RENDER extension support + (Gilbert Baumann and Christian Sunesson) + - X authority support that works with ssh forwarding (Eric Marsden via CMUCL) + - OPEN-DEFAULT-DISPLAY function which, as the name suggests, does that (dan) + - various bug fixes (Iban Hatchondo and a cast of several) + - a manual in texinfo format (Shawn Betts, Gilbert Baumann) + += Compatibility + +This CLX distribution is intended to work under the latest released +version of SBCL - please report the bug if it doesn't. It should +usually also work with earlier versions back to 0.9.0, and possibly +earlier still, but may need manual adjustment to the clx.asd file (to +remove use of newly-introduced features). + +It has also been used as a basis for CLX ports on other Lisp +implementations, but these instructions are only good for SBCL. If +you're running something else, you need to know (a) that it builds +with asdf (and asdf-install, if the planets are in alignment) and +(b) what asdf is anyway. http://www.weitz.de/asdf-install/ might help +you there. If you've installed this using some non-SBCL Lisp, please +send mail describing the process so that future versions can incorporate +your instructions. + +If you are following SBCL CVS and this CLX does not run in it, please +check the darcs repositor{y,ies} for this CLX distribution to see if +your bug has been fixed already. + +darcs get http://verisons.telent.net/clx # version from which releases are made + http://common-lisp.net/~crhodes/clx # patches merged by Christophe + http://monday-monkey.com/repos/clx/ # OpenMCL tree by bryan o'connor? + += Building using asdf-install + +* (require 'asdf) +* (require 'asdf-install) +* (asdf-install:install 'clx) ; download and install automatically, or +* (asdf-install:install "clx-x.y.z.tar.gz") ; if you've downloaded already + += Building by hand + +If you don't trust asdf-install, here's how to do it manually - + +1. Untar this tree somewhere + +2. Add a symlink to clx.asd from one of the directories listed in your + asdf:*central-registry* + + If that makes no sense to you yet, choose one of - + + 2a. personal installation: + + $ cd $HOME/.sbcl/systems # you may have to create this directory + $ ln -s /path/to/clx/source/clx.asd . + + 2b. systemwide installations: you need to ask SBCL where it lives + + $ sbcl --noinform --eval '(format t "~A~%" (posix-getenv "SBCL_HOME"))' </dev/null + /usr/local/lib/sbcl/ + * + $ cd /usr/local/lib/sbcl/site-systems + $ ln -s /path/to/clx/source/clx.asd . + +3. + * (require 'asdf) + * (require 'clx) + +This will load all the files, after compiling anything that needs compiling + +4. To test CLX (and get a small amount of Lisp advocacy), try loading +the file "demo/menu", and then executing the function +xlib::just-say-lisp. + + * (load "clx/demo/menu") + * (xlib::just-say-lisp) + +5. If you're new to Lisp, be advised that despite the examples in +demo/, it's generally /not/ considered good style to switch to the +:xlib package and write your code in it. Spend some time with a +language reference to familiarize yourself with USE-PACKAGE, or +better yet, the USE option to DEFPACKAGE. + + += Known problems: + +(none reported) + + += Bug reports, new features, patches + +Please send bug reports to the portable-clx list: + +http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx + +Note that your post will be held for approval if you are not subscribed. + + +-dan + +-- +Heavy lifting by <Raymond.Wiker at fast.no> +ASDFized version and ongoing by Daniel Barlow <dan at metacircles.com> +and (mostly, these days) Christophe Rhodes <csr21 at cam.ac.uk> diff --git a/clx/README-CMUCL b/clx/README-CMUCL new file mode 100644 index 000000000..b3baed054 --- /dev/null +++ b/clx/README-CMUCL @@ -0,0 +1,39 @@ +$Id: README-CMUCL,v 1.1 2007/08/21 15:49:27 fgilham Exp $ + +This is an import of Telent-CLX as of 0.7.3. + +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 diff --git a/clx/README-R5 b/clx/README-R5 new file mode 100644 index 000000000..d6e7b895f --- /dev/null +++ b/clx/README-R5 @@ -0,0 +1,52 @@ +$Id: README-R5,v 1.1 2007/08/21 15:49:27 fgilham Exp $ +Original CLX README, retained for historical information + +--- +These files contain beta code, but they have been tested to some extent under +Symbolics, TI, Lucid and Franz. The files have been given .l suffixes to keep +them within 12 characters, to keep SysV sites happy. Please rename them with +more appropriate suffixes for your system. + + +For Franz systems, see exclREADME. + + +For Symbolics systems, first rename all the .l files to .lisp. Then edit your +sys.translations file so that sys:x11;clx; points to this directory and put a +clx.system file in your sys:site;directory that has the form + + (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp") + +in it. After that CLX can be compiled with the "Compile System CLX" command +and loaded with the "Load System CLX" command. + + + +For TI systems, rename all the .l files to .lisp, and make a clx.translations +file in your sys:site; directory pointing to this directory and a +sys:site;clx.system file like the one described for symbolics systems above, +but with the defsystem file being in the clx:clx; directory. Then CLX can be +compiled with (make-system "CLX" :compile :noconfirm) and loaded with +(make-system "CLX" :noconfirm). + + + +For Lucid systems, you should rename all the .l files to .lisp too (This might +not be possible on SysV systems). After loading the defsystem.l file, CLX can +be compiled with the (compile-clx) function and loaded with the +(load-clx) form. + +The ms-patch.uu file is a patch to Lucid version 2 systems. You probably +don't need it, as you are probably running Lucid version 3 or later, but if +you are still using Lucid version 2, you need this patch. You'll need to +uudecode it to produce the binary. + + + +For kcl systems, after loading the defsystem.l file, CLX can be compiled with +the (compile-clx) function and loaded with the (load-clx) form. + + + +For more information, see defsystem.l and provide.l. + diff --git a/clx/attributes.lisp b/clx/attributes.lisp index 0b3b67229..ae0420139 100644 --- a/clx/attributes.lisp +++ b/clx/attributes.lisp @@ -17,9 +17,6 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/attributes.lisp,v 1.6 1999/03/16 23:37:36 pw Exp $") ;;; The special variable *window-attributes* is an alist containg: ;;; (drawable attributes attribute-changes geometry geometry-changes) @@ -43,12 +40,15 @@ ;;; 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.7 2007/08/21 15:49:27 fgilham Exp $") + (in-package :xlib) -(eval-when (compile load eval) ;needed by Franz Lisp -(defconstant *attribute-size* 44) -(defconstant *geometry-size* 24) -(defconstant *context-size* (max *attribute-size* *geometry-size* (* 16 4)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +attribute-size+ 44) + (defconstant +geometry-size+ 24) + (defconstant +context-size+ (max +attribute-size+ +geometry-size+ (* 16 4)))) (defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE @@ -57,7 +57,7 @@ (defun allocate-context () (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer) - (make-reply-buffer *context-size*))) + (make-reply-buffer +context-size+))) (defun deallocate-context (context) (declare (type reply-buffer context)) @@ -69,12 +69,12 @@ (defmacro state-geometry-changes (state) `(fifth ,state)) (defmacro drawable-equal-function () - (if (member 'drawable *clx-cached-types*) + (if (member 'drawable +clx-cached-types+) ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's ''drawable-equal)) (defmacro window-equal-function () - (if (member 'window *clx-cached-types*) + (if (member 'window +clx-cached-types+) ''eq ''drawable-equal)) @@ -158,7 +158,7 @@ (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit (setf (aref changes (1+ number)) value)) ;; save value ; Send change to the server - (with-buffer-request ((window-display window) *x-changewindowattributes*) + (with-buffer-request ((window-display window) +x-changewindowattributes+) (window window) (card32 (ash 1 number) value))))) ;; @@ -185,7 +185,7 @@ (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit (setf (aref changes (1+ number)) value)) ;; save value ; Send change to the server - (with-buffer-request ((drawable-display drawable) *x-configurewindow*) + (with-buffer-request ((drawable-display drawable) +x-configurewindow+) (drawable drawable) (card16 (ash 1 number)) (card29 value))))) @@ -207,7 +207,7 @@ (deallocate-gcontext-state (state-attribute-changes state-entry)) (setf (state-attribute-changes state-entry) nil)) ;; Get window attributes - (with-buffer-request-and-reply (display *x-getwindowattributes* size :sizes (8)) + (with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8)) ((window window)) (let ((repbuf (or (state-attributes state-entry) (allocate-context)))) (declare (type reply-buffer repbuf)) @@ -237,7 +237,7 @@ (deallocate-gcontext-state (state-geometry-changes state-entry)) (setf (state-geometry-changes state-entry) nil)) ;; Get drawable attributes - (with-buffer-request-and-reply (display *x-getgeometry* size :sizes (8)) + (with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8)) ((drawable drawable)) (let ((repbuf (or (state-geometry state-entry) (allocate-context)))) (declare (type reply-buffer repbuf)) @@ -255,7 +255,7 @@ (mask (aref changes 0))) (declare (type display display) (type mask32 mask)) - (with-buffer-request (display *x-changewindowattributes*) + (with-buffer-request (display +x-changewindowattributes+) (window window) (card32 mask) (progn ;; Insert a word in the request for each one bit in the mask @@ -282,7 +282,7 @@ (mask (aref changes 0))) (declare (type display display) (type mask16 mask)) - (with-buffer-request (display *x-configurewindow*) + (with-buffer-request (display +x-configurewindow+) (window window) (card16 mask) (progn ;; Insert a word in the request for each one bit in the mask @@ -352,6 +352,8 @@ (t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) background) +#+Genera (eval-when (compile) (compiler:function-defined 'window-background)) + (defsetf window-background set-window-background) (defun set-window-border (window border) @@ -365,6 +367,8 @@ (t (x-type-error border '(or (member :copy) integer pixmap)))) border) +#+Genera (eval-when (compile) (compiler:function-defined 'window-border)) + (defsetf window-border set-window-border) (defun window-bit-gravity (window) @@ -372,11 +376,11 @@ (declare (type window window)) (declare (clx-values bit-gravity)) (with-attributes (window :sizes 8) - (member8-vector-get 14 *bit-gravity-vector*))) + (member8-vector-get 14 +bit-gravity-vector+))) (defun set-window-bit-gravity (window gravity) (change-window-attribute - window 4 (encode-type (member-vector *bit-gravity-vector*) gravity)) + window 4 (encode-type (member-vector +bit-gravity-vector+) gravity)) gravity) (defsetf window-bit-gravity set-window-bit-gravity) @@ -386,11 +390,11 @@ (declare (type window window)) (declare (clx-values win-gravity)) (with-attributes (window :sizes 8) - (member8-vector-get 15 *win-gravity-vector*))) + (member8-vector-get 15 +win-gravity-vector+))) (defun set-window-gravity (window gravity) (change-window-attribute - window 5 (encode-type (member-vector *win-gravity-vector*) gravity)) + window 5 (encode-type (member-vector +win-gravity-vector+) gravity)) gravity) (defsetf window-gravity set-window-gravity) @@ -630,6 +634,8 @@ (change-drawable-geometry window 5 (encode-type window sibling)))) mode) +#+Genera (eval-when (compile) (compiler:function-defined 'window-priority)) + (defsetf window-priority (window &optional sibling) (mode) ;; A bit strange, but retains setf form. `(set-window-priority ,mode ,window ,sibling)) diff --git a/clx/big-requests.lisp b/clx/big-requests.lisp new file mode 100644 index 000000000..882691e6a --- /dev/null +++ b/clx/big-requests.lisp @@ -0,0 +1,34 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- +;;; +;;; (c) copyright 2006 Richard Kreuter +;;; (c) copyright 2007 by Christophe Rhodes +;;; +;;; Permission is granted to any individual or institution to use, +;;; copy, modify, and distribute this software, provided that this +;;; complete copyright and permission notice is maintained, intact, in +;;; all copies and supporting documentation. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +#+cmu +(ext:file-comment "$Id: big-requests.lisp,v 1.1 2007/08/21 15:49:27 fgilham Exp $") + +(in-package "XLIB") + +;;; No new events or errors are defined by this extension. (Big +;;; Requests Extension, section 3) +;;; +;;; The name of this extension is "BIG-REQUESTS" (Big Requests +;;; Extension, section 4) +(define-extension "BIG-REQUESTS") + +(defun enable-big-requests (display) + (declare (type display display)) + (let ((opcode (extension-opcode display "BIG-REQUESTS"))) + (with-buffer-request-and-reply (display opcode nil) + ((data 0)) + (let ((maximum-request-length (card32-get 8))) + (setf (display-extended-max-request-length display) + maximum-request-length))))) diff --git a/clx/buffer.lisp b/clx/buffer.lisp index 8a3d38cf5..f79f2b5cb 100644 --- a/clx/buffer.lisp +++ b/clx/buffer.lisp @@ -18,9 +18,6 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/buffer.lisp,v 1.8 1999/03/16 23:37:36 pw Exp $") ;; A few notes: ;; @@ -52,9 +49,12 @@ ;; 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.9 2007/08/21 15:49:27 fgilham Exp $") + (in-package :xlib) -(defconstant *requestsize* 160) ;; Max request size (excluding variable length requests) +(defconstant +requestsize+ 160) ;; Max request size (excluding variable length requests) ;;; This is here instead of in bufmac so that with-display can be ;;; compiled without macros and bufmac being loaded. @@ -71,6 +71,7 @@ ,@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)) @@ -89,7 +90,13 @@ (declare (type display buffer) (type (or null number) timeout) (type function function) - (dynamic-extent 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)) (with-buffer (buffer :timeout timeout :inline t) (funcall function))) @@ -103,18 +110,33 @@ `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card16 (byte-index) + #+clx-overlapping-arrays + `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) + #-clx-overlapping-arrays `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-int16 (byte-index) + #+clx-overlapping-arrays + `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) + #-clx-overlapping-arrays `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card32 (byte-index) + #+clx-overlapping-arrays + `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) + #-clx-overlapping-arrays `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-int32 (byte-index) + #+clx-overlapping-arrays + `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) + #-clx-overlapping-arrays `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card29 (byte-index) + #+clx-overlapping-arrays + `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) + #-clx-overlapping-arrays `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro event-code (reply-buffer) @@ -143,10 +165,43 @@ ,(declare-bufmac) ,@(and display '(%buffer)) (let* ((buffer-boffset (the array-index ,(or index 0))) - (buffer-bbuf (reply-ibuf8 %reply-buffer))) - (declare (type array-index buffer-boffset) - (type buffer-bytes buffer-bbuf) - (ignorable buffer-boffset buffer-bbuf)) + #-clx-overlapping-arrays + (buffer-bbuf (reply-ibuf8 %reply-buffer)) + #+clx-overlapping-arrays + ,@(append + (when (member 8 sizes) + `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) + (when (or (member 16 sizes) (member 160 sizes)) + `((buffer-woffset (index-ash buffer-boffset -1)) + (buffer-wbuf (reply-ibuf16 %reply-buffer)))) + (when (member 32 sizes) + `((buffer-loffset (index-ash buffer-boffset -2)) + (buffer-lbuf (reply-ibuf32 %reply-buffer)))))) + (declare (type array-index buffer-boffset)) + #-clx-overlapping-arrays + (declare (type buffer-bytes buffer-bbuf)) + #+clx-overlapping-arrays + ,@(append + (when (member 8 sizes) + '((declare (type buffer-bytes buffer-bbuf)))) + (when (member 16 sizes) + '((declare (type array-index buffer-woffset)) + (declare (type buffer-words buffer-wbuf)))) + (when (member 32 sizes) + '((declare (type array-index buffer-loffset)) + (declare (type buffer-longs buffer-lbuf))))) + buffer-boffset + #-clx-overlapping-arrays + buffer-bbuf + #+clx-overlapping-arrays + ,@(append + (when (member 8 sizes) '(buffer-bbuf)) + (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) + (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) + #+clx-overlapping-arrays + (macrolet ((%buffer-sizes () ',sizes)) + ,@body) + #-clx-overlapping-arrays ,@body))) (defun make-buffer (output-size constructor &rest options) @@ -157,6 +212,18 @@ (apply constructor :size output-size :obuf8 byte-output + #+clx-overlapping-arrays + :obuf16 + #+clx-overlapping-arrays + (make-array (index-ash output-size -1) + :element-type 'overlap16 + :displaced-to byte-output) + #+clx-overlapping-arrays + :obuf32 + #+clx-overlapping-arrays + (make-array (index-ash output-size -2) + :element-type 'overlap32 + :displaced-to byte-output) options))) (defun make-reply-buffer (size) @@ -165,7 +232,19 @@ :initial-element 0))) (make-reply-buffer-internal :size size - :ibuf8 byte-input))) + :ibuf8 byte-input + #+clx-overlapping-arrays + :ibuf16 + #+clx-overlapping-arrays + (make-array (index-ash size -1) + :element-type 'overlap16 + :displaced-to byte-input) + #+clx-overlapping-arrays + :ibuf32 + #+clx-overlapping-arrays + (make-array (index-ash size -2) + :element-type 'overlap32 + :displaced-to byte-input)))) (defun buffer-ensure-size (buffer size) (declare (type buffer buffer) @@ -176,7 +255,16 @@ (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size)))) (new-buffer (make-array new-buffer-size :element-type 'card8 :initial-element 0))) - (setf (buffer-obuf8 buffer) new-buffer))))) + (setf (buffer-obuf8 buffer) new-buffer) + #+clx-overlapping-arrays + (setf (buffer-obuf16 buffer) + (make-array (index-ash new-buffer-size -1) + :element-type 'overlap16 + :displaced-to new-buffer) + (buffer-obuf32 buffer) + (make-array (index-ash new-buffer-size -2) + :element-type 'overlap32 + :displaced-to new-buffer)))))) (defun buffer-pad-request (buffer pad) (declare (type buffer buffer) @@ -200,7 +288,10 @@ (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) - (dynamic-extent request-function)) + #+clx-ansi-common-lisp + (dynamic-extent request-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg request-function)) (with-buffer (display :inline t) (multiple-value-prog1 (progn @@ -212,7 +303,10 @@ (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) - (dynamic-extent request-function)) + #+clx-ansi-common-lisp + (dynamic-extent request-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg request-function)) (multiple-value-prog1 (progn (when gc-force (force-gcontext-changes-internal gc-force)) @@ -223,14 +317,17 @@ (sequence 0 :type card16) (reply-buffer nil :type (or null reply-buffer)) (process nil) - (next nil :type (or null pending-command))) + (next nil #-explorer :type #-explorer (or null pending-command))) (defun with-buffer-request-and-reply-function (display multiple-reply request-function reply-function) (declare (type display display) (type generalized-boolean multiple-reply)) (declare (type function request-function reply-function) - (dynamic-extent 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)) (let ((pending-command nil) (reply-buffer nil)) (declare (type (or null pending-command) pending-command) @@ -392,56 +489,60 @@ ;;; Reading sequences of chars -(defun read-sequence-char (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (character) t)) transform) - (dynamic-extent transform)) - (if transform - (flet ((card8->char->transform (v) - (declare (type card8 v)) - (funcall transform (card8->char v)))) - (declare (dynamic-extent #'card8->char->transform)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->char->transform - data start index)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->char - data start index))) +(defmacro define-transformed-sequence-reader (name totype transformer reader) + (let ((ntrans (gensym))) + `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) + (declare + (type reply-buffer reply-buffer) + (type t result-type) + (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)) + (if transform + (flet ((,ntrans (v) (funcall transform (,transformer v)))) + #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) + (,reader reply-buffer result-type nitems #',ntrans data start index)) + (,reader reply-buffer result-type nitems #',transformer data start index))))) -;;; Reading sequences of card8's +(define-transformed-sequence-reader read-sequence-char character + card8->char read-sequence-card8) -(defun read-list-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 1))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (read-card8 index))))) - -(defun read-list-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card8) t) transform) - (dynamic-extent transform)) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 1))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (funcall transform (read-card8 index)))))) +;;; Reading sequences of card8's +(defmacro define-list-readers ((name tname) type size step reader) + `(progn + (defun ,name (reply-buffer nitems data start index) + (declare (type reply-buffer reply-buffer) + (type array-index nitems start index) + (type list data)) + (with-buffer-input (reply-buffer :sizes (,size) :index index) + (do* ((j nitems (index- j 1)) + (list (nthcdr start data) (cdr list)) + (index 0 (index+ index ,step))) + ((index-zerop j)) + (declare (type array-index index j) (type list list)) + (setf (car list) (,reader index))))) + (defun ,tname (reply-buffer nitems data transform start index) + (declare (type reply-buffer reply-buffer) + (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)) + (with-buffer-input (reply-buffer :sizes (,size) :index index) + (do* ((j nitems (index- j 1)) + (list (nthcdr start data) (cdr list)) + (index 0 (index+ index ,step))) + ((index-zerop j)) + (declare (type array-index index j) (type list list)) + (setf (car list) (funcall transform (,reader index)))))))) + +(define-list-readers (read-list-card8 read-list-card8-with-transform) card8 + 8 1 read-card8) + +#-lispm (defun read-simple-array-card8 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) @@ -450,12 +551,16 @@ (with-buffer-input (reply-buffer :sizes (8)) (buffer-replace data buffer-bbuf start (index+ start nitems) index)))) +#-lispm (defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card8 (*)) data)) (declare (type (function (card8) card8) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) @@ -485,7 +590,10 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card8) t) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) @@ -495,105 +603,74 @@ (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card8 index))))))) -(defun read-sequence-card8 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card8) t)) transform) - (dynamic-extent transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card8-with-transform - reply-buffer nitems result transform start index) - (read-list-card8 reply-buffer nitems result start index))) - ((simple-array card8 (*)) - (if transform - (read-simple-array-card8-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card8 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card8-with-transform - reply-buffer nitems result transform start index) - (read-vector-card8 reply-buffer nitems result start index)))) - result)) +(defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec)) + `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) + (declare + (type reply-buffer reply-buffer) + (type t result-type) + (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)) + (let ((result (or data (make-sequence result-type nitems)))) + (typecase result + (list + (if transform + (,tlist reply-buffer nitems result transform start index) + (,list reply-buffer nitems result start index))) + #-lispm + ((simple-array ,type (*)) + (if transform + (,tsa reply-buffer nitems result transform start index) + (,sa reply-buffer nitems result start index))) + ;; FIXME: general sequences + (t + (if transform + (,tvec reply-buffer nitems result transform start index) + (,vec reply-buffer nitems result start index)))) + result))) -;;; For now, perhaps performance it isn't worth doing better? +(define-sequence-reader read-sequence-card8 card8 + (read-list-card8 read-list-card8-with-transform) + (read-simple-array-card8 read-simple-array-card8-with-transform) + (read-vector-card8 read-vector-card8-with-transform)) -(defun read-sequence-int8 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int8) t)) transform) - (dynamic-extent transform)) - (if transform - (flet ((card8->int8->transform (v) - (declare (type card8 v)) - (funcall transform (card8->int8 v)))) - (declare (dynamic-extent #'card8->int8->transform)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->int8->transform - data start index)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->int8 - data start index))) +(define-transformed-sequence-reader read-sequence-int8 int8 + card8->int8 read-sequence-card8) ;;; Reading sequences of card16's -(defun read-list-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 2))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (read-card16 index))))) - -(defun read-list-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card16) t) transform) - (dynamic-extent transform)) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 2))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (funcall transform (read-card16 index)))))) - +(define-list-readers (read-list-card16 read-list-card16-with-transform) card16 + 16 2 read-card16) +#-lispm (defun read-simple-array-card16 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card16 (*)) data)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) + #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) - (setf (aref data j) (the card16 (read-card16 index))))))) + (setf (aref data j) (the card16 (read-card16 index)))) + #+clx-overlapping-arrays + (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) +#-lispm (defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card16 (*)) data)) (declare (type (function (card16) card16) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) @@ -610,12 +687,15 @@ (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) + #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) - (setf (aref data j) (read-card16 index)))))) + (setf (aref data j) (read-card16 index))) + #+clx-overlapping-arrays + (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) (defun read-vector-card16-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) @@ -623,7 +703,10 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card16) t) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) @@ -633,103 +716,46 @@ (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card16 index))))))) -(defun read-sequence-card16 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card16) t)) transform) - (dynamic-extent transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card16-with-transform reply-buffer nitems result transform start index) - (read-list-card16 reply-buffer nitems result start index))) - ((simple-array card16 (*)) - (if transform - (read-simple-array-card16-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card16 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card16-with-transform - reply-buffer nitems result transform start index) - (read-vector-card16 reply-buffer nitems result start index)))) - result)) - -;;; For now, perhaps performance it isn't worth doing better? +(define-sequence-reader read-sequence-card16 card16 + (read-list-card16 read-list-card16-with-transform) + (read-simple-array-card16 read-simple-array-card16-with-transform) + (read-vector-card16 read-vector-card16-with-transform)) -(defun read-sequence-int16 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int16) t)) transform) - (dynamic-extent transform)) - (if transform - (flet ((card16->int16->transform (v) - (declare (type card16 v)) - (funcall transform (card16->int16 v)))) - (declare (dynamic-extent #'card16->int16->transform)) - (read-sequence-card16 - reply-buffer result-type nitems #'card16->int16->transform - data start index)) - (read-sequence-card16 - reply-buffer result-type nitems #'card16->int16 - data start index))) +(define-transformed-sequence-reader read-sequence-int16 int16 + card16->int16 read-sequence-card16) ;;; Reading sequences of card32's -(defun read-list-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 4))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (read-card32 index))))) - -(defun read-list-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card32) t) transform) - (dynamic-extent transform)) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 4))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (funcall transform (read-card32 index)))))) +(define-list-readers (read-list-card32 read-list-card32-with-transform) card32 + 32 4 read-card32) +#-lispm (defun read-simple-array-card32 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card32 (*)) data)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) + #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) - (setf (aref data j) (the card32 (read-card32 index))))))) + (setf (aref data j) (the card32 (read-card32 index)))) + #+clx-overlapping-arrays + (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) +#-lispm (defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card32 (*)) data)) (declare (type (function (card32) card32) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) @@ -746,12 +772,15 @@ (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) + #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) - (setf (aref data j) (read-card32 index)))))) + (setf (aref data j) (read-card32 index))) + #+clx-overlapping-arrays + (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) (defun read-vector-card32-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) @@ -759,7 +788,10 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card32) t) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) @@ -769,101 +801,90 @@ (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card32 index))))))) -(defun read-sequence-card32 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card32) t)) transform) - (dynamic-extent transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card32-with-transform reply-buffer nitems result transform start index) - (read-list-card32 reply-buffer nitems result start index))) - ((simple-array card32 (*)) - (if transform - (read-simple-array-card32-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card32 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card32-with-transform - reply-buffer nitems result transform start index) - (read-vector-card32 reply-buffer nitems result start index)))) - result)) +(define-sequence-reader read-sequence-card32 card32 + (read-list-card32 read-list-card32-with-transform) + (read-simple-array-card32 read-simple-array-card32-with-transform) + (read-vector-card32 read-vector-card32-with-transform)) -;;; For now, perhaps performance it isn't worth doing better? - -(defun read-sequence-int32 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int32) t)) transform) - (dynamic-extent transform)) - (if transform - (flet ((card32->int32->transform (v) - (declare (type card32 v)) - (funcall transform (card32->int32 v)))) - (declare (dynamic-extent #'card32->int32->transform)) - (read-sequence-card32 - reply-buffer result-type nitems #'card32->int32->transform - data start index)) - (read-sequence-card32 - reply-buffer result-type nitems #'card32->int32 - data start index))) +(define-transformed-sequence-reader read-sequence-int32 int32 + card32->int32 read-sequence-card32) ;;; Writing sequences of chars -(defun write-sequence-char - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) character)) transform) - (dynamic-extent transform)) - (if transform - (flet ((transform->char->card8 (x) - (char->card8 (the character (funcall transform x))))) - (declare (dynamic-extent #'transform->char->card8)) - (write-sequence-card8 - buffer boffset data start end #'transform->char->card8)) - (write-sequence-card8 buffer boffset data start end #'char->card8))) +(defmacro define-transformed-sequence-writer (name fromtype transformer writer) + (let ((ntrans (gensym))) + `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) + (declare + (type buffer buffer) + (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)) + (if transform + (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) + #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) + (,writer buffer boffset data start end #',ntrans)) + (,writer buffer boffset data start end #',transformer))))) + +(define-transformed-sequence-writer write-sequence-char character + char->card8 write-sequence-card8) ;;; Writing sequences of card8's -(defun write-list-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card8 - ((lst (nthcdr start data))) - ((type list lst)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (pop lst)) - )) - nil) +(defmacro define-list-writers ((name tname) type step writer) + `(progn + (defun ,name (buffer boffset data start end) + (declare + (type buffer buffer) + (type list data) + (type array-index boffset start end)) + (writing-buffer-chunks ,type + ((list (nthcdr start data))) + ((type list list)) + (do ((j 0 (index+ j ,step))) + ((index>= j chunk)) + (declare (type array-index j)) + (,writer j (pop list))))) + (defun ,tname (buffer boffset data start end transform) + (declare + (type buffer buffer) + (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)) + (writing-buffer-chunks ,type + ((list (nthcdr start data))) + ((type list list)) + (do ((j 0 (index+ j ,step))) + ((index>= j chunk)) + (declare (type array-index j)) + (,writer j (funcall transform (pop list)))))))) + +;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8 +#+ti +(progn + (defun write-list-card8 (buffer boffset data start end) + (writing-buffer-chunks card8 + ((list (nthcdr start data))) + ((type list list)) + (dotimes (j chunk) + (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list))))) + (defun write-list-card8-with-transform (buffer boffset data start end transform) + (writing-buffer-chunks card8 + ((list (nthcdr start data))) + ((type list lst)) + (dotimes (j chunk) + (declare (type array-index j)) + (write-card8 j (funcall transform (pop lst))))))) -(defun write-list-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card8) transform) - (dynamic-extent transform)) - (writing-buffer-chunks card8 - ((lst (nthcdr start data))) - ((type list lst)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (pop lst))))) - nil) +#-ti +(define-list-writers (write-list-card8 write-list-card8-with-transform) card8 + 1 write-card8) ;;; Should really write directly from data, instead of into the buffer first +#-lispm (defun write-simple-array-card8 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card8 (*)) data) @@ -878,12 +899,16 @@ index))) nil) +#-lispm (defun write-simple-array-card8-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card8 (*)) data) (type array-index boffset start end)) (declare (type (function (card8) card8) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 ((index start)) @@ -914,7 +939,10 @@ (type vector data) (type array-index boffset start end)) (declare (type (function (t) card8) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card8 ((index start)) @@ -925,76 +953,44 @@ (setq index (index+ index 1))))) nil) -(defun write-sequence-card8 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card8)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-card8-with-transform buffer boffset data start end transform) - (write-list-card8 buffer boffset data start end))) - ((simple-array card8 (*)) - (if transform - (write-simple-array-card8-with-transform buffer boffset data start end transform) - (write-simple-array-card8 buffer boffset data start end))) - (t - (if transform - (write-vector-card8-with-transform buffer boffset data start end transform) - (write-vector-card8 buffer boffset data start end))))) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun write-sequence-int8 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int8)) transform) - (dynamic-extent transform)) - (if transform - (flet ((transform->int8->card8 (x) - (int8->card8 (the int8 (funcall transform x))))) - (declare (dynamic-extent #'transform->int8->card8)) - (write-sequence-card8 - buffer boffset data start end #'transform->int8->card8)) - (write-sequence-card8 buffer boffset data start end #'int8->card8))) +(defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec)) + `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) + (declare + (type buffer buffer) + (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)) + (typecase data + (list + (if transform + (,tlist buffer boffset data start end transform) + (,list buffer boffset data start end))) + #-lispm + ((simple-array ,type (*)) + (if transform + (,tsa buffer boffset data start end transform) + (,sa buffer boffset data start end))) + (t ; FIXME: general sequences + (if transform + (,tvec buffer boffset data start end transform) + (,vec buffer boffset data start end)))))) + +(define-sequence-writer write-sequence-card8 card8 + (write-list-card8 write-list-card8-with-transform) + (write-simple-array-card8 write-simple-array-card8-with-transform) + (write-vector-card8 write-vector-card8-with-transform)) + +(define-transformed-sequence-writer write-sequence-int8 int8 + int8->card8 write-sequence-card8) ;;; Writing sequences of card16's -(defun write-list-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (pop lst)))) - nil) - -(defun write-list-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card16) transform) - (dynamic-extent transform)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (pop lst))))) - nil) +(define-list-writers (write-list-card16 write-list-card16-with-transform) card16 + 2 write-card16) +#-lispm (defun write-simple-array-card16 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card16 (*)) data) @@ -1018,12 +1014,16 @@ (setq index (index+ index length))))) nil) +#-lispm (defun write-simple-array-card16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) @@ -1066,7 +1066,10 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) @@ -1079,59 +1082,17 @@ (setq index (index+ index 1))))) nil) -(defun write-sequence-card16 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card16)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-card16-with-transform buffer boffset data start end transform) - (write-list-card16 buffer boffset data start end))) - ((simple-array card16 (*)) - (if transform - (write-simple-array-card16-with-transform buffer boffset data start end transform) - (write-simple-array-card16 buffer boffset data start end))) - (t - (if transform - (write-vector-card16-with-transform buffer boffset data start end transform) - (write-vector-card16 buffer boffset data start end))))) +(define-sequence-writer write-sequence-card16 card16 + (write-list-card16 write-list-card16-with-transform) + (write-simple-array-card16 write-simple-array-card16-with-transform) + (write-vector-card16 write-vector-card16-with-transform)) ;;; Writing sequences of int16's -(defun write-list-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks int16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (pop lst)))) - nil) - -(defun write-list-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) int16) transform) - (dynamic-extent transform)) - (writing-buffer-chunks int16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (pop lst))))) - nil) +(define-list-writers (write-list-int16 write-list-int16-with-transform) int16 + 2 write-int16) +#-lispm (defun write-simple-array-int16 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array int16 (*)) data) @@ -1155,12 +1116,16 @@ (setq index (index+ index length))))) nil) +#-lispm (defun write-simple-array-int16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array int16 (*)) data) (type array-index boffset start end)) (declare (type (function (int16) int16) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 ((index start)) @@ -1203,7 +1168,10 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) int16) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks int16 ((index start)) @@ -1216,59 +1184,17 @@ (setq index (index+ index 1))))) nil) -(defun write-sequence-int16 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int16)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-int16-with-transform buffer boffset data start end transform) - (write-list-int16 buffer boffset data start end))) - ((simple-array int16 (*)) - (if transform - (write-simple-array-int16-with-transform buffer boffset data start end transform) - (write-simple-array-int16 buffer boffset data start end))) - (t - (if transform - (write-vector-int16-with-transform buffer boffset data start end transform) - (write-vector-int16 buffer boffset data start end))))) +(define-sequence-writer write-sequence-int16 int16 + (write-list-int16 write-list-int16-with-transform) + (write-simple-array-int16 write-simple-array-int16-with-transform) + (write-vector-int16 write-vector-int16-with-transform)) ;;; Writing sequences of card32's -(defun write-list-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card32 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (pop lst)))) - nil) - -(defun write-list-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card32) transform) - (dynamic-extent transform)) - (writing-buffer-chunks card32 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (pop lst))))) - nil) +(define-list-writers (write-list-card32 write-list-card32-with-transform) card32 + 4 write-card32) +#-lispm (defun write-simple-array-card32 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card32 (*)) data) @@ -1292,12 +1218,16 @@ (setq index (index+ index length))))) nil) +#-lispm (defun write-simple-array-card32-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card32 (*)) data) (type array-index boffset start end)) (declare (type (function (card32) card32) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 ((index start)) @@ -1340,7 +1270,10 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card32) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card32 ((index start)) @@ -1353,43 +1286,13 @@ (setq index (index+ index 1))))) nil) -(defun write-sequence-card32 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card32)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-card32-with-transform buffer boffset data start end transform) - (write-list-card32 buffer boffset data start end))) - ((simple-array card32 (*)) - (if transform - (write-simple-array-card32-with-transform buffer boffset data start end transform) - (write-simple-array-card32 buffer boffset data start end))) - (t - (if transform - (write-vector-card32-with-transform buffer boffset data start end transform) - (write-vector-card32 buffer boffset data start end))))) - -;;; For now, perhaps performance it isn't worth doing better? +(define-sequence-writer write-sequence-card32 card32 + (write-list-card32 write-list-card32-with-transform) + (write-simple-array-card32 write-simple-array-card32-with-transform) + (write-vector-card32 write-vector-card32-with-transform)) -(defun write-sequence-int32 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int32)) transform) - (dynamic-extent transform)) - (if transform - (flet ((transform->int32->card32 (x) - (int32->card32 (the int32 (funcall transform x))))) - (declare (dynamic-extent #'transform->int32->card32)) - (write-sequence-card32 - buffer boffset data start end #'transform->int32->card32)) - (write-sequence-card32 buffer boffset data start end #'int32->card32))) +(define-transformed-sequence-writer write-sequence-int32 int32 + int32->card32 write-sequence-card32) (defun read-bitvector256 (buffer-bbuf boffset data) (declare (type buffer-bytes buffer-bbuf) @@ -1434,34 +1337,10 @@ ;;; Writing sequences of char2b's -(defun write-list-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (pop lst)))) - nil) - -(defun write-list-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card16) transform) - (dynamic-extent transform)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (pop lst))))) - nil) +(define-list-writers (write-list-char2b write-list-char2b-with-transform) card16 + 2 write-char2b) +#-lispm (defun write-simple-array-char2b (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card16 (*)) data) @@ -1477,12 +1356,16 @@ (setq index (index+ index 1))))) nil) +#-lispm (defun write-simple-array-char2b-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) @@ -1516,7 +1399,10 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) - (dynamic-extent transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) @@ -1528,24 +1414,7 @@ (setq index (index+ index 1))))) nil) -(defun write-sequence-char2b - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card16)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-char2b-with-transform buffer boffset data start end transform) - (write-list-char2b buffer boffset data start end))) - ((simple-array card16 (*)) - (if transform - (write-simple-array-char2b-with-transform buffer boffset data start end transform) - (write-simple-array-char2b buffer boffset data start end))) - (t - (if transform - (write-vector-char2b-with-transform buffer boffset data start end transform) - (write-vector-char2b buffer boffset data start end))))) - +(define-sequence-writer write-sequence-char2b card16 + (write-list-char2b write-list-char2b-with-transform) + (write-simple-array-char2b write-simple-array-char2b-with-transform) + (write-vector-char2b write-vector-char2b-with-transform)) diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp index 65a659888..471fe8ebe 100644 --- a/clx/bufmac.lisp +++ b/clx/bufmac.lisp @@ -18,9 +18,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/bufmac.lisp,v 1.4 1998/12/19 15:21:15 dtc Exp $") +(ext:file-comment "$Id: bufmac.lisp,v 1.5 2007/08/21 15:49:27 fgilham Exp $") (in-package :xlib) diff --git a/clx/build-clx.lisp b/clx/build-clx.lisp new file mode 100644 index 000000000..a280963f9 --- /dev/null +++ b/clx/build-clx.lisp @@ -0,0 +1,36 @@ +;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- + +#+cmu +(ext:file-comment "$Id: build-clx.lisp,v 1.4 2007/08/21 15:49:27 fgilham Exp $") + +;;; Load this file if you want to compile CLX in its entirety. +(proclaim '(optimize (speed 3) (safety 1) (space 1) + (compilation-speed 0))) + + +;;; Hide CLOS from CLX, so objects stay implemented as structures. +;;; +#|| +(when (find-package "CLOS") + (rename-package (find-package "CLOS") "NO-CLOS-HERE")) +(when (find-package "PCL") + (rename-package (find-package "PCL") "NO-PCL-HERE")) +(when (find-package "SB-PCL") + (rename-package (find-package "SB-PCL") "NO-SB-PCL-HERE")) +||# + +(when (find-package "XLIB") + (delete-package "XLIB")) + +(unless (find-package "XLIB") + (make-package "XLIB" :use '("COMMON-LISP"))) + +#-sbcl +(compile-file "clx:defsystem.lisp" :error-file nil :load t) + +#+sbcl +(progn (compile-file "clx:defsystem.lisp") + (load "clx:defsystem")) + +(with-compilation-unit () + (#+cmu xlib:compile-clx #-cmu compile-clx (pathname "CLX:"))) diff --git a/clx/clx-module.lisp b/clx/clx-module.lisp new file mode 100644 index 000000000..da96ee216 --- /dev/null +++ b/clx/clx-module.lisp @@ -0,0 +1,9 @@ +;;;(in-package :xlib) +;;;(common-lisp:use-package (list :common-lisp)) + +#+cmu +(ext:file-comment "$Id: clx-module.lisp,v 1.1 2007/08/21 15:49:27 fgilham Exp $") + +(provide :clx) +(load "clx:defsystem.lisp") +(load-clx (translate-logical-pathname "CLX:")) diff --git a/clx/clx.lisp b/clx/clx.lisp index d256aa03b..3cde49313 100644 --- a/clx/clx.lisp +++ b/clx/clx.lisp @@ -15,9 +15,6 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/clx.lisp,v 1.14 2003/08/08 07:35:56 emarsden Exp $") ;; Primary Interface Author: ;; Robert W. Scheifler @@ -79,6 +76,9 @@ ;;; 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.15 2007/08/21 15:49:27 fgilham Exp $") + ;; Note: all of the following is in the package XLIB. (in-package :xlib) @@ -86,12 +86,10 @@ (pushnew :clx *features*) (pushnew :xlib *features*) -(defparameter *version* "MIT R5.02") +(defparameter *version* "Telent CLX 0.7.3 + CMUCL mods, based on MIT R5.02") (pushnew :clx-mit-r4 *features*) (pushnew :clx-mit-r5 *features*) -(provide :clx) - (defparameter *protocol-major-version* 11.) (defparameter *protocol-minor-version* 0) @@ -164,6 +162,20 @@ (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. @@ -334,12 +346,14 @@ (atom-id-map (make-hash-table :test (resource-id-map-test) :size *atom-cache-size*) :type hash-table) + (extended-max-request-length 0 :type card32) ) (defun print-display-name (display stream) (declare (type (or null display) display)) (cond (display - (princ (display-host display) stream) + #-allegro (princ (display-host display) stream) + #+allegro (write-string (string (display-host display)) stream) (write-string ":" stream) (princ (display-display display) stream)) (t @@ -371,7 +385,7 @@ (print-unreadable-object (drawable stream :type t) (print-display-name (drawable-display drawable) stream) (write-string " " stream) - (prin1 (drawable-id drawable) stream))) + (let ((*print-base* 16)) (prin1 (drawable-id drawable) stream)))) (def-clx-class (window (:include drawable) (:copier nil) (:print-function print-drawable)) @@ -441,27 +455,27 @@ (deftype xatom () '(or string symbol)) -(defconstant *predefined-atoms* - '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP - :CARDINAL :COLORMAP :CURSOR - :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7 - :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE - :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP - :RGB_BLUE_MAP :RGB_DEFAULT_MAP - :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING - :VISUALID :WINDOW :WM_COMMAND :WM_HINTS - :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE - :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS - :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE - :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y - :SUBSCRIPT_X :SUBSCRIPT_Y - :UNDERLINE_POSITION :UNDERLINE_THICKNESS - :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT - :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT - :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE - :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT - :WM_CLASS :WM_TRANSIENT_FOR)) +(defconstant +predefined-atoms+ + '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP + :CARDINAL :COLORMAP :CURSOR + :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 + :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7 + :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE + :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP + :RGB_BLUE_MAP :RGB_DEFAULT_MAP + :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING + :VISUALID :WINDOW :WM_COMMAND :WM_HINTS + :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE + :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS + :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE + :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y + :SUBSCRIPT_X :SUBSCRIPT_Y + :UNDERLINE_POSITION :UNDERLINE_THICKNESS + :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT + :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT + :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE + :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT + :WM_CLASS :WM_TRANSIENT_FOR)) (deftype stringable () '(or string symbol)) @@ -471,19 +485,31 @@ (deftype timestamp () '(or null card32)) -(defconstant *bit-gravity-vector* - '#(:forget :north-west :north :north-east :west - :center :east :south-west :south - :south-east :static)) +(defconstant +bit-gravity-vector+ + '#(:forget :north-west :north :north-east :west + :center :east :south-west :south + :south-east :static)) (deftype bit-gravity () '(member :forget :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) -(defconstant *win-gravity-vector* - '#(:unmap :north-west :north :north-east :west - :center :east :south-west :south :south-east - :static)) +(defconstant +win-gravity-vector+ + '#(:unmap :north-west :north :north-east :west + :center :east :south-west :south :south-east + :static)) + +(defparameter *protocol-families* + '(;; X11/X.h, Family* + (:internet . 0) + (:decnet . 1) + (:chaos . 2) + ;; X11/Xauth.h "not part of X standard" + (:Local . 256) + (:Wild . 65535) + (:Netname . 254) + (:Krb5Principal . 253) + (:LocalHost . 252))) (deftype win-gravity () '(member :unmap :north-west :north :north-east :west @@ -527,7 +553,7 @@ (server-state (allocate-gcontext-state) :type gcontext-state) (local-state (allocate-gcontext-state) :type gcontext-state) (plist nil :type list) ; Extension hook - (next nil :type (or null gcontext)) + (next nil #-explorer :type #-explorer (or null gcontext)) ) (defun print-gcontext (gcontext stream depth) @@ -538,13 +564,13 @@ (write-string " " stream) (prin1 (gcontext-id gcontext) stream))) -(defconstant *event-mask-vector* - '#(:key-press :key-release :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :owner-grab-button)) +(defconstant +event-mask-vector+ + '#(:key-press :key-release :button-press :button-release + :enter-window :leave-window :pointer-motion :pointer-motion-hint + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion :keymap-state :exposure :visibility-change + :structure-notify :resize-redirect :substructure-notify :substructure-redirect + :focus-change :property-change :colormap-change :owner-grab-button)) (deftype event-mask-class () '(member :key-press :key-release :owner-grab-button :button-press :button-release @@ -557,11 +583,14 @@ (deftype event-mask () '(or mask32 (clx-list event-mask-class))) -(defconstant *pointer-event-mask-vector* - '#(%error %error :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) +(defconstant +pointer-event-mask-vector+ + ;; the first two elements used to be '%error '%error (i.e. symbols, + ;; and not keywords) but the vector is supposed to contain + ;; keywords, so I renamed them -dan 2004.11.13 + '#(:%error :%error :button-press :button-release + :enter-window :leave-window :pointer-motion :pointer-motion-hint + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion :keymap-state)) (deftype pointer-event-mask-class () '(member :button-press :button-release @@ -572,10 +601,10 @@ (deftype pointer-event-mask () '(or mask32 (clx-list pointer-event-mask-class))) -(defconstant *device-event-mask-vector* - '#(:key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) +(defconstant +device-event-mask-vector+ + '#(:key-press :key-release :button-press :button-release :pointer-motion + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion)) (deftype device-event-mask-class () '(member :key-press :key-release :button-press :button-release :pointer-motion @@ -585,9 +614,9 @@ (deftype device-event-mask () '(or mask32 (clx-list device-event-mask-class))) -(defconstant *state-mask-vector* - '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 - :button-1 :button-2 :button-3 :button-4 :button-5)) +(defconstant +state-mask-vector+ + '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 + :button-1 :button-2 :button-3 :button-4 :button-5)) (deftype modifier-key () '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) @@ -598,12 +627,12 @@ (deftype state-mask-key () '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) -(defconstant *gcontext-components* - '(:function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style - :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes - :arc-mode)) +(defconstant +gcontext-components+ + '(:function :plane-mask :foreground :background + :line-width :line-style :cap-style :join-style :fill-style + :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode + :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes + :arc-mode)) (deftype gcontext-key () '(member :function :plane-mask :foreground :background @@ -613,14 +642,16 @@ :arc-mode)) (deftype event-key () - '(member :key-press :key-release :button-press :button-release :motion-notify - :enter-notify :leave-notify :focus-in :focus-out :keymap-notify - :exposure :graphics-exposure :no-exposure :visibility-notify - :create-notify :destroy-notify :unmap-notify :map-notify :map-request - :reparent-notify :configure-notify :gravity-notify :resize-request - :configure-request :circulate-notify :circulate-request :property-notify - :selection-clear :selection-request :selection-notify - :colormap-notify :client-message :mapping-notify)) + '(or (member :key-press :key-release :button-press :button-release + :motion-notify :enter-notify :leave-notify :focus-in :focus-out + :keymap-notify :exposure :graphics-exposure :no-exposure + :visibility-notify :create-notify :destroy-notify :unmap-notify + :map-notify :map-request :reparent-notify :configure-notify + :gravity-notify :resize-request :configure-request :circulate-notify + :circulate-request :property-notify :selection-clear + :selection-request :selection-notify :colormap-notify :client-message + :mapping-notify) + (satisfies extension-event-key-p))) (deftype error-key () '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice @@ -629,11 +660,11 @@ (deftype draw-direction () '(member :left-to-right :right-to-left)) -(defconstant *boole-vector* - '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 - #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior - #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 - #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) +(defconstant +boole-vector+ + '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 + #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior + #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 + #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) (deftype boole-constant () `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 @@ -802,7 +833,7 @@ (let ((predicate (xintern type '-equal)) (id (xintern type '-id)) (dpy (xintern type '-display))) - (if (member type *clx-cached-types*) + (if (member type +clx-cached-types+) `(within-definition (,type make-mumble-equal) (declaim (inline ,predicate)) (defun ,predicate (a b) (eq a b))) @@ -824,10 +855,10 @@ ;;; Converts from keyword-lists to integer and back ;;; (defun encode-mask (key-vector key-list key-type) - ;; KEY-VECTOR is a vector containg bit-position keywords. The position of the - ;; keyword in the vector indicates its bit position in the resulting mask - ;; KEY-LIST is either a mask or a list of KEY-TYPE - ;; Returns NIL when KEY-LIST is not a list or mask. + ;; KEY-VECTOR is a vector containg bit-position keywords. The + ;; position of the keyword in the vector indicates its bit position + ;; in the resulting mask. KEY-LIST is either a mask or a list of + ;; KEY-TYPE Returns NIL when KEY-LIST is not a list or mask. (declare (type (simple-array keyword (*)) key-vector) (type (or mask32 list) key-list)) (declare (clx-values (or mask32 null))) @@ -858,7 +889,7 @@ (defun encode-event-mask (event-mask) (declare (type event-mask event-mask)) (declare (clx-values mask32)) - (or (encode-mask *event-mask-vector* event-mask 'event-mask-class) + (or (encode-mask +event-mask-vector+ event-mask 'event-mask-class) (x-type-error event-mask 'event-mask))) (defun make-event-mask (&rest keys) @@ -866,18 +897,18 @@ ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. (declare (type (clx-list event-mask-class) keys)) (declare (clx-values mask32)) - (encode-mask *event-mask-vector* keys 'event-mask-class)) + (encode-mask +event-mask-vector+ keys 'event-mask-class)) (defun make-event-keys (event-mask) ;; This is only defined for core events. (declare (type mask32 event-mask)) (declare (clx-values (clx-list event-mask-class))) - (decode-mask *event-mask-vector* event-mask)) + (decode-mask +event-mask-vector+ event-mask)) (defun encode-device-event-mask (device-event-mask) (declare (type device-event-mask device-event-mask)) (declare (clx-values mask32)) - (or (encode-mask *device-event-mask-vector* device-event-mask + (or (encode-mask +device-event-mask-vector+ device-event-mask 'device-event-mask-class) (x-type-error device-event-mask 'device-event-mask))) @@ -885,29 +916,29 @@ (declare (type modifier-mask modifier-mask)) (declare (clx-values mask16)) (or (and (eq modifier-mask :any) #x8000) - (encode-mask *state-mask-vector* modifier-mask 'modifier-key) + (encode-mask +state-mask-vector+ modifier-mask 'modifier-key) (x-type-error modifier-mask 'modifier-mask))) (defun encode-state-mask (state-mask) (declare (type (or mask16 (clx-list state-mask-key)) state-mask)) (declare (clx-values mask16)) - (or (encode-mask *state-mask-vector* state-mask 'state-mask-key) + (or (encode-mask +state-mask-vector+ state-mask 'state-mask-key) (x-type-error state-mask '(or mask16 (clx-list state-mask-key))))) (defun make-state-mask (&rest keys) ;; Useful for constructing modifier-mask, state-mask. (declare (type (clx-list state-mask-key) keys)) (declare (clx-values mask16)) - (encode-mask *state-mask-vector* keys 'state-mask-key)) + (encode-mask +state-mask-vector+ keys 'state-mask-key)) (defun make-state-keys (state-mask) (declare (type mask16 state-mask)) (declare (clx-values (clx-list state-mask-key))) - (decode-mask *state-mask-vector* state-mask)) + (decode-mask +state-mask-vector+ state-mask)) (defun encode-pointer-event-mask (pointer-event-mask) (declare (type pointer-event-mask pointer-event-mask)) (declare (clx-values mask32)) - (or (encode-mask *pointer-event-mask-vector* pointer-event-mask + (or (encode-mask +pointer-event-mask-vector+ pointer-event-mask 'pointer-event-mask-class) (x-type-error pointer-event-mask 'pointer-event-mask))) diff --git a/clx/cmudep.lisp b/clx/cmudep.lisp new file mode 100644 index 000000000..24a9a837b --- /dev/null +++ b/clx/cmudep.lisp @@ -0,0 +1,19 @@ +;;; -*- Package: XLIB -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/cmudep.lisp,v 1.3 2007/08/21 15:49:27 fgilham Rel $") +;;; +;;; ********************************************************************** +;;; +(in-package "XLIB") + +(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) + c-call:int + (host c-call:c-string) + (port c-call:int)) diff --git a/clx/debug/debug.lisp b/clx/debug/debug.lisp index 69f3dd636..82e4e38c5 100644 --- a/clx/debug/debug.lisp +++ b/clx/debug/debug.lisp @@ -20,6 +20,9 @@ ;;; Created 04/09/87 14:30:41 by LaMott G. OREN +#+cmu +(ext:file-comment "$Id: debug.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + (in-package :xlib) (export '(display-listen diff --git a/clx/debug/describe.lisp b/clx/debug/describe.lisp index 00371fc95..404786f99 100644 --- a/clx/debug/describe.lisp +++ b/clx/debug/describe.lisp @@ -20,6 +20,9 @@ ;;; Created 07/15/87 by LaMott G. OREN +#cmu +(ext:file-comment "$Id: describe.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + (in-package :xlib) (defparameter *request-parameters* (make-array (length *request-names*))) @@ -76,7 +79,7 @@ (string8 (format t " Bytes:~%~v@t" margin) (dotimes (k (- length (- j start))) - (format t "~a" (int-char (card8-get j))) + (format t "~a" (code-char (card8-get j))) (incf j))) (otherwise (format t " Bytes:~%~v@t" margin) diff --git a/clx/debug/event-test.lisp b/clx/debug/event-test.lisp index 5ded127ab..8d6320873 100644 --- a/clx/debug/event-test.lisp +++ b/clx/debug/event-test.lisp @@ -1,6 +1,15 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*- -(in-package :xtest :use '(:xlib :lisp)) +;;; This code was intended for CLUE. --FMG + +#+cmu +(ext:file-comment "$Id: event-test.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + +(defpackage "XTEST" + (:use :xlib :common-lisp) + ) + +(in-package "XTEST") (defstruct event key ; Event key diff --git a/clx/debug/keytrans.lisp b/clx/debug/keytrans.lisp index 333c1efa7..44db61c76 100644 --- a/clx/debug/keytrans.lisp +++ b/clx/debug/keytrans.lisp @@ -18,20 +18,23 @@ ;;; express or implied warranty. ;;; +#+cmu +(ext:file-comment "$Id: keytrans.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + (in-package :xlib) (defun list-missing-keysyms () ;; Lists explorer characters which have no keysyms (dotimes (i 256) - (unless (character->keysyms (int-char i)) - (format t "~%(define-keysym ~@c ~d)" (int-char i) i)))) + (unless (character->keysyms (code-char i)) + (format t "~%(define-keysym ~@c ~d)" (code-char i) i)))) (defun list-multiple-keysyms () ;; Lists characters with more than one keysym (dotimes (i 256) - (when (cdr (character->keysyms (int-char i))) - (format t "~%Character ~@c [~d] has keysyms" (int-char i) i) - (dolist (keysym (character->keysyms (int-char i))) + (when (cdr (character->keysyms (code-char i))) + (format t "~%Character ~@c [~d] has keysyms" (code-char i) i) + (dolist (keysym (character->keysyms (code-char i))) (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) (defun check-lowercase-keysyms () @@ -52,7 +55,7 @@ char (and lowercase (ldb (byte 8 8) lowercase)) (and lowercase (ldb (byte 8 0) lowercase)) - (int-char lowercase) + (code-char lowercase) (ldb (byte 8 8) (char-int should-be)) (ldb (byte 8 0) (char-int should-be)) should-be))) diff --git a/clx/debug/trace.lisp b/clx/debug/trace.lisp index 276e2f56b..364a3f0f9 100644 --- a/clx/debug/trace.lisp +++ b/clx/debug/trace.lisp @@ -32,6 +32,9 @@ ;;; Created 09/14/87 by LaMott G. OREN +#+cmu +(ext:file-comment "$Id: trace.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + (in-package :xlib) (eval-when (load eval) diff --git a/clx/debug/util.lisp b/clx/debug/util.lisp index 7db6be640..471be6d4e 100644 --- a/clx/debug/util.lisp +++ b/clx/debug/util.lisp @@ -20,6 +20,9 @@ ;;; Created 04/09/87 14:30:41 by LaMott G. OREN +#+cmu +(ext:file-comment "$Id: util.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + (in-package :xlib) (export '(display-root @@ -145,12 +148,13 @@ ;; Returns a list of windows in the order that they are printed. (declare (arglist window) (type window window) - (values (list window))) + (clx-values (list window))) (let ((props (mapcar #'(lambda (prop) (multiple-value-bind (data type format) (get-property window prop) (case type - (:string (setq data (coerce data 'string)))) + (:string (setq data (map 'string #'code-char data))) + (:utf8_string (setq data (map 'string #'code-char data)))) (list prop format type data))) (list-properties window))) (result (list window))) diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp index 82fb9e52c..ce67e3f5c 100644 --- a/clx/defsystem.lisp +++ b/clx/defsystem.lisp @@ -18,19 +18,275 @@ ;;; ;;; Franz Incorporated provides this software "as is" without express or ;;; implied warranty. -#+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/defsystem.lisp,v 1.7 2003/07/20 15:55:23 emarsden Exp $") ;;; #+ features used in this file +;;; clx-ansi-common-lisp +;;; lispm +;;; genera +;;; minima +;;; lucid +;;; lcl3.0 +;;; apollo +;;; kcl +;;; ibcl +;;; excl ;;; CMU +;;; sbcl + +#+cmu +(ext:file-comment "$Id: defsystem.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $") + +#+(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) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* si:*ansi-common-lisp-readtable*)) -(cl:in-package "XLIB") +#-(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) +;;;; Lisp Machines + +#+(and lispm (not genera)) +(global:defsystem CLX + (:pathname-default "clx:clx;") + (:patchable "clx:patch;" clx-ti) + (:initial-status :experimental) + + (:module package "package") + (:module depdefs "depdefs") + (:module clx "clx") + (:module dependent "dependent") + (:module macros "macros") + (:module bufmac "bufmac") + (:module buffer "buffer") + (:module display "display") + (:module gcontext "gcontext") + (:module requests "requests") + (:module input "input") + (:module fonts "fonts") + (:module graphics "graphics") + (:module text "text") + (:module attributes "attributes") + (:module translate "translate") + (:module keysyms "keysyms") + (:module manager "manager") + (:module image "image") + (:module resource "resource") + (:module doc "doc") + + (:compile-load package) + (:compile-load depdefs + (:fasload package)) + (:compile-load clx + (:fasload package depdefs)) + (:compile-load dependent + (:fasload package depdefs clx)) + ;; Macros only needed for compilation + (:skip :compile-load macros + (:fasload package depdefs clx dependent)) + ;; Bufmac only needed for compilation + (:skip :compile-load bufmac + (:fasload package depdefs clx dependent macros)) + (:compile-load buffer + (:fasload package depdefs clx dependent macros bufmac)) + (:compile-load display + (:fasload package depdefs clx dependent macros bufmac buffer)) + (:compile-load gcontext + (:fasload package depdefs clx dependent macros bufmac buffer display)) + (:compile-load input + (:fasload package depdefs clx dependent macros bufmac buffer display)) + (:compile-load requests + (:fasload package depdefs clx dependent macros bufmac buffer display input)) + (:compile-load fonts + (:fasload package depdefs clx dependent macros bufmac buffer display)) + (:compile-load graphics + (:fasload package depdefs clx dependent macros fonts bufmac buffer display + fonts)) + (:compile-load text + (:fasload package depdefs clx dependent macros fonts bufmac buffer display + gcontext fonts)) + (:compile-load-init attributes + (dependent) + (:fasload package depdefs clx dependent macros bufmac buffer display)) + (:compile-load translate + (:fasload package depdefs clx dependent macros bufmac buffer display)) + (:compile-load keysyms + (:fasload package depdefs clx dependent macros bufmac buffer display + translate)) + (:compile-load manager + (:fasload package depdefs clx dependent macros bufmac buffer display)) + (:compile-load image + (:fasload package depdefs clx dependent macros bufmac buffer display)) + (:compile-load resource + (:fasload package depdefs clx dependent macros bufmac buffer display)) + (:auxiliary doc) + ) + + +;;; Symbolics Lisp Machines +#+Genera +(scl:defsystem CLX + (:default-pathname "SYS:X11;CLX;" + :pretty-name "CLX" + :maintaining-sites (:scrc) + :distribute-sources t + :distribute-binaries t + :source-category :basic) + (:module doc ("doc") + (:type :lisp-example)) + (:serial + "package" "depdefs" "generalock" "clx" "dependent" "macros" "bufmac" + "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" + "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) + +#+Minima +(zl:::scl:defsystem Minima-CLX + (:default-pathname "SYS:X11;CLX;" + :pretty-name "Minima CLX" + :maintain-journals nil + :maintaining-sites (:scrc) + :distribute-sources t + :distribute-binaries t + :source-category :basic + :default-module-type :minima-lisp) + (:module doc ("doc") + (:type :lisp-example)) + (:serial + "package" "depdefs" "clx" "dependent" "macros" "bufmac" + "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" + "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) + + +;;; Franz + +;; +;; The following is a suggestion. If you comment out this form be +;; prepared for possible deadlock, since no interrupts will be recognized +;; while reading from the X socket if the scheduler is not running. +;; +#+excl +(setq compiler::generate-interrupt-checks-switch + (compile nil + '(lambda (safety size speed &optional debug) + (declare (ignore size debug)) + (or (< speed 3) (> safety 0))))) + + +;;; Allegro + +#+allegro +(excl:defsystem :clx + () + |package| + (|excldep| + :load-before-compile (|package|) + :recompile-on (|package|)) + (|depdefs| + :load-before-compile (|package| |excldep|) + :recompile-on (|excldep|)) + (|clx| + :load-before-compile (|package| |excldep| |depdefs|) + :recompile-on (|package| |excldep| |depdefs|)) + (|dependent| + :load-before-compile (|package| |excldep| |depdefs| |clx|) + :recompile-on (|clx|)) + (|exclcmac| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|) + :recompile-on (|dependent|)) + (|macros| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac|) + :recompile-on (|exclcmac|)) + (|bufmac| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros|) + :recompile-on (|macros|)) + (|buffer| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac|) + :recompile-on (|bufmac|)) + (|display| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer|) + :recompile-on (|buffer|)) + (|gcontext| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display|) + :recompile-on (|display|)) + (|input| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display|) + :recompile-on (|display|)) + (|requests| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display| + |input|) + :recompile-on (|display|)) + (|fonts| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display|) + :recompile-on (|display|)) + (|graphics| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display| + |fonts|) + :recompile-on (|fonts|)) + (|text| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display| + |gcontext| |fonts|) + :recompile-on (|gcontext| |fonts|) + :load-after (|translate|)) + ;; The above line gets around a compiler macro expansion bug. + + (|attributes| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display|) + :recompile-on (|display|)) + (|translate| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display| + |text|) + :recompile-on (|display|)) + (|keysyms| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display| + |translate|) + :recompile-on (|translate|)) + (|manager| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display|) + :recompile-on (|display|)) + (|image| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display|) + :recompile-on (|display|)) + + ;; Don't know if l-b-c list is correct. XX + (|resource| + :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| + |exclcmac| |macros| |bufmac| |buffer| |display|) + :recompile-on (|display|)) + ) + +#+allegro +(excl:defsystem :clx-debug + (:default-pathname "debug/" + :needed-systems (:clx) + :load-before-compile (:clx)) + |describe| |keytrans| |trace| |util|) ;;;; Compile CLX @@ -54,6 +310,54 @@ ;;; out correctly, but you may have to explicitly give the source and ;;; binary file types. +;;; An attempt at compiling the C language sources is also made, +;;; but you may have to set different compiler switches +;;; should be. If it doesn't do the right thing, then do +;;; (compile-clx "" "" :compile-c NIL) +;;; to prevent the compilation. + +;;; compilation notes +;;; lucid2.0/hp9000s300 +;;; must uudecode the file make-sequence-patch.uu + +#+(or lucid kcl ibcl cmu) +(defun clx-foreign-files (binary-path) + + #+(and lucid (not lcl3.0) (or mc68000 mc68020)) + (load (merge-pathnames "make-sequence-patch" binary-path)) + + #+(and lucid apollo) + (lucid::load-foreign-file + (namestring (merge-pathnames "socket" binary-path)) + :preserve-pathname t) + + #+(and lucid (not apollo)) + (lucid::load-foreign-files + (list (namestring (merge-pathnames "socket.o" binary-path))) + '("-lc")) + + #+cmu + (declare (ignore binary-path)) + #+(or cmu sbcl) + (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) + c-call:int + (host c-call:c-string) + (port c-call:int)) + + #+(or kcl ibcl) + (progn + (let ((pathname (merge-pathnames "sockcl.o" binary-path)) + (options + (concatenate + 'string + (namestring (merge-pathnames "socket.o" binary-path)) + " -lc"))) + (format t "~&Faslinking ~A with ~A.~%" pathname options) + (si:faslink (namestring pathname) options) + (format t "~&Finished faslinking ~A.~%" pathname))) + ) + +#-(or lispm allegro Minima) (defun compile-clx (&optional (source-pathname-defaults "") (binary-pathname-defaults "") @@ -74,6 +378,7 @@ :version (pathname-version source-path))) (binary-path (merge-pathnames binary-pathname-defaults path)) + #+clx-ansi-common-lisp (*compile-verbose* t) (*load-verbose* t)) ;; Make sure source-path and binary-path file types are distinct so @@ -87,28 +392,76 @@ (format t "~&;;; Default paths: ~s ~s~%" source-path binary-path) + ;; In lucid make sure we're using the compiler in production mode. + #+lcl3.0 + (progn + (unless (member :pqc *features*) + (cerror + "Go ahead anyway." + "Lucid's production mode compiler must be loaded to compile CLX.")) + (proclaim '(optimize (speed 3) + (safety 1) + (space 0) + (compilation-speed 0)))) + (labels ((compile-lisp (filename) (let ((source (merge-pathnames filename source-path)) (binary (merge-pathnames filename binary-path))) ;; If the source and binary pathnames are the same, ;; then don't supply an output file just to be sure ;; compile-file defaults correctly. + #+(or kcl ibcl) (load source) (if (equal source binary) (compile-file source) (compile-file source :output-file binary)) binary)) (compile-and-load (filename) - (load (compile-lisp filename)))) + (load (compile-lisp filename))) + #+(or lucid kcl ibcl) + (compile-c (filename) + (let* ((c-filename (concatenate 'string filename ".c")) + (o-filename (concatenate 'string filename ".o")) + (src (merge-pathnames c-filename source-path)) + (obj (merge-pathnames o-filename binary-path)) + (args (list "-c" (namestring src) + "-o" (namestring obj) + #+mips "-G 0" + #+(or hp sysv) "-DSYSV" + #+(and mips (not dec)) "-I/usr/include/bsd" + #-(and mips (not dec)) "-DUNIXCONN" + #+(and lucid pa) "-DHPUX -DHPUX7.0" + ))) + (format t ";;; cc~{ ~A~}~%" args) + (unless + (zerop + #+lucid + (multiple-value-bind (iostream estream exitstatus pid) + ;; in 2.0, run-program is exported from system: + ;; in 3.0, run-program is exported from lcl: + ;; system inheirits lcl + (system::run-program "cc" :arguments args) + (declare (ignore iostream estream pid)) + exitstatus) + #+(or kcl ibcl) + (system (format nil "cc~{ ~A~}" args))) + (error "Compile of ~A failed." src))))) ;; Now compile and load all the files. ;; Defer compiler warnings until everything's compiled, if possible. - (with-compilation-unit + (#+(or clx-ansi-common-lisp CMU) with-compilation-unit + #+lcl3.0 lucid::with-deferred-warnings + #-(or lcl3.0 clx-ansi-common-lisp CMU) progn () (compile-and-load "package") + #+(or lucid kcl ibcl) (when compile-c (compile-c "socket")) + #+(or kcl ibcl) (compile-lisp "sockcl") + #+(or lucid kcl ibcl) (clx-foreign-files binary-path) + #+excl (compile-and-load "excldep") (compile-and-load "depdefs") (compile-and-load "clx") (compile-and-load "dependent") + #+excl (compile-and-load "exclcmac") ; these are just macros (compile-and-load "macros") ; these are just macros (compile-and-load "bufmac") ; these are just macros (compile-and-load "buffer") @@ -147,6 +500,7 @@ ;;; (LOAD <clx-defsystem-file>) ;;; (LOAD-CLX <binary-specific-clx-directory>) +#-(or lispm allegro Minima) (defun load-clx (&optional (binary-pathname-defaults "") &key (macrosp nil)) @@ -167,10 +521,13 @@ (load binary)))) (load-binary "package") + #+(or lucid kcl ibcl cmu) (clx-foreign-files binary-path) + #+excl (load-binary "excldep") (load-binary "depdefs") (load-binary "clx") (load-binary "dependent") (when macrosp + #+excl (load-binary "exclcmac") (load-binary "macros") (load-binary "bufmac")) (load-binary "buffer") @@ -188,3 +545,27 @@ (load-binary "image") (load-binary "resource") ))) + +;;; +;;; ECL likes to combine several files into a single dynamically loadable +;;; library. +;;; +#+ecl +(defconstant +clx-modules+ + '("package" "depdefs" "clx" "dependent" "macros" "bufmac" "buffer" + "display" "gcontext" "input" "requests" "fonts" "graphics" "text" + "attributes" "translate" "keysyms" "manager" "image" "resource")) + +#+(or) ;ecl +(flet ((compile-if-old (destdir sources &rest options) + (mapcar #'(lambda (source) + (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object)))) + (unless (and (probe-file object) + (>= (file-write-date object) (file-write-date source))) + (apply #'compile-file source :output-file object options)) + object)) + sources))) + (let ((clx-objects (compile-if-old "./" +clx-modules+ :system-p t))) + (c::build-fasl "clx" :lisp-files clx-objects))) + +(mapcar #'load +clx-modules+) diff --git a/clx/demo/README b/clx/demo/README new file mode 100644 index 000000000..d67dd3cb7 --- /dev/null +++ b/clx/demo/README @@ -0,0 +1,30 @@ +$Id: README,v 1.1 2007/08/21 15:49:29 fgilham Rel $ + +A brief description of the files in this directory, as best I (FMG) can figure. + +bezier.lisp: An example of how to define an extension. As far as I know, there's no bezier +extension in most X servers, so this won't do much. + +beziertest.lisp: An example of how to invoke the bezier extension. + +Both the above files are obsolete. + +clclock.lisp: Display a clock using Roman numerals. Works. + +clipboard.lisp: Shows how to manage cut-and-paste (the X clipboard). Works. + +clx-demos.lisp: Some old graphics demos. Works. Many of them have been updated in the cmucl +src/contrib/demos directory. + +gl-test.lisp: A test and demonstration of the GL interface. Seems to mostly work on my system. + +hello.lisp: A hello-world X program that gives a kind of skeleton for X programs. Works. + +mandel.lisp: A Mandelbrot set generator that I couldn't get to work, even by hacking quite a +bit on it. There are some obvious problems in the code that I tried fixing and some less +obvious ones that I couldn't fix. The code here is as I originally found it. + +menu.lisp: An old menu demonstration program. Works. + +zoid.lisp: Another program for interfacing with extensions. Again this extension (the "zoid +extension") doesn't exist in any X server I know of. This is another obsolete file. diff --git a/clx/demo/bezier.lisp b/clx/demo/bezier.lisp index fca439b00..6028679f3 100644 --- a/clx/demo/bezier.lisp +++ b/clx/demo/bezier.lisp @@ -18,6 +18,9 @@ ;;; express or implied warranty. ;;; +#+cmu +(ext:file-comment "$Id: bezier.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + (in-package :xlib) (export 'draw-curves) diff --git a/clx/demo/beziertest.lisp b/clx/demo/beziertest.lisp index dc5bb91a2..6569fc2b9 100644 --- a/clx/demo/beziertest.lisp +++ b/clx/demo/beziertest.lisp @@ -18,6 +18,9 @@ ;;; express or implied warranty. ;;; +#+cmu +(ext:file-comment "$Id: beziertest.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + (in-package :xlib) (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) diff --git a/clx/demo/clclock.lisp b/clx/demo/clclock.lisp new file mode 100644 index 000000000..9ad9a8b7a --- /dev/null +++ b/clx/demo/clclock.lisp @@ -0,0 +1,81 @@ +#+cmu +(ext:file-comment "$Id: clclock.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") + +(defpackage "XCLCLOCK" + (:use "CL") + (:export "CLOCK")) + +(in-package "XCLCLOCK") + +(defvar *display* (xlib:open-default-display)) +(defvar *screen* (xlib:display-default-screen *display*)) +(defvar *colormap* (xlib:screen-default-colormap *screen*)) + +(defvar *font* (xlib:open-font *display* "fixed")) +(defvar *win*) + +(multiple-value-bind (width ascent) + (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII") + (setq *win* + (xlib:create-window + :parent (xlib:screen-root *screen*) + :x 512 + :y 512 + :width (+ 20 width) + :height (+ 20 ascent) + :background (xlib:alloc-color *colormap* + (xlib:lookup-color *colormap* + "midnightblue"))))) + +(defvar *gcontext* (xlib:create-gcontext + :drawable *win* + :fill-style :solid + :background (xlib:screen-white-pixel *screen*) + :foreground (xlib:alloc-color *colormap* + (xlib:lookup-color + *colormap* + "yellow")) + :font *font*)) + +(defvar *background* (xlib:create-gcontext + :drawable *win* + :fill-style :solid + :background (xlib:screen-white-pixel *screen*) + :foreground (xlib:alloc-color *colormap* + (xlib:lookup-color *colormap* + "midnightblue")) + :font *font*)) +(defvar *palette* nil) +(defvar *black* (xlib:screen-black-pixel *screen*)) + +(defun romanize (arg) + (if (zerop arg) + "O" + (format nil "~@R" arg))) + +(defun clock-string () + (multiple-value-bind (s m h) (decode-universal-time (get-universal-time)) + (format nil "~a ~a ~a" (romanize h) (romanize m) (romanize s)))) + +(defun update-clockface () + (let ((string (clock-string))) + (let ((string-width (xlib:text-width *gcontext* string))) + (xlib:draw-rectangle *win* *background* + 0 0 + (xlib:drawable-width *win*) + (xlib:drawable-height *win*) + :fill-p) + (xlib:draw-glyphs *win* *gcontext* + (- (truncate + (- (xlib:drawable-width *win*) string-width) + 2) + 10) + (- (xlib:drawable-height *win*) 10) + string))) + (xlib:display-force-output *display*)) + +(defun clock () + (xlib:map-window *win*) + (loop + (update-clockface) + (sleep 1))) diff --git a/clx/demo/clipboard.lisp b/clx/demo/clipboard.lisp new file mode 100644 index 000000000..19c505812 --- /dev/null +++ b/clx/demo/clipboard.lisp @@ -0,0 +1,203 @@ +;;; This is a pretty direct translation of the Xlib selection test +;;; program by Tor Andersson found at +;;; <http://ghostscript.com/~tor/repos/Klipp/x11clipboard.c>, with +;;; minor enhancements: +;;; +;;; * gdk requestors apparently unconditionally request UTF8_STRING +;;; selections without checking the TARGETS list of the selection +;;; owner -- and apparently even never request anything else. This +;;; seems to be in contradiction with the freedesktop.org draft +;;; specification at +;;; <http://www.pps.jussieu.fr/~jch/software/UTF8_STRING/UTF8_STRING.text> +;;; (linked from <http://freedesktop.org/Standards>), but this is +;;; the real world and we have to live in it. It would be nice if +;;; someone in the freedesktop community could resolve this. +;;; +;;; * the original C code, in the XSendEvent call, has an event mask +;;; of SelectionNotify. SelectionNotify is not an event mask at +;;; all, however: but the code works "by accident" because +;;; SelectionNotify happens to have value 31, which has enough bits +;;; flipped on that most clients select on at least one of those +;;; events. This bug is fixed below. +;;; +;;; * [ Update 2004-11-29, superseding to some extent the above ] in +;;; fact, these two things are related. ICCCM says that the event +;;; disclaiming the ability to send in a given format should be sent +;;; with an empty event mask ("2.2 Responsibilities of the Selection +;;; Owner"). +;;; +;;; * implemented the ICCCM-required TIMESTAMP and MULTIPLE targets +;;; +;;; As ever with these things, the divisions in intellectual property +;;; between the writer of the original C program, Tor Andersson +;;; (contactable at tor [dot] andersson [at] gmail [dot] com) and the +;;; translator (Christophe Rhodes, csr21 [at] cam [dot] ac [dot] uk) +;;; are murky, probably depend on jurisdiction, and in addition for +;;; such a small work are essentially trivial. To set peoples' minds +;;; at ease, Tor wishes this information to be disseminated as widely +;;; as possible. + +;;; Copyright (c) 2004, Christophe Rhodes +;;; +;;; 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. + +#+cmu +(ext:file-comment "$Id: clipboard.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") + +(defpackage "CLIPBOARD" + (:use "CL" "XLIB") + (:export "MAIN")) + +(in-package "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 +;;; was secondary to achieving First Paste. +(defvar *window*) +(defvar *time*) +(defvar *display*) + +(defun ownselect () + (format t "~&> set-selection-owner~%") (finish-output) + (set-selection-owner *display* :primary *window* *time*) + (unless (eq *window* (selection-owner *display* :primary)) + (write-string "failed to own primary"))) + +(defun deselect () + (format t "~&> unset-selection-owner~%") (finish-output) + (set-selection-owner *display* :primary nil *time*) + (unless (eq nil (selection-owner *display* :primary)) + (write-string "failed to disown primary"))) + +(defun ask-paste () + (format t "~&! deleting properties on window~%") (finish-output) + (delete-property *window* :aeclip-target) + (delete-property *window* :aeclip-string) + (delete-property *window* :aeclip-utf8_string) + (delete-property *window* :aeclip-text) + (format t "~&> convert-selection TARGETS~%") (finish-output) + (convert-selection :primary :targets *window* :aeclip-target) + (format t "~&> convert-selection STRING~%") (finish-output) + (convert-selection :primary :string *window* :aeclip-string) + (format t "~&> convert-selection UTF8_STRING~%") (finish-output) + (convert-selection :primary :utf8_string *window* :aeclip-utf8_string) + (format t "~&> convert-selection TEXT~%") (finish-output) + (convert-selection :primary :text *window* :aeclip-text) + nil) + +(defun recv-paste (property) + (multiple-value-bind (data name format) + (get-property *window* property) + (format t "~&< get-prop ~S " name) + (case format + (32 (format t "[~{~S~^,~}]" + (mapcar (lambda (x) (atom-name *display* x)) data))) + (8 (format t "~S" (map 'string 'code-char data))) + (t (format t "format=~S data=~S" format data))) + (format t "~%") (finish-output) + (delete-property *window* property))) + +(defun send-copy (selection target property requestor time) + (flet ((send (target property) + (case target + ((:string) + (format t "~&> sending text data~%") (finish-output) + (change-property requestor property + "Hello, World (from the CLX clipboard)!" + target 8 + :transform #'char-code) + property) + (:targets + (format t "~&> sending targets list~%") (finish-output) + ;; ARGH. Can't use :TRANSFORM as we scribble over CLX's buffer. + (let ((targets + (mapcar (lambda (x) (intern-atom *display* x)) + '(:targets :timestamp :multiple :string)))) + (change-property requestor property targets target 32)) + property) + (:timestamp + (format t "~&> sending timestamp~%") (finish-output) + (change-property requestor property (list *time*) target 32) + property) + (t + (format t "~&> sending none~%") (finish-output) + nil)))) + (case target + ;; WARNING: this is untested. I don't know of any clients which + ;; use the :MULTIPLE target. + (:multiple + (let* ((list (get-property requestor property)) + (plist (mapcar (lambda (x) (atom-name *display* x)) list))) + (loop for (ptarget pproperty) on plist by #'cddr + with all-succeeded = t + if (send ptarget pproperty) + collect ptarget into result + and collect pproperty into result + else + collect nil into result + and collect pproperty into result + and do (setf all-succeeded nil) + finally (unless all-succeeded + (let ((new-list + (mapcar (lambda (x) (intern-atom *display* x)) + result))) + (change-property requestor property new-list + target 32)))))) + (t (setf property (send target property)))) + (send-event requestor :selection-notify (make-event-mask) + :selection selection :target target + :property property :time time + :event-window requestor :window requestor))) + +(defun main () + (let* ((*display* (open-default-display)) + (screen (display-default-screen *display*)) + (*window* + (create-window + :parent (screen-root screen) + :x 10 :y 10 :width 200 :height 200 + :event-mask (make-event-mask :button-press :property-change)))) + (map-window *window*) + (display-finish-output *display*) + (event-case (*display*) + (:button-press (code time) + (format t "~&ButtonPress~%") (finish-output) + (case code + (1 (setf *time* time) (ownselect)) + (2 (ask-paste)) + (3 (deselect)))) + (:client-message () + (format t "~&ClientMessage~%") (finish-output)) + (:selection-clear (selection) + (format t "~&SelectionClear ~S~%" selection) (finish-output)) + (:selection-notify (selection target property) + (format t "~&SelectionNotify ~S ~S ~S~%" selection target property) + (finish-output) + (unless (eq property nil) + (recv-paste property)) + (display-finish-output *display*)) + (:selection-request (selection target property requestor time) + (format t "~&SelectionRequest ~S ~S ~S~%" selection target property) + (finish-output) + (send-copy selection target property requestor time) + (display-finish-output *display*)) + (:property-notify (atom state) + (format t "~&PropertyNotify ~S ~S~%" atom state) (finish-output))))) diff --git a/clx/demo/clx-demos.lisp b/clx/demo/clx-demos.lisp new file mode 100644 index 000000000..442b82e7a --- /dev/null +++ b/clx/demo/clx-demos.lisp @@ -0,0 +1,1065 @@ +;;; -*- Mode: Lisp; Package: Demos -*- +;;; +;;; This file contains various graphics hacks written and ported over the +;;; years by various and numerous persons. +;;; +;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. +;;; + +#+cmu +(ext:file-comment "$Id: clx-demos.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") + +(defpackage :demos (:use :common-lisp) + (:export do-all-demos demo)) + +(in-package :demos) + + +;;;; Graphic demos wrapper macro. + +;;; This wrapper macro should be reconsidered with respect to its property +;;; list usage. Possibly a demo structure should be used with *demos* +;;; pointing to these instead of function names. Also, something should +;;; be done about a title window that displays the name of the demo while +;;; it is running. + +(defparameter *demos* nil) + +(defvar *display* nil) +(defvar *screen* nil) +(defvar *root* nil) +(defvar *black-pixel* nil) +(defvar *white-pixel* nil) +(defvar *window* nil) + +(defvar *delay* .01) ; This is necessary on current hardware to make the demos run slow enough + ; to actually see something. + +(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms) + `(progn + (defun ,fun-name ,args + ,doc + (unless *display* +;; #+:cmu +;; (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) + #+(or cmu sbcl allegro) + (progn + (setf *display* (xlib::open-default-display)) + (setf *screen* (xlib:display-default-screen *display*))) + #-(or cmu sbcl allegro clisp) + (progn + ;; Portable method + (setf *display* (xlib:open-display (machine-instance))) + (setf *screen* (xlib:display-default-screen *display*))) + (setf *root* (xlib:screen-root *screen*)) + (setf *black-pixel* (xlib:screen-black-pixel *screen*)) + (setf *white-pixel* (xlib:screen-white-pixel *screen*))) + (let ((*window* (xlib:create-window :parent *root* + :x ,x :y ,y + :event-mask nil + :width ,width :height ,height + :background *white-pixel* + :border *black-pixel* + :border-width 2 + :override-redirect :on))) + (xlib:map-window *window*) + ;; + ;; I hate to do this since this is not something any normal + ;; program should do ... + (setf (xlib:window-priority *window*) :above) + (xlib:display-finish-output *display*) + (unwind-protect + (progn ,@forms) + (xlib:unmap-window *window*) + (xlib:display-finish-output *display*)))) + (setf (get ',fun-name 'demo-name) ',demo-name) + (setf (get ',fun-name 'demo-doc) ',doc) + (export ',fun-name) + (pushnew ',fun-name *demos*) + ',fun-name)) + + +;;;; Main entry points. + +(defun do-all-demos () + (loop + (dolist (demo *demos*) + (funcall demo) + (sleep 3)))) + +;;; DEMO is a hack to get by. It should be based on creating a menu. At +;;; that time, *name-to-function* should be deleted, since this mapping will +;;; be manifested in the menu slot name cross its action. Also the +;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for +;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". +;;; + +(defvar *name-to-function* (make-hash-table :test #'eq)) +(defvar *keyword-package* (find-package "KEYWORD")) + +(defun demo () + (macrolet ((read-demo () + `(let ((*package* *keyword-package*)) + (read)))) + (dolist (d *demos*) + (setf (gethash (intern (string-upcase (get d 'demo-name)) + *keyword-package*) + *name-to-function*) + d)) + (loop + (fresh-line) + (dolist (d *demos*) + (write-string " ") + (write-line (get d 'demo-name))) + (write-string " ") + (write-line "Help <demo name>") + (write-string " ") + (write-line "Quit") + (write-string "Enter demo name: ") + (let ((demo (read-demo))) + (case demo + (:help + (let* ((demo (read-demo)) + (fun (gethash demo *name-to-function*))) + (fresh-line) + (if fun + (format t "~&~%~A~&~%" (get fun 'demo-doc)) + (format t "Unknown demo name -- ~A." demo)))) + (:quit (return t)) + (t + (let ((fun (gethash demo *name-to-function*))) + (if fun + #+mp + (mp:make-process #'(lambda () + (loop + (funcall fun) + (sleep 2))) + :name (format nil "~S" demo)) + #-mp + (funcall fun) + (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) + + +;;;; Shared demo utilities. + +(defun full-window-state (w) + (xlib:with-state (w) + (values (xlib:drawable-width w) (xlib:drawable-height w) + (xlib:drawable-x w) (xlib:drawable-y w) + (xlib:window-map-state w)))) + + +;;;; Greynetic. + +;;; GREYNETIC displays random sized and shaded boxes in a window. This is +;;; real slow. It needs work. +;;; +(defun greynetic (window duration) + (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 + :drawable window)) + (gcontext (xlib:create-gcontext :drawable window + :background *white-pixel* + :foreground *black-pixel* + :tile pixmap + :fill-style :tiled))) + (multiple-value-bind (width height) (full-window-state window) + (dotimes (i duration) + (let* ((pixmap-data (greynetic-pixmapper)) + (image (xlib:create-image :width 32 :height 32 + :depth 1 :data pixmap-data))) + (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) + (xlib:draw-rectangle window gcontext + (- (random width) 5) + (- (random height) 5) + (+ 4 (random (truncate width 3))) + (+ 4 (random (truncate height 3))) + t)) + (xlib:display-force-output *display*) + (sleep *delay*))) + (xlib:free-gcontext gcontext) + (xlib:free-pixmap pixmap))) + +(defvar *greynetic-pixmap-array* + (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) + +(defun greynetic-pixmapper () + (let ((pixmap-data *greynetic-pixmap-array*)) + (dotimes (i 4) + (declare (fixnum i)) + (let ((nibble (random 16))) + (setf nibble (logior nibble (ash nibble 4)) + nibble (logior nibble (ash nibble 8)) + nibble (logior nibble (ash nibble 12)) + nibble (logior nibble (ash nibble 16))) + (dotimes (j 32) + (let ((bit (if (logbitp j nibble) 1 0))) + (setf (aref pixmap-data i j) bit + (aref pixmap-data (+ 4 i) j) bit + (aref pixmap-data (+ 8 i) j) bit + (aref pixmap-data (+ 12 i) j) bit + (aref pixmap-data (+ 16 i) j) bit + (aref pixmap-data (+ 20 i) j) bit + (aref pixmap-data (+ 24 i) j) bit + (aref pixmap-data (+ 28 i) j) bit))))) + pixmap-data)) + +#+nil +(defdemo greynetic-demo "Greynetic" (&optional (duration 300)) + 100 100 600 600 + "Displays random grey rectangles." + (greynetic *window* duration)) + + +;;;; Qix. + +(defstruct qix + buffer + (dx1 5) + (dy1 10) + (dx2 10) + (dy2 5)) + +(defun construct-qix (length) + (let ((qix (make-qix))) + (setf (qix-buffer qix) (make-circular-list length)) + qix)) + +(defun make-circular-list (length) + (let ((l (make-list length))) + (rplacd (last l) l))) + + +(defun qix (window lengths duration) + "Each length is the number of lines to put in a qix, and that many qix + (of the correct size) are put up on the screen. Lets the qix wander around + the screen for Duration steps." + (let ((histories (mapcar #'construct-qix lengths))) + (multiple-value-bind (width height) (full-window-state window) + (declare (fixnum width height)) + (xlib:clear-area window) + (xlib:display-force-output *display*) + (do ((h histories (cdr h)) + (l lengths (cdr l))) + ((null h)) + (do ((x (qix-buffer (car h)) (cdr x)) + (i 0 (1+ i))) + ((= i (car l))) + (rplaca x (make-array 4)))) + ;; Start each qix at a random spot on the screen. + (dolist (h histories) + (let ((x (random width)) + (y (random height))) + (rplaca (qix-buffer h) + (make-array 4 :initial-contents (list x y x y))))) + (rplacd (last histories) histories) + (let ((x1 0) (y1 0) (x2 0) (y2 0) + (dx1 0) (dy1 0) (dx2 0) (dy2 0) + tem line next-line qix + (gc (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel* + :line-width 0 :line-style :solid + :function boole-c2))) + (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) + (dotimes (i duration) + ;; Line is the next line in the next qix. Rotate this qix and + ;; the qix ring. + (setq qix (car histories)) + (setq line (car (qix-buffer qix))) + (setq next-line (cadr (qix-buffer qix))) + (setf (qix-buffer qix) (cdr (qix-buffer qix))) + (setq histories (cdr histories)) + (setf x1 (svref line 0)) + (setf y1 (svref line 1)) + (setf x2 (svref line 2)) + (setf y2 (svref line 3)) + (xlib:draw-line window gc x1 y1 x2 y2) + (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) + (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) + (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) + (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) + (cond ((> dx1 10) (setq dx1 10)) + ((< dx1 -10) (setq dx1 -10))) + (cond ((> dy1 10) (setq dy1 10)) + ((< dy1 -10) (setq dy1 -10))) + (cond ((> dx2 10) (setq dx2 10)) + ((< dx2 -10) (setq dx2 -10))) + (cond ((> dy2 10) (setq dy2 10)) + ((< dy2 -10) (setq dy2 -10))) + (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) + (setq dx1 (- dx1)))) + (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) + (setq dx2 (- dx2)))) + (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) + (setq dy1 (- dy1)))) + (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) + (setq dy2 (- dy2)))) + (setf (qix-dy2 qix) dy2) + (setf (qix-dx2 qix) dx2) + (setf (qix-dy1 qix) dy1) + (setf (qix-dx1 qix) dx1) +` (when (svref next-line 0) + (xlib:draw-line window gc + (svref next-line 0) (svref next-line 1) + (svref next-line 2) (svref next-line 3))) + (setf (svref next-line 0) (+ x1 dx1)) + (setf (svref next-line 1) (+ y1 dy1)) + (setf (svref next-line 2) (+ x2 dx2)) + (setf (svref next-line 3) (+ y2 dy2)) + (xlib:display-force-output *display*) + (sleep *delay*)))))) + + +(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) + 0 0 700 700 + "Hypnotic wandering lines." + (qix *window* lengths duration)) + + + +;;;; Petal. + +;;; Fast sine constants: + +(defconstant d360 #o5500) +(defconstant d270 #o4160) +(defconstant d180 #o2640) +(defconstant d90 #o1320) +(defconstant vecmax 2880) + +(defparameter sin-array + '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 + #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 + #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 + #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 + #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 + #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 + #o23546 #o24106 #o24443 #o24774 #o25323 #o25645 + #o26165 #o26501 #o27011 #o27316 #o27617 #o30115 + #o30406 #o30674 #o31156 #o31434 #o31706 #o32154 + #o32416 #o32654 #o33106 #o33333 #o33554 #o33771 + #o34202 #o34406 #o34605 #o35000 #o35167 #o35351 + #o35526 #o35677 #o36043 #o36203 #o36336 #o36464 + #o36605 #o36721 #o37031 #o37134 #o37231 #o37322 + #o37407 #o37466 #o37540 #o37605 #o37646 #o37701 + #o37730 #o37751 #o37766 #o37775 #o40000)) + +(defmacro psin (val) + `(let* ((val ,val) + neg + frac + sinlo) + (if (>= val d180) + (setq neg t + val (- val d180))) + (if (>= val d90) + (setq val (- d180 val))) + (setq frac (logand val 7)) + (setq val (ash val -3)) + ;; + (setq sinlo (if (>= val 90) + (svref sin-array 90) + (svref sin-array val))) + ;; + (if (< val 90) + (setq sinlo + (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) + -3)))) + ;; + (if neg + (- sinlo) + sinlo))) + +(defmacro pcos (x) + `(let ((tmp (- ,x d270))) + (psin (if (minusp tmp) (+ tmp d360) tmp)))) + + +;;;; Miscellaneous petal hackery. + +(defmacro high-16bits-* (a b) + `(let ((a-h (ash ,a -8)) + (b-h (ash ,b -8))) + (+ (* a-h b-h) + (ash (* a-h (logand ,b 255)) -8) + (ash (* b-h (logand ,a 255)) -8)))) + +(defun complete (style petal) + (let ((repnum 1) + factor cntval needed) + (dotimes (i 3) + (case i + (0 (setq factor 2 cntval 6)) + (1 (setq factor 3 cntval 2)) + (2 (setq factor 5 cntval 1))) + (do () + ((or (minusp cntval) (not (zerop (rem style factor))))) + (setq repnum (* repnum factor)) + (setq cntval (1- cntval)) + (setq style (floor style factor)))) + (setq needed (floor vecmax repnum)) + (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) + + +;;;; Petal Parameters and Petal itself + +(defparameter continuous t) +(defparameter styinc 2) +(defparameter petinc 1) +(defparameter scalfac-fac 8192) + +(defun petal (petal-window &optional (how-many 10) (style 0) (petal 0)) + (let ((width 512) + (height 512)) + (xlib:clear-area petal-window) + (xlib:display-force-output *display*) + (let ((veccnt 0) + (nustyle 722) + (nupetal 3) + (scalfac (1+ (floor scalfac-fac (min width height)))) + (ctrx (floor width 2)) + (ctry (floor height 2)) + (tt 0) + (s 0) + (lststyle 0) + (lstpetal 0) + (petstyle 0) + (vectors 0) + (r 0) + (x1 0) + (y1 0) + (x2 0) + (y2 0) + (i 0) + (gc (xlib:create-gcontext :drawable petal-window + :foreground *black-pixel* + :background *white-pixel* + :line-width 0 :line-style :solid))) + (loop + (when (zerop veccnt) + (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal + style nustyle petstyle (rem (* petal style) d360) + vectors (complete style petal)) + (when continuous + (setq nupetal (+ nupetal petinc) + nustyle (+ nustyle styinc))) + (when (or (/= lststyle style) (/= lstpetal petal)) + (xlib:clear-area petal-window) + (xlib:display-force-output *display*))) + (when (or (/= lststyle style) (/= lstpetal petal)) + (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 + tt (rem (+ tt style) d360) + s (rem (+ s petstyle) d360) + r (pcos s)) + (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) + y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) + (when (/= i 1) + (xlib:draw-line petal-window gc x1 y1 x2 y2) + (xlib:display-force-output *display*))) + (when (> veccnt vectors) + (setq veccnt 0) + (setq how-many (1- how-many)) + (sleep 2) + (when (zerop how-many) (return))))))) + +(defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0)) + 100 100 512 512 + "Flower-like display." + (petal *window* how-many style petal)) + + +;;;; Hanoi. + +;;; Random parameters: + +(defparameter disk-thickness 15 "The thickness of a disk in pixels.") +(defparameter disk-spacing (+ disk-thickness 3) + "The amount of vertical space used by a disk on a needle.") +(defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.") +(defvar *vertical-velocity* 12 "The speed at which disks move up and down.") + +;;; These variables are bound by the main function. + +(defvar *hanoi-window* () "The window that Hanoi is happening on.") +(defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.") +(defvar *transfer-height* () "The height at which disks are transferred.") +(defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.") + +;;; Needle Functions + +(defstruct disk + size) + +(defstruct needle + position + disk-stack) + +;;; Needle-Top-Height returns the height of the top disk on NEEDLE. + +(defun needle-top-height (needle) + (- *hanoi-window-height* + (* disk-spacing (length (the list (needle-disk-stack needle)))))) + +(defvar available-disks + (do ((i 10 (+ i 10)) + (dlist () (cons (make-disk :size i) dlist))) + ((> i 80) dlist))) + +(defvar needle-1 (make-needle :position 184)) +(defvar needle-2 (make-needle :position 382)) +(defvar needle-3 (make-needle :position 584)) + +;;; Graphic interface abstraction: + +;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p" +;;; set to T. Update-Screen forces the display output. +;;; +(defmacro invert-rectangle (x y height width) + `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* + ,x ,y ,width ,height t)) + +(defmacro update-screen () + `(progn + (xlib:display-force-output *display*) + (sleep *delay*))) + + +;;;; Moving disks up and down + +;;; Slide-Up slides the image of a disk up from the coordinates X, +;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to +;;; move. START-Y must be greater than END-Y + +(defun slide-up (start-y end-y x disk-size) + (multiple-value-bind (number-moves pixels-left) + (truncate (- start-y end-y) *vertical-velocity*) + (do ((x (- x disk-size)) + (width (* disk-size 2)) + (old-y start-y (- old-y *vertical-velocity*)) + (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle x (- old-y pixels-left) disk-thickness width) + (invert-rectangle x old-y disk-thickness width) + (update-screen))) + ;; Loop body writes disk at new height & erases at old height. + (invert-rectangle x old-y disk-thickness width) + (invert-rectangle x new-y disk-thickness width) + (update-screen)))) + +;;; Slide-Down slides the image of a disk down from the coordinates X, +;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to +;;; move. START-Y must be less than END-Y. + +(defun slide-down (start-y end-y x disk-size) + (multiple-value-bind (number-moves pixels-left) + (truncate (- end-y start-y) *vertical-velocity*) + (do ((x (- x disk-size)) + (width (* disk-size 2)) + (old-y start-y (+ old-y *vertical-velocity*)) + (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle x (+ old-y pixels-left) disk-thickness width) + (invert-rectangle x old-y disk-thickness width) + (update-screen))) + ;; Loop body writes disk at new height & erases at old height. + (invert-rectangle X old-y disk-thickness width) + (invert-rectangle X new-y disk-thickness width) + (update-screen)))) + + +;;;; Lifting and Droping Disks + +;;; Lift-disk pops the top disk off of needle and raises it up to the +;;; transfer height. The disk is returned. + +(defun lift-disk (needle) + "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it." + (let* ((height (needle-top-height needle)) + (disk (pop (needle-disk-stack needle)))) + (slide-up height + *transfer-height* + (needle-position needle) + (disk-size disk)) + disk)) + +;;; Drop-disk drops a disk positioned over needle at the transfer height +;;; onto needle. The disk is pushed onto needle. + +(defun drop-disk (disk needle) + "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." + (push disk (needle-disk-stack needle)) + (slide-down *transfer-height* + (needle-top-height needle) + (needle-position needle) + (disk-size disk)) + t) + + +;;; Drop-initial-disk is the same as drop-disk except that the disk is +;;; drawn once before dropping. + +(defun drop-initial-disk (disk needle) + "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." + (let* ((size (disk-size disk)) + (lx (- (needle-position needle) size))) + (invert-rectangle lx *transfer-height* disk-thickness (* size 2)) + (push disk (needle-disk-stack needle)) + (slide-down *transfer-height* + (needle-top-height needle) + (needle-position needle) + (disk-size disk)) + t)) + + +;;;; Sliding Disks Right and Left + +;;; Slide-Right slides the image of a disk located at START-X, Y to the +;;; position END-X, Y. DISK-SIZE is the size of the disk. START-X is +;;; less than END-X. + +(defun slide-right (start-x end-x Y disk-size) + (multiple-value-bind (number-moves pixels-left) + (truncate (- end-x start-x) *horizontal-velocity*) + (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*)) + (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle right-x Y disk-thickness pixels-left) + (invert-rectangle left-x Y disk-thickness pixels-left) + (update-screen))) + ;; Loop body adds chunk *horizontal-velocity* pixels wide to right + ;; side of disk, then chops off left side. + (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) + (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) + (update-screen)))) + +;;; Slide-Left is the same as Slide-Right except that START-X is greater +;;; than END-X. + +(defun slide-left (start-x end-x Y disk-size) + (multiple-value-bind (number-moves pixels-left) + (truncate (- start-x end-x) *horizontal-velocity*) + (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*) + (- right-x *horizontal-velocity*)) + (left-x (- (- start-x disk-size) *horizontal-velocity*) + (- left-x *horizontal-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) + (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) + (invert-rectangle left-x Y disk-thickness pixels-left) + (invert-rectangle right-x Y disk-thickness pixels-left) + (update-screen))) + ;; Loop body adds chunk *horizontal-velocity* pixels wide to left + ;; side of disk, then chops off right side. + (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) + (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) + (update-screen)))) + + +;;;; Transferring Disks + +;;; Transfer disk slides a disk at the transfer height from a position +;;; over START-NEEDLE to a position over END-NEEDLE. Modified disk is +;;; returned. + +(defun transfer-disk (disk start-needle end-needle) + "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." + (let ((start (needle-position start-needle)) + (end (needle-position end-needle))) + (if (< start end) + (slide-right start end *transfer-height* (disk-size disk)) + (slide-left start end *transfer-height* (disk-size disk))) + disk)) + + +;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE. + +(defun move-one-disk (start-needle end-needle) + "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." + (drop-disk (transfer-disk (lift-disk start-needle) + start-needle + end-needle) + end-needle) + t) + +;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE +;;; obeying the rules of the towers of hannoi problem. To move the +;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage. + +(defun move-n-disks (n start-needle end-needle temp-needle) + "Moves the top N disks from START-NEEDLE to END-NEEDLE. + Uses TEMP-NEEDLE for temporary storage." + (cond ((= n 1) + (move-one-disk start-needle end-needle)) + (t + (move-n-disks (1- n) start-needle temp-needle end-needle) + (move-one-disk start-needle end-needle) + (move-n-disks (1- n) temp-needle end-needle start-needle))) + t) + + +;;;; Hanoi itself. + +(defun hanoi (window n) + (multiple-value-bind (width height) (full-window-state window) + (declare (ignore width)) + (let* ((*hanoi-window* window) + (*hanoi-window-height* height) + (*transfer-height* (- height (* disk-spacing n))) + (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* + :foreground *white-pixel* + :background *black-pixel* + :fill-style :solid + :function boole-c2))) + (xlib:clear-area *hanoi-window*) + (xlib:display-force-output *display*) + (let ((needle-1 (make-needle :position 184)) + (needle-2 (make-needle :position 382)) + (needle-3 (make-needle :position 584))) + (setf (needle-disk-stack needle-1) ()) + (setf (needle-disk-stack needle-2) ()) + (setf (needle-disk-stack needle-3) ()) + (do ((n n (1- n)) + (available-disks available-disks (cdr available-disks))) + ((zerop n)) + (drop-initial-disk (car available-disks) needle-1)) + (move-n-disks n needle-1 needle-3 needle-2) + t)))) + +;;; Change the names of these when the DEMO loop isn't so stupid. +;;; +(defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4)) + 0 100 768 300 + "Solves the Towers of Hanoi problem before your very eyes." + (let ((*horizontal-velocity* 3) + (*vertical-velocity* 1)) + (hanoi *window* how-many))) +;;; +(defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7)) + 0 100 768 300 + "Solves the Towers of Hanoi problem before your very eyes." + (hanoi *window* how-many)) + + + +;;;; Bounce window. + +;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of +;;; the screen. Optionally, the window can have an initial x velocity, +;;; screen border elasticity, and gravity value. The outer loop is +;;; entered the first time with the window at its initial height, but +;;; each iteration after this, the loop starts with the window at the +;;; bottom of the screen heading upward. The inner loop, except for the +;;; first execution, carries the window up until the negative velocity +;;; becomes positive, carrying the window down to bottom when the +;;; velocity is positive. Due to number lossage, ROUND'ing and +;;; TRUNC'ing when the velocity gets so small will cause the window to +;;; head upward with the same velocity over two iterations which will +;;; cause the window to bounce forever, so we have prev-neg-velocity and +;;; number-problems to check for this. This is not crucial with the x +;;; velocity since the loop terminates as a function of the y velocity. +;;; +(defun bounce-window (window &optional + (x-velocity 0) (elasticity 0.85) (gravity 2)) + (unless (< 0 elasticity 1) + (error "Elasticity must be between 0 and 1.")) + (unless (plusp gravity) + (error "Gravity must be positive.")) + (multiple-value-bind (width height x y mapped) (full-window-state window) + (when (eq mapped :viewable) + (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) + (left-of-window-at-right (- (xlib:drawable-width *root*) width)) + (y-velocity 0) + (prev-neg-velocity most-negative-fixnum) + (number-problems nil)) + (declare (fixnum top-of-window-at-bottom left-of-window-at-right + y-velocity)) + (loop + (when (= prev-neg-velocity 0) (return t)) + (let ((negative-velocity (minusp y-velocity))) + (loop + (let ((next-y (+ y y-velocity)) + (next-y-velocity (+ y-velocity gravity))) + (declare (fixnum next-y next-y-velocity)) + (when (> next-y top-of-window-at-bottom) + (cond + (number-problems + (setf y-velocity (incf prev-neg-velocity))) + (t + (setq y-velocity + (- (truncate (* elasticity y-velocity)))) + (when (= y-velocity prev-neg-velocity) + (incf y-velocity) + (setf number-problems t)) + (setf prev-neg-velocity y-velocity))) + (setf y top-of-window-at-bottom) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*) + (sleep *delay*) + (return)) + (setq y-velocity next-y-velocity) + (setq y next-y)) + (when (and negative-velocity (>= y-velocity 0)) + (setf negative-velocity nil)) + (let ((next-x (+ x x-velocity))) + (declare (fixnum next-x)) + (when (or (> next-x left-of-window-at-right) + (< next-x 0)) + (setq x-velocity (- (truncate (* elasticity x-velocity))))) + (setq x next-x)) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*) + (sleep *delay*)))))))) + +;;; Change the name of this when DEMO is not so stupid. +;;; +(defdemo shove-bounce-demo "Shove-bounce" () + 100 100 300 300 + "Drops the demo window with an inital X velocity which bounces off + screen borders." + (bounce-window *window* 30)) + +(defdemo bounce-demo "Bounce" () + 100 100 300 300 + "Drops the demo window which bounces off screen borders." + (bounce-window *window*)) + + +;;;; Recurrence Demo + +;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu) + +;;; 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. + +;;; The author provides this software "as is" without express or +;;; implied warranty. + +;;; This routine plots the recurrence +;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 +;;; y <- .21 - x +;;; As described in a ?? 1983 issue of the Mathematical Intelligencer + +(defun recurrence (display window &optional (point-count 10000)) + (let ((gc (xlib:create-gcontext :drawable window + :background *white-pixel* + :foreground *black-pixel*))) + (multiple-value-bind (width height) (full-window-state window) + (xlib:clear-area window) + (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) + (xlib:display-force-output display) + (sleep 4)) + (xlib:free-gcontext gc))) + +;;; Draw points. X assumes points are in the range of width x height, +;;; with 0,0 being upper left and 0,H being lower left. +;;; hw and hh are half-width and half-height of screen + +(defun draw-ppict (win gc count x y hw hh) + "Recursively draw pretty picture" + (unless (zerop count) + (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture + (yf (floor (* (+ 0.7 y) hh )))) + (xlib:draw-point win gc xf yf) + (draw-ppict win gc (1- count) + (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) + (- 0.21 x) + hw + hh)))) + +(defdemo recurrence-demo "Recurrence" () + 10 10 700 700 + "Plots a cool recurrence relation." + (recurrence *display* *window*)) + + +;;;; Plaid + +;;; +;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover. +;;; + +(defmacro rect-x (rects n) + `(svref ,rects (ash ,n 2))) +(defmacro rect-y (rects n) + `(svref ,rects (+ (ash ,n 2) 1))) +(defmacro rect-width (rects n) + `(svref ,rects (+ (ash ,n 2) 2))) +(defmacro rect-height (rects n) + `(svref ,rects (+ (ash ,n 2) 3))) + +(defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10)) + (let ((gcontext (xlib:create-gcontext :drawable window + :function boole-c2 + :plane-mask (logxor *white-pixel* + *black-pixel*) + :background *white-pixel* + :foreground *black-pixel* + :fill-style :solid)) + (rectangles (make-array (* 4 num-rectangles) + :element-type 'number + :initial-element 0))) + (multiple-value-bind (width height) (full-window-state window) + (let ((center-x (ash width -1)) + (center-y (ash height -1)) + (x-dir -2) + (y-dir -2) + (x-off 2) + (y-off 2)) + (dotimes (iter (truncate num-iterations num-rectangles)) + (dotimes (i num-rectangles) + (setf (rect-x rectangles i) (- center-x x-off)) + (setf (rect-y rectangles i) (- center-y y-off)) + (setf (rect-width rectangles i) (ash x-off 1)) + (setf (rect-height rectangles i) (ash y-off 1)) + (incf x-off x-dir) + (incf y-off y-dir) + (when (or (<= x-off 0) (>= x-off center-x)) + (decf x-off (ash x-dir 1)) + (setf x-dir (- x-dir))) + (when (or (<= y-off 0) (>= y-off center-y)) + (decf y-off (ash y-dir 1)) + (setf y-dir (- y-dir)))) + (xlib:draw-rectangles window gcontext rectangles t) + (sleep *delay*) + (xlib:display-force-output display)))) + (xlib:free-gcontext gcontext))) + +(defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10)) + 10 10 101 201 + "Plaid, man." + (plaid *display* *window* iterations num-rectangles)) + + +;;;; Bball demo + +;;; +;;; Ported to CLX by Blaine Burks +;;; + +(defvar *ball-size-x* 38) +(defvar *ball-size-y* 34) + +(defmacro xor-ball (pixmap window gcontext x y) + `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* + ,window ,x ,y)) + +(defconstant bball-gravity 1) +(defconstant maximum-x-drift 7) + +(defvar *max-bball-x*) +(defvar *max-bball-y*) + +(defstruct ball + (x (random (- *max-bball-x* *ball-size-x*))) + (y (random (- *max-bball-y* *ball-size-y*))) + (dx (if (zerop (random 2)) (random maximum-x-drift) + (- (random maximum-x-drift)))) + (dy 0)) + +(defun get-bounce-image () + "Returns the pixmap to be bounced around the screen." + (xlib::bitmap-image #*000000000000000000000000000000000000 + #*000000000000000000000000000000000000 + #*000000000000000000001000000010000000 + #*000000000000000000000000000100000000 + #*000000000000000000000100001000000000 + #*000000000000000010000000010000000000 + #*000000000000000000100010000000000000 + #*000000000000000000001000000000000000 + #*000000000001111100000000000101010000 + #*000000000010000011000111000000000000 + #*000000000100000000111000000000000000 + #*000000000100000000000000000100000000 + #*000000000100000000001000100010000000 + #*000000111111100000010000000001000000 + #*000000111111100000100000100000100000 + #*000011111111111000000000000000000000 + #*001111111111111110000000100000000000 + #*001111111111111110000000000000000000 + #*011111111111111111000000000000000000 + #*011111111111111111000000000000000000 + #*111111111111110111100000000000000000 + #*111111111111111111100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111111100000000000000000 + #*111111111111110111100000000000000000 + #*011111111111111111000000000000000000 + #*011111111111011111000000000000000000 + #*001111111111111110000000000000000000 + #*001111111111111110000000000000000000 + #*000011111111111000000000000000000000 + #*000000111111100000000000000000000000 + #*000000000000000000000000000000000000)) + + +(defun bounce-1-ball (pixmap window gcontext ball) + (let ((x (ball-x ball)) + (y (ball-y ball)) + (dx (ball-dx ball)) + (dy (ball-dy ball))) + (xor-ball pixmap window gcontext x y) + (setq x (+ x dx)) + (setq y (+ y dy)) + (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) + (setq x (- x dx) + dx (- dx))) + (if (> y (- *max-bball-y* *ball-size-y*)) + (setq y (- y dy) + dy (- dy))) + (setq dy (+ dy bball-gravity)) + (setf (ball-x ball) x) + (setf (ball-y ball) y) + (setf (ball-dx ball) dx) + (setf (ball-dy ball) dy) + (xor-ball pixmap window gcontext x y))) + +(defun bounce-balls (display window how-many duration) + (xlib:clear-area window) + (xlib:display-force-output display) + (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) + (let* ((balls (do ((i 0 (1+ i)) + (list () (cons (make-ball) list))) + ((= i how-many) list))) + (gcontext (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel* + :function boole-xor + :exposures :off)) + (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 + :drawable window)) + (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap + :foreground *white-pixel* + :background *black-pixel*))) + (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) + :x 0 :y 0 :width 38 :height 34) + (xlib:free-gcontext pixmap-gc) + (dolist (ball balls) + (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) + (xlib:display-force-output display) + (dotimes (i duration) + (dolist (ball balls) + (bounce-1-ball bounce-pixmap window gcontext ball)) + (xlib:display-force-output display) + (sleep *delay*)) + (xlib:free-pixmap bounce-pixmap) + (xlib:free-gcontext gcontext)))) + +#+nil +(defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) + 34 34 700 500 + "Bouncing balls in space." + (bounce-balls *display* *window* how-many duration)) diff --git a/clx/demo/gl-test.lisp b/clx/demo/gl-test.lisp new file mode 100644 index 000000000..453433ded --- /dev/null +++ b/clx/demo/gl-test.lisp @@ -0,0 +1,480 @@ +#+cmu +(ext:file-comment "$Id: gl-test.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") + +(defpackage :gl-test + (:use :common-lisp :xlib) + (:export "TEST" "CLX-TEST")) + +(in-package :gl-test) + + +(defun test (function &key (host "") (display 0) (width 200) (height 200)) + (let* ((display (open-display host :display display)) + (screen (display-default-screen display)) + (root (screen-root screen)) + ctx) + (unwind-protect + (progn + ;;; Inform the server about us. + (glx::client-info display) + (let* ((visual (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)) + (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) + :depth 24 + :colormap colormap + :event-mask '(:structure-notify :exposure))) + (gc (create-gcontext :foreground (screen-white-pixel screen) + :background (screen-black-pixel screen) + :drawable window + :font (open-font display "fixed")))) + (set-wm-properties window + :name "glx-test" + :resource-class "glx-test" + :command (list "glx-test") + :x 10 :y 10 :width width :height height + :min-width width :min-height height + :initial-state :normal) + + (setf ctx (glx:create-context screen (glx:visual-id visual))) + (map-window window) + (glx:make-current window ctx) + + (funcall function display window) + + (unmap-window window) + (free-gcontext gc))) + + (when ctx (glx:destroy-context ctx)) + (close-display display)))) + + +;;; Tests + + +(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) + (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) + (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) + (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) + + (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) + (sleep 0.02)))) + + (sleep 3)) + + +;;; glxgears + +(defconstant +pi+ (coerce pi 'single-float)) +(declaim (type single-float +pi+)) + + +(defun gear (inner-radius outer-radius width teeth tooth-depth) + (let ((r0 inner-radius) + (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) + + ;; Front face. + (gl:begin gl:+quad-strip+) + (dotimes (i (1+ teeth)) + (let ((angle (/ (* i 2.0 +pi+) teeth))) + (declare (type single-float angle)) + (gl:vertex-3f (* r0 (cos angle)) + (* r0 (sin angle)) + (* width 0.5s0)) + (gl:vertex-3f (* r1 (cos angle)) + (* r1 (sin angle)) + (* width 0.5s0)) + (when (< i teeth) + (gl:vertex-3f (* r0 (cos angle)) + (* r0 (sin angle)) + (* width 0.5s0)) + (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (* r1 (sin (+ angle (* 3 da)))) + (* width 0.5s0))))) + (gl:end) + + + ;; Draw front sides of teeth. + (gl:begin gl:+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)) + (* r1 (sin angle)) + (* width 0.5s0)) + (gl:vertex-3f (* r2 (cos (+ angle da))) + (* r2 (sin (+ angle da))) + (* width 0.5s0)) + (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (* r2 (sin (+ angle (* 2 da)))) + (* width 0.5s0)) + (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (* r1 (sin (+ angle (* 3 da)))) + (* width 0.5s0)))) + (gl:end) + + (gl:normal-3f 0.0s0 0.0s0 -1.0s0) + + ;; Draw back face. + (gl:begin gl:+quad-strip+) + (dotimes (i (1+ teeth)) + (let ((angle (/ (* i 2.0s0 +pi+) teeth))) + (declare (type single-float angle)) + (gl:vertex-3f (* r1 (cos angle)) + (* r1 (sin angle)) + (* width -0.5s0)) + (gl:vertex-3f (* r0 (cos angle)) + (* r0 (sin angle)) + (* width -0.5s0)) + (when (< i teeth) + (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (* r1 (sin (+ angle (* 3 da)))) + (* width -0.5s0)) + (gl:vertex-3f (* r0 (cos angle)) + (* r0 (sin angle)) + (* width 0.5s0))))) + (gl:end) + + ;; Draw back sides of teeth. + (gl:begin gl:+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)))) + (* r1 (sin (+ angle (* 3 da)))) + (* width -0.5s0)) + (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (* r2 (sin (+ angle (* 2 da)))) + (* width -0.5s0)) + (gl:vertex-3f (* r2 (cos (+ angle da))) + (* r2 (sin (+ angle da))) + (* width -0.5s0)) + (gl:vertex-3f (* r1 (cos angle)) + (* r1 (sin angle)) + (* width -0.5s0)))) + (gl:end) + + ;; Draw outward faces of teeth. + (gl:begin gl:+quad-strip+) + (dotimes (i teeth) + (let ((angle (/ (* i 2.0s0 +pi+) teeth))) + (declare (type single-float angle)) + (gl:vertex-3f (* r1 (cos angle)) + (* r1 (sin angle)) + (* width 0.5s0)) + (gl:vertex-3f (* r1 (cos angle)) + (* r1 (sin angle)) + (* width -0.5s0)) + (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) + (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) + (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))) + (* r2 (sin (+ angle da))) + (* width 0.5s0)) + (gl: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)))) + (* r2 (sin (+ angle (* 2 da)))) + (* width 0.5s0)) + (gl: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)))) + (* r1 (sin (+ angle (* 3 da)))) + (* width 0.5s0)) + (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (* r1 (sin (+ angle (* 3 da)))) + (* width -0.5s0)) + (gl: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)) + + (gl:end) + + (gl:shade-model gl:+smooth+) + + ;; Draw inside radius cylinder. + (gl:begin gl:+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))) + + +(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+)) + + (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) + + (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) + + (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) + + (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) + + (gl:pop-matrix)) + + +(defun reshape (width height) + (gl: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)) + + (gl:matrix-mode gl:+modelview+) + (gl:load-identity) + (gl: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+) + + ;; 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)) + (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) + (gl: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)) + (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) + (gl: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)) + (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) + (gl:end-list) + + ;;(gl:enable gl:+normalize+) + + (values gear-1 gear-2 gear-3))) + + +(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+) + + (reshape 300 300) + + ;;(gl:light-fv gl:+light0+ gl:+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)) + (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) + (glx:render) + (gl:end-list)) + + + (loop + ;;for angle from 0.0s0 below 361.0s0 by 1.0s0 + with angle single-float = 0.0s0 + with dt = 0.004s0 + repeat 2500 + do (progn + + (incf angle (* 70.0s0 dt)) ; 70 degrees per second + (when (< 3600.0s0 angle) + (decf angle 3600.0s0)) + + (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) + + (gl:push-matrix) + (gl: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)) + (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) + (gl: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)) + (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) + (gl: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)) + (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) + (gl:pop-matrix) + + + (gl:pop-matrix) + + (glx:swap-buffers) + ;;(sleep 0.025) + ))) + + + ;;(sleep 3) + ) + + +(defun gears (display window) + (declare (ignore window)) + (let ((view-rotx 20.0s0) + (view-roty 30.0s0) + (view-rotz 0.0s0) + (angle 0.0s0) + (frames 0) + (dt 0.004s0) ; *** This is dynamically adjusted + ;;(t-rot-0 -1.0d0) + ;;(t-rate-0 -1.d0) + gear-1 gear-2 gear-3) + + (multiple-value-setq (gear-1 gear-2 gear-3) + (init)) + + (loop + (event-case (display :timeout 0.01 :force-output-p t) + (configure-notify (width height) + (reshape width height) + t) + (key-press (code) + (format t "Key pressed: ~S~%" code) + (return-from gears t))) + + (incf angle (* 70.0s0 dt)) ; 70 degrees per second + (when (< 3600.0s0 angle) + (decf angle 3600.0s0)) + + (draw gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) + (glx:swap-buffers) + + (incf frames) + + ;; FPS calculation goes here + ))) diff --git a/clx/demo/hello.lisp b/clx/demo/hello.lisp index a3fbd88d8..b2a273db5 100644 --- a/clx/demo/hello.lisp +++ b/clx/demo/hello.lisp @@ -1,5 +1,8 @@ ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- +#+cmu +(ext:file-comment "$Id: hello.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $") + (in-package :xlib) (defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) diff --git a/clx/demo/mandel.lisp b/clx/demo/mandel.lisp new file mode 100644 index 000000000..a877191f4 --- /dev/null +++ b/clx/demo/mandel.lisp @@ -0,0 +1,561 @@ +#+cmu +(ext:file-comment "$Id: mandel.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $") + +(defpackage "XMANDEL" + (:use "CL") + (:export "NEW-WINDOW" "EVENT-LOOP")) + +(in-package "XMANDEL") + +(defvar *display* (xlib:open-default-display)) +(defvar *screen* (xlib:display-default-screen *display*)) + +(defvar *backing-store* (make-hash-table) "Backing store hashtable, keyed off window id") +(defvar *colmap* nil) +(defvar *helpwin* nil) +(defvar *zoom-table* (make-hash-table)) +(defvar *zoomcolmap* (xlib:create-gcontext + :drawable (xlib:screen-root *screen*) + :foreground (xlib:screen-white-pixel *screen*) + :function boole-xor)) +(defvar *white* (xlib:create-gcontext + :drawable (xlib:screen-root *screen*) + :foreground (xlib:screen-white-pixel *screen*) + )) +(defvar *winmap* (make-hash-table)) +(defvar *textmap* (xlib:create-gcontext + :drawable (xlib:screen-root *screen*) + :foreground (xlib:screen-black-pixel *screen*) + :background (xlib:screen-white-pixel *screen*))) + +;;; OK, this is an ugly hack to make sure we can handle +;;; shift and modstate in a sane way, alas we can't 100% rely +;;; on "current state of keyboard", since we only process events +;;; with a noticeable delay, at eth best of times, so a fast keyboarder +;;; can fool us, we are, however, IIRC, guaranteed that all events are +;;; serialised, so... +(defvar *modstate* nil) +(declaim (list *modstate*)) +(defun make-shift-foo () + (let ((rv 0)) + (if (member :shift *modstate*) + (setf rv 1)) + (if (member :character-set-switch *modstate*) + (setf rv (+ rv 2))) + rv)) + +(defstruct (mandel-square (:conc-name ms-)) + (x 0 :type fixnum) + (y 0 :type fixnum) + (s 512 :type fixnum) + (base-r 0.0d0 :type double-float) + (base-i 0.0d0 :type double-float) + (maxiter 1024 :type fixnum) + (dr 0.0d0 :type double-float) + (di 0.0d0 :type double-float) + win + ) + +(defun make-queue (&rest args) + (apply #'make-instance 'queue args)) + +(defclass queue () + ((head :initform nil :accessor q-head) + (tail :initform nil :accessor q-tail))) +(defclass out-queue () + ((win-queues :accessor win-queues :initarg :xyzzy-1) + (seen-windows :accessor windows :initform nil) + (win-list :accessor win-list :initarg :xyzzy-2) + (last-window :accessor last-window :initform nil)) + (:default-initargs :xyzzy-1 (make-hash-table) + :xyzzy-2 (make-instance 'queue))) + +(defvar *sysqueue* (make-instance 'out-queue)) + +(defgeneric empty-p (queue)) +(defgeneric empty (queue)) +(defgeneric empty-win (queue win)) +(defgeneric enqueue (queue item)) +(defgeneric queue-push (queue item)) +(defgeneric dequeue (queue)) + +(defmethod empty-p ((q null)) + t) +(defmethod empty-p ((q queue)) + (null (q-head q))) +(defmethod empty-p ((q out-queue)) + (let ((coll nil)) + (maphash #'(lambda (key val) + (declare (ignore key)) + (push (empty-p val) coll)) + (win-queues q)) + (every #'identity coll))) + +(defmethod empty ((q null)) + nil) +(defmethod empty ((q queue)) + (setf (q-head q) nil) + (setf (q-tail q) nil)) +(defmethod empty ((q out-queue)) + (maphash #'(lambda (key val) (declare (ignore key)) (empty val)) + (win-queues q))) +(defmethod empty-win ((q out-queue) win) + (let ((temp-queue (gethash win (win-queues q)))) + (empty temp-queue))) + +(defmethod enqueue ((q queue) item) + (cond ((empty-p q) + (setf (q-head q) (cons item nil)) + (setf (q-tail q) (q-head q))) + (t (setf (cdr (q-tail q)) (cons item nil)) + (setf (q-tail q) (cdr (q-tail q)))))) +(defmethod enqueue ((q out-queue) item) + (let ((windows (q-head (win-list q))) + (win (ms-win item))) + (declare (type xlib:window win)) + (unless (member win windows) + (enqueue (win-list q) win)) + (unless (member win (windows q)) + (push win (windows q))) + (let ((temp-queue (gethash win (win-queues q)))) + (if (null temp-queue) + (let ((new (make-queue))) + (setf (gethash win (win-queues q)) new) + (enqueue new item)) + (enqueue temp-queue item))))) + +(defmethod queue-push ((q queue) item) + (cond ((empty-p q) + (setf (q-head q) (cons item nil)) + (setf (q-tail q) (q-head q))) + (t (setf (q-head q) (cons item (q-head q)))))) +(defmethod queue-push ((q out-queue) item) + (let ((windows (q-head (win-list q))) + (win (ms-win item))) + (declare (type xlib:window win)) + (unless (member win windows) + (enqueue (win-list q) win)) + (unless (member win (windows q)) + (push win (windows q))) + (let ((temp-queue (gethash win (win-queues q)))) + (if (null temp-queue) + (let ((new (make-queue))) + (setf (gethash win (win-queues q)) new) + (queue-push new item)) + (queue-push temp-queue item))))) + +(defmethod dequeue ((q out-queue)) + (if (empty-p q) + nil + (let ((windows (win-list q))) + (do* ((next (dequeue windows)) + (finished nil) + (val nil) + (temp-queue (gethash next (win-queues q)) + (gethash next (win-queues q)))) + (finished val) + (cond ((empty-p temp-queue) + (setf next (dequeue windows))) + (t (setf val (dequeue temp-queue)) + (unless (empty-p temp-queue) + (enqueue windows next)) + (setf finished t))))))) +(defmethod dequeue ((q queue)) + (prog1 + (car (q-head q)) + (if (not (empty-p q)) + (setf (q-head q) (cdr (q-head q)))) + (if (null (q-head q)) + (progn + (setf (q-head q) nil) + (setf (q-tail q) nil))))) + +(defun iter (rc ic max) + (declare (double-float rc ic) + (fixnum max)) + (do ((x 0.0d0 (the double-float (+ (- (* x x) (* y y)) rc))) + (y 0.0d0 (the double-float (+ (* 2.0d0 x y) ic))) + (n 1 (the fixnum (1+ n)))) + ((or (>= n max) (>= (+ (* x x) (* y y)) 4.0d0)) + n))) +;;; (a+bi)^2 --> +;;; (a+bi)(a+bi) --> +;;; a^2+2abi+(bi)^2 --> +;;; a^2+2abi-b^2 + +(defclass zoomer () + ((zoom-type :initarg :type :reader zoom-type :type fixnum) + (start-x :initarg :x :reader start-x :type fixnum) + (start-y :initarg :y :reader start-y :type fixnum) + (stop-x :accessor stop-x :initform -1 :type fixnum) + (stop-y :accessor stop-y :initform -1 :type fixnum) + (win :reader win :initarg :win))) + +;;;(defmethod print-object ((object zoomer) stream) +;;; (format stream "<zoomer [type ~a] [~a ~a] -> [~a ~a]>~%" +;;; (zoom-type object) (start-x object) (start-y object) +;;; (stop-x object) (stop-y object))) + +(defun init-colours () + (unless *colmap* + (setf *colmap* (make-array 256 :element-type 'xlib:gcontext :initial-element *zoomcolmap*)) + (setf (aref *colmap* 0) (xlib:create-gcontext + :drawable (xlib:screen-root *screen*) + :foreground (xlib:alloc-color + (xlib:screen-default-colormap *screen*) + (xlib:make-color :red 0 + :green 0 + :blue 0)))) + (loop for index from 1 to 255 + do (setf (aref *colmap* index) + (xlib:create-gcontext + :drawable (xlib:screen-root *screen*) + :foreground (xlib:alloc-color + (xlib:screen-default-colormap *screen*) + (xlib:make-color :red (random 1.0) + :green (random 1.0) + :blue (random 1.0)))))))) +(defmacro modcol (col max) + `(if (= ,col ,max) 0 (1+ (mod ,col 255)))) + +(defun plot (win col x y max) + (declare (fixnum col x y max)) + (let ((col (modcol col max))) + (xlib:draw-point win (aref *colmap* col) x y) + (setf (aref (the (simple-array (integer 0 255) (512 512)) + (gethash win *backing-store*)) x y) col))) + +(defun display-help () + (unless *helpwin* + (setf *helpwin* (xlib:create-window + :parent (xlib:screen-root *screen*) + :x 512 + :y 512 + :width 310 + :height 180 + :event-mask (xlib:make-event-mask :exposure) + :backing-store :always + :background (xlib:screen-white-pixel *screen*))) + (xlib:map-window *helpwin*) + (xlib:display-force-output *display*)) + (unless (xlib:gcontext-font *textmap*) + (let ((fixed (xlib:list-fonts *display* "fixed")) + font) + (if fixed + (setf font (xlib:open-font *display* "fixed")) + (error "Could not open suitable font")) + (setf (xlib:gcontext-font *textmap*) (if (consp fixed) + (car fixed) + fixed)))) + (xlib:draw-rectangle *helpwin* *white* 0 0 (xlib:drawable-width *helpwin*) (xlib:drawable-height *helpwin*) t) + (xlib:draw-glyphs *helpwin* *textmap* 10 13 "Button 1: Zoom same") + (xlib:draw-glyphs *helpwin* *textmap* 10 33 "Button 2: Zoom new") + (xlib:draw-glyphs *helpwin* *textmap* 10 53 "Button 3: Zoom out, same") + (xlib:draw-glyphs *helpwin* *textmap* 10 93 "In general, click to zoom centred on mouse,") + (xlib:draw-glyphs *helpwin* *textmap* 10 113 "drag to zoom a region.") + (xlib:draw-glyphs *helpwin* *textmap* 10 153 "Q: quit") + (xlib:display-force-output *display*)) + +(defun repaint-window (win x-low y-low x-high y-high) + (declare (fixnum x-low y-low x-high y-high)) + (if (eq win *helpwin*) + (display-help) + (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) + (loop for y of-type fixnum from y-low to y-high + do + (loop for x of-type fixnum from x-low to x-high + do (xlib:draw-point win (aref *colmap* (aref bs x y)) x y)))))) + +(defun fill-square (win col x y s max) + (declare (fixnum col x y s max)) + (let ((col (modcol col max))) + (xlib:draw-rectangle win (aref *colmap* col) x y s s t) + (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) + (loop for px of-type fixnum from x to (1- (+ x s)) + do (loop for py of-type fixnum from y to (1- (+ y s)) + do (setf (aref bs px py) col)))))) + +(defun make-square (win x y side bx by dx dy &optional (maxiter 1024)) + (declare (xlib:window win) + (fixnum x y side maxiter) + (double-float bx by dx dy)) + (let ((sq (make-mandel-square + :x x :y y :s side + :base-r bx :base-i by + :dr dx :di dy + :maxiter maxiter + :win win))) + (queue-push *sysqueue* sq))) + +(defun mandel-win (win lx ly hx hy &optional (maxiter 1024)) + (declare (xlib:window win) + (double-float lx ly hx hy) + (fixnum maxiter)) + (let ((dx (coerce (/ (- hx lx) 512.0d0) 'double-float)) + (dy (coerce (/ (- hy ly) 512.0d0) 'double-float))) + (setf (gethash win *winmap*) + (make-mandel-square :x 0 :y 0 :s 512 + :base-r lx :base-i ly + :dr dx :di dy :maxiter maxiter)) + (make-square win 0 256 256 lx ly dx dy maxiter) + (make-square win 256 256 256 lx ly dx dy maxiter) + (make-square win 256 0 256 lx ly dx dy maxiter) + (make-square win 0 0 256 lx ly dx dy maxiter))) + +(defun new-window (lx ly hx hy &optional (maxiter 1024)) + (let ((win (xlib:create-window + :parent (xlib:screen-root *screen*) + :x (+ 100 (random 50)) :y (+ 100 (random 50)) + :width 512 :height 512 + :bit-gravity :center + :event-mask (xlib:make-event-mask + :button-motion :button-press :button-release + :key-press :exposure))) + (ar (make-array '(512 512) + :element-type '(integer 0 255) :initial-element 0)) + ) + (setf (gethash win *backing-store*) ar) + (xlib:map-window win) + (mandel-win win + (coerce lx 'double-float) (coerce ly 'double-float) + (coerce hx 'double-float) (coerce hy 'double-float) maxiter))) + +(defun fill-square-p (ix iy s bx by dx dy max win) + (declare (fixnum ix iy s max) + (double-float bx by dx dy)) + (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max))) + (and + (loop for px from ix below (+ ix s) + for x of-type double-float = (+ bx (* px dx)) + with y = (+ by (* iy dy)) + for i = (iter x y max) + do (plot win i px iy max) + while (= i norm) + finally (return t)) + (loop for py from iy below (+ s iy) + for y of-type double-float = (+ by (* py dy)) + with x = (+ bx (* ix dx)) + for i = (iter x y max) + do (plot win i ix py max) + while (= i norm) + finally (return t)) + (loop for px from (1- (+ s ix)) downto ix + for x of-type double-float = (+ bx (* px dx)) + with y = (+ by (* dy (1- (+ s iy)))) + for i = (iter x y max) + do (plot win i px iy max) + if (/= i norm) return nil + finally (return t)) + (loop for py from (1- (+ s iy)) downto iy + for y of-type double-float = (+ by (* py dy)) + with x = (+ bx (* dx (1- (+ s ix)))) + for i = (iter x y max) + do (plot win i ix py max) + if (/= i norm) return nil + finally (return t))))) + +(defmacro z (base delta int) + `(+ ,base (* ,delta ,int))) +(defun draw-square (square) + (declare (mandel-square square)) + (let ((dx (ms-dr square)) + (dy (ms-di square)) + (base-x (ms-base-r square)) + (base-y (ms-base-i square)) + (maxiter (ms-maxiter square)) + (win (ms-win square)) + (x (ms-x square)) + (y (ms-y square)) + (s (ms-s square)) + ) + (declare (double-float dx dy base-x base-y) + (fixnum x y s maxiter)) + (cond + ((= s 2) + (plot win + (iter (z base-x dx (1+ x)) (z base-y dy (1+ y)) maxiter) + (1+ x) (1+ y) maxiter) + (plot win + (iter (z base-x dx (1+ x)) (z base-y dy y) maxiter) + (1+ x) y maxiter) + (plot win + (iter (z base-x dx x) (z base-y dy (1+ y)) maxiter) + x (1+ y) maxiter) + (plot win + (iter (z base-x dx x) (z base-y dy y) maxiter) + x y maxiter)) + ((fill-square-p x y s base-x base-y dx dy maxiter win) + (fill-square win + (iter (z base-x dx x) (z base-y dy y) maxiter) + x y s maxiter)) + (t (let ((new-s (/ s 2))) + (make-square win + x y new-s + base-x base-y + dx dy + maxiter) + (make-square win + x (+ y new-s) new-s + base-x base-y + dx dy + maxiter) + (make-square win + (+ x new-s) y new-s + base-x base-y + dx dy + maxiter) + (make-square win + (+ x new-s) (+ y new-s) new-s + base-x base-y + dx dy + maxiter)))))) + +(defun create-zoom (win x y button) + (setf (gethash win *zoom-table*) + (make-instance 'zoomer + :x x :y y + :win win + :type (case button + (1 :zoom-same) + (2 :zoom-new) + (3 :zoom-out))))) + +(defun update-zoom (win x y code) + (declare (ignore code) + (fixnum x y)) + (let ((zoomer (gethash win *zoom-table*))) + (when zoomer + (let ((new-side (max 0 + (- (the fixnum x) (the fixnum (start-x zoomer))) + (- (the fixnum y) (the fixnum (start-y zoomer)))))) + (let ((old-side (max 0 + (- (the fixnum (stop-x zoomer)) + (the fixnum (start-x zoomer))) + (- (the fixnum (stop-y zoomer)) + (the fixnum (start-y zoomer)))))) + (xlib:draw-rectangle win *zoomcolmap* + (the fixnum (start-x zoomer)) + (the fixnum (start-y zoomer)) + old-side old-side)) + (setf (stop-x zoomer) (max (the fixnum (start-x zoomer)) + (the fixnum x) + )) + (setf (stop-y zoomer) (max (the fixnum (start-y zoomer)) + (the fixnum y) + )) + (xlib:draw-rectangle win *zoomcolmap* + (the fixnum (start-x zoomer)) + (the fixnum (start-y zoomer)) + new-side new-side) + (xlib:display-force-output *display*))))) + +(defun finish-zoom (win x y code) + (declare (ignore code)) + (let ((zoomer (gethash win *zoom-table*))) + (setf (stop-x zoomer) x) + (setf (stop-y zoomer) y))) + +(defun do-zoom (win) + (let ((zoomer (gethash win *zoom-table*))) + (declare (zoomer zoomer)) + (setf (gethash win *zoom-table*) nil) + (let ((dx (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer)))) + (dy (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))) + (sq (gethash win *winmap*))) + (let ((side (max dx dy)) + (x (the fixnum (start-x zoomer))) + (y (the fixnum (start-y zoomer))) + lx hx ly hy + ) + (if (< side 5) + (setf lx (+ (ms-base-r sq) + (* (- x 128) (ms-dr sq))) + ly (+ (ms-base-i sq) + (* (- y 128) (ms-di sq))) + hx (+ (ms-base-r sq) + (* (+ x 128) (ms-dr sq))) + hy (+ (ms-base-i sq) + (* (+ y 128) (ms-di sq)))) + (setf lx (+ (ms-base-r sq) + (* x (ms-dr sq))) + ly (+ (ms-base-i sq) + (* y (ms-dr sq))) + hx (+ (ms-base-r sq) + (* (+ side x) (ms-dr sq))) + hy (+ (ms-base-i sq) + (* (+ side y) (ms-dr sq))))) +;;; (format t "DEBUG: zoomer is ~a~%~%" zoomer) + (case (zoom-type zoomer) + (:zoom-new (new-window lx ly hx hy (ms-maxiter sq))) + (:zoom-same (empty-win *sysqueue* win) + (mandel-win win lx ly hx hy (ms-maxiter sq))) + (:zoom-out (empty-win *sysqueue* win) + (let ((br (ms-base-r sq)) + (bi (ms-base-i sq)) + (dr (ms-dr sq)) + (di (ms-di sq))) + (mandel-win win + (- br (* 512 dr)) (- bi (* 512 di)) + (+ (* 1024 dr) br) (+ (* 1024 di) bi) + (ms-maxiter sq)))) + + (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer)))))))) + +(defun quit-window (window) + (let ((temp (gethash window (win-queues *sysqueue*)))) + (when temp + (empty temp)))) + +(defun event-loop () + (init-colours) + (do ((quit nil) + (redisplay nil t)) + ((eq quit 'quit)) + (xlib:event-case (*display* :timeout 0) + (:button-press (window x y code) + (create-zoom window x y code) + t) + (:button-release (window x y code) + (finish-zoom window x y code) + (do-zoom window) + t) + (:motion-notify (window x y code) + (update-zoom window x y code) + t) + (:exposure (window x y width height count) + (let ((count count)) + (declare (ignore count) + (fixnum x y width height)) + (when redisplay + (repaint-window window x y (1- (+ x width)) (1- (+ y height))))) + t) + (:key-press (window code) + (case (xlib:keysym->character + *display* + (xlib:keycode->keysym *display* code (make-shift-foo))) + (#\q (quit-window window)) + (#\? (display-help)) + ((:left-shift :right-shift) + (push :shift *modstate*)) + ((:left-control :right-control) + (push :ctrl *modstate*)) + (:character-set-switch + (push :character-set-switch *modstate*))) + t) + (:key-release (window code) + (let ((window window)) + (declare (ignore window)) + (case (xlib:keysym->character + *display* + (xlib:keycode->keysym *display* code 0)) + (:character-set-switch + (setf *modstate* (delete :character-set-switch *modstate*))) + ((:left-control :right-control) + (setf *modstate* (delete :ctrl *modstate*))) + ((:left-shift :right-shift) + (setf *modstate* (delete :shift *modstate*))))) + t)) + (cond ((empty-p *sysqueue*) + nil) + (t (let ((square (dequeue *sysqueue*))) + (draw-square square)))))) diff --git a/clx/demo/menu.lisp b/clx/demo/menu.lisp index 80bc08eee..821635610 100644 --- a/clx/demo/menu.lisp +++ b/clx/demo/menu.lisp @@ -16,6 +16,9 @@ ;;; express or implied warranty. ;;; +#+cmu +(ext:file-comment "$Id") + (in-package :xlib) @@ -273,8 +276,8 @@ ;; Make menu visible (MAP-WINDOW menu-window))) -(defun just-say-lisp (host &optional (font-name "fixed")) - (let* ((display (OPEN-DISPLAY host)) +(defun just-say-lisp (&optional (font-name "fixed")) + (let* ((display (open-default-display)) (screen (first (DISPLAY-ROOTS display))) (fg-color (SCREEN-BLACK-PIXEL screen)) (bg-color (SCREEN-WHITE-PIXEL screen)) @@ -303,7 +306,7 @@ (parent-width 400) (parent-height 400) (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) - :override-redirect :on +;; :override-redirect :on :x 100 :y 100 :width parent-width :height parent-height :background bg-color diff --git a/clx/demo/zoid.lisp b/clx/demo/zoid.lisp index 0a313059f..a3bf4cef2 100644 --- a/clx/demo/zoid.lisp +++ b/clx/demo/zoid.lisp @@ -18,6 +18,9 @@ ;;; express or implied warranty. ;;; +#+cmu +(ext:file-comment "$Id") + (in-package :xlib) (export '(draw-filled-trapezoids diff --git a/clx/dep-allegro.lisp b/clx/dep-allegro.lisp new file mode 100644 index 000000000..ffc26a696 --- /dev/null +++ b/clx/dep-allegro.lisp @@ -0,0 +1,2213 @@ +;;; -*- 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. +;;; + +#+cmu +(ext:file-comment "$Id: dep-allegro.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") + +(in-package :xlib) + +(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) + +#-(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) + + (defconstant +long-0+ 3) + (defconstant +long-1+ 2) + (defconstant +long-2+ 1) + (defconstant +long-3+ 0)) + +;;; 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)) + +#-Genera +(progn + +(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)) + +#+(or excl lcl3.0 clx-overlapping-arrays) +(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 + aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) + +#+(and clx-overlapping-arrays (not Genera)) +(progn + +(defun aref-card16 (a i) + (aref a i)) + +(defun aset-card16 (v a i) + (setf (aref a i) v)) + +(defun aref-int16 (a i) + (card16->int16 (aref a i))) + +(defun aset-int16 (v a i) + (setf (aref a i) (int16->card16 v)) + v) + +(defun aref-card32 (a i) + (aref a i)) + +(defun aset-card32 (v a i) + (setf (aref a i) v)) + +(defun aref-int32 (a i) + (card32->int32 (aref a i))) + +(defun aset-int32 (v a i) + (setf (aref a i) (int32->card32 v)) + v) + +(defun aref-card29 (a i) + (aref a i)) + +(defun aset-card29 (v a i) + (setf (aref a i) v)) + +) + +#+excl +(progn + +(defun aref-card8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card8)) + #.(declare-buffun) + (the card8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :unsigned-byte))) + +(defun aset-card8 (v a i) + (declare (type card8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :unsigned-byte) v)) + +(defun aref-int8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int8)) + #.(declare-buffun) + (the int8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :signed-byte))) + +(defun aset-int8 (v a i) + (declare (type int8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :signed-byte) v)) + +(defun aref-card16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card16)) + #.(declare-buffun) + (the card16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :unsigned-word))) + +(defun aset-card16 (v a i) + (declare (type card16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :unsigned-word) v)) + +(defun aref-int16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int16)) + #.(declare-buffun) + (the int16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :signed-word))) + +(defun aset-int16 (v a i) + (declare (type int16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :signed-word) v)) + +(defun aref-card32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card32)) + #.(declare-buffun) + (the card32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :unsigned-long))) + +(defun aset-card32 (v a i) + (declare (type card32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :unsigned-long) v)) + +(defun aref-int32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int32)) + #.(declare-buffun) + (the int32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :signed-long))) + +(defun aset-int32 (v a i) + (declare (type int32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :signed-long) v)) + +(defun aref-card29 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card29)) + #.(declare-buffun) + (the card29 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :unsigned-long))) + +(defun aset-card29 (v a i) + (declare (type card29 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i + :unsigned-long) 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)))) + + +#+(or cmu sbcl) (progn + +;;; 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 + `(#-lispm + ;; The normal ascii codes for the control characters. + ,@`((#\Return . 13) + (#\Linefeed . 10) + (#\Rubout . 127) + (#\Page . 12) + (#\Tab . 9) + (#\Backspace . 8) + (#\Newline . 10) + (#\Space . 32)) + ;; One the lispm, #\Newline is #\Return, but we'd really like + ;; #\Newline to translate to ascii code 10, so we swap the + ;; Ascii codes for #\Return and #\Linefeed. We also provide + ;; mappings from the counterparts of these control characters + ;; so that the character mapping from the lisp machine + ;; character set to ascii is invertible. + #+lispm + ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) + (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) + (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) + (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) + (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) + (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) + (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) + (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) + ;; 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)) + #-Genera + (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)))) + ) + #+Genera + (progn + (defun char->card8 (char) + (declare lt:(side-effects reader reducible)) + (aref *char-to-card8-translation-table* (char-code char))) + (defun card8->char (card8) + (declare lt:(side-effects reader reducible)) + (aref *card8-to-char-translation-table* card8)) + ) + #-Minima + (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))) + #-Minima + (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. + +#+excl +(defun make-process-lock (name) + (mp:make-process-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 + +;;; HOLDING-LOCK for CMU Common Lisp. +;;; +;;; We are not multi-processing, but we use this macro to try to protect +;;; against re-entering request functions. This can happen if an interrupt +;;; occurs and the handler attempts to use X over the same display connection. +;;; This can happen if the GC hooks are used to notify the user over the same +;;; display connection. We inhibit GC notifications since display of them +;;; could cause recursive entry into CLX. +;;; + +;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. +;;; +#+excl +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) + (unwind-protect + (block .hl-doit. + (when (sys:scheduler-running-p) ; fast test for scheduler running + (setq .hl-lock. ,locator + .hl-curproc. mp::*current-process*) + (when (and .hl-curproc. ; nil if in process-wait fun + (not (eq (mp::process-lock-locker .hl-lock.) + .hl-curproc.))) + ;; Then we need to grab the lock. + ,(if timeout + `(if (not (mp::process-lock .hl-lock. .hl-curproc. + ,whostate ,timeout)) + (return-from .hl-doit. nil)) + `(mp::process-lock .hl-lock. .hl-curproc. + ,@(when whostate `(,whostate)))) + ;; There is an apparent race condition here. However, there is + ;; no actual race condition -- our implementation of mp:process- + ;; lock guarantees that the lock will still be held when it + ;; returns, and no interrupt can happen between that and the + ;; execution of the next form. -- jdi 2/27/91 + (setq .hl-obtained-lock. t))) + ,@body) + (if (and .hl-obtained-lock. + ;; Note -- next form added to allow error handler inside + ;; body to unlock the lock prematurely if it knows that + ;; the current process cannot possibly continue but will + ;; throw out (or is it throw up?). + (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) + (mp::process-unlock .hl-lock. .hl-curproc.))))) + +;;; 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. + +#+excl +(defmacro without-aborts (&body body) + `(without-interrupts ,@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. + +#+excl +(defun process-block (whostate predicate &rest predicate-args) + (if (sys:scheduler-running-p) + (apply #'mp::process-wait whostate predicate predicate-args) + (or (apply predicate predicate-args) + (error "Program tried to wait with no scheduler.")))) + +;;; PROCESS-WAKEUP: Check some other process' wait function. + +(declaim (inline process-wakeup)) + +#+excl +(defun process-wakeup (process) + (let ((curproc mp::*current-process*)) + (when (and curproc process) + (unless (mp::process-p curproc) + (error "~s is not a process" curproc)) + (unless (mp::process-p process) + (error "~s is not a process" process)) + (if (> (mp::process-priority process) (mp::process-priority curproc)) + (mp::process-allow-schedule process))))) + + +;;; CURRENT-PROCESS: Return the current process object for input locking and +;;; for calling PROCESS-WAKEUP. + +(declaim (inline current-process)) + +;;; Default return NIL, which is acceptable even if there is a scheduler. + +#+excl +(defun current-process () + (and (sys:scheduler-running-p) + mp::*current-process*)) + +;;; WITHOUT-INTERRUPTS -- provide for atomic operations. + +;;; CONDITIONAL-STORE: + +;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. +;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. +#-sbcl +(defmacro conditional-store (place old-value new-value) + `(without-interrupts + (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. +;;; +;;;---------------------------------------------------------------------------- + +#-Genera +(defmacro wrap-buf-output ((buffer) &body body) + ;; Error recovery wrapper + `(unless (buffer-dead ,buffer) + ,@body)) + +#-Genera +(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 that since we don't use the CL i/o facilities to do i/o, the display +;; input and output "stream" is really a file descriptor (fixnum). +;; +#+excl +(defun open-x-stream (host display protocol) + (declare (ignore protocol)) ;; assume TCP + (let ((stream (socket:make-socket :remote-host (string host) + :remote-port (+ *x-tcp-port* display) + :format :binary))) + (if (streamp stream) + stream + (error "Cannot connect to server: ~A:~D" host display)))) + + +;;; BUFFER-READ-DEFAULT - read data from the X stream + + +;; +;; Rewritten 10/89 to not use foreign function interface to do I/O. +;; +#+excl +(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 (real 0 *)) timeout)) + #.(declare-buffun) + + (let* ((howmany (- end start)) + (fd (display-input-stream display))) + (declare (type array-index howmany)) + (or (cond ((fd-char-avail-p fd) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (fd-read-bytes fd vector start howmany)))) + + +;;; WARNING: +;;; CLX performance will suffer if your lisp uses read-byte for +;;; receiving all data from the X Window System server. +;;; You are encouraged to write a specialized version of +;;; buffer-read-default that does block transfers. + + +;;; BUFFER-WRITE-DEFAULT - write data to the X stream + +#+excl +(defun buffer-write-default (vector display start end) + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (unless (null stream) + (write-sequence vector stream :start start :end end))) + ) + +;;; WARNING: +;;; CLX performance will be severely degraded if your lisp uses +;;; write-byte to send all data to the X Window System server. +;;; You are STRONGLY encouraged to write a specialized version +;;; of buffer-write-default that does block transfers. + +;;; buffer-force-output-default - force output to the X stream + +#+excl +(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 + +#+excl +(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. + +;;; The default implementation + + +;; +;; This is used so an 'eq' test may be used to find out whether or not we can +;; safely throw this process out of the CLX read loop. +;; +#+excl +(defparameter *read-whostate* "waiting for input from X server") + +;; +;; Note that this function returns nil on error if the scheduler is running, +;; t on error if not. This is ok since buffer-read will detect the error. +;; +#+excl +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout)) + (declare (clx-values timeout)) + (let ((fd (display-input-stream display))) + (when (streamp fd) + (cond ((fd-char-avail-p fd) + nil) + + ;; Otherwise no bytes were available on the socket + ((and timeout (= timeout 0)) + ;; If there aren't enough and timeout == 0, timeout. + :timeout) + + ;; If the scheduler is running let it do timeouts. + ((sys:scheduler-running-p) + (if (not + (mp:wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p + :timeout timeout)) + (return-from buffer-input-wait-default :timeout)) + ) + + ;; Otherwise we have to handle timeouts by hand, and call select() + ;; to block until input is available. Note we don't really handle + ;; the interaction of interrupts and (numberp timeout) here. XX + (t + #+mswindows + (error "scheduler must be running to use CLX on MS Windows") + #-mswindows + (let ((res 0)) + (declare (fixnum res)) + (with-interrupt-checking-on + (loop + (setq res (fd-wait-for-input fd (if (null timeout) 0 + (truncate timeout)))) + (cond ((plusp res) ; success + (return nil)) + ((eq res 0) ; timeout + (return :timeout)) + ((eq res -1) ; error + (return t)) + ;; Otherwise we got an interrupt -- go around again. + ))))))))) + + +;;; 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. + +;;; The default implementation is to just use listen. +#+excl +#+(and excl clx-use-allegro-streams) +(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)))) + +#+(and excl (not clx-use-allegro-streams)) +(defun buffer-listen-default (display) + (declare (type display display)) + (let ((fd (display-input-stream display))) + (declare (type fixnum fd)) + (if (= fd -1) + t + (fd-char-avail-p fd)))) + + +;;;---------------------------------------------------------------------------- +;;; 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. +;; +#-lispm +(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) + #+clx-ansi-common-lisp (dynamic-extent ,var)) + ,@body)) + +#-lispm +(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) + #+clx-ansi-common-lisp (dynamic-extent ,var)) + ,@body)) + +(declaim (inline buffer-replace)) + +#+excl +(defun buffer-replace (target-sequence source-sequence target-start + target-end &optional (source-start 0)) + (declare (type buffer-bytes target-sequence source-sequence) + (type array-index target-start target-end source-start) + (optimize (speed 3) (safety 0))) + + (let ((source-end (length source-sequence))) + (declare (type array-index source-end)) + + (excl:if* (and (eq target-sequence source-sequence) + (> target-start source-start)) + then (let ((nelts (min (- target-end target-start) + (- source-end source-start)))) + (do ((target-index (+ target-start nelts -1) (1- target-index)) + (source-index (+ source-start nelts -1) (1- source-index))) + ((= target-index (1- target-start)) target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) + else (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index target-end) (= source-index source-end)) + target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))))) + +#-lispm +(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?+ + #+(or Genera Minima CMU sbcl) nil + #-(or Genera Minima CMU sbcl) t) + +;; 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) + #+(or cmu sbcl) + `(typep ,object ,type) + #-(or cmu sbcl) + (if (not (constantp type)) + `(typep ,object ,type) + (progn + (setq type (eval type)) + #+(or Genera explorer Minima) + (if +type-check?+ + `(locally (declare (optimize safety)) (typep ,object ',type)) + `(typep ,object ',type)) + #-(or Genera explorer Minima) + (let ((predicate (assoc type + '((drawable drawable-p) (window window-p) + (pixmap pixmap-p) (cursor cursor-p) + (font font-p) (gcontext gcontext-p) + (colormap colormap-p) (null null) + (integer integerp))))) + (cond (predicate + `(,(second predicate) ,object)) + ((eq type 'generalized-boolean) + 't) ; Everything is a generalized-boolean. + (+type-check?+ + `(locally (declare (optimize safety)) (typep ,object ',type))) + (t + `(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))) + +#+(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)) + +;;; X-ERROR for CMU Common Lisp +;;; +;;; We detect a couple condition types for which we disable event handling in +;;; our system. This prevents going into the debugger or returning to a +;;; command prompt with CLX repeatedly seeing the same condition. This occurs +;;; because CMU Common Lisp provides for all events (that is, X, input on file +;;; descriptors, Mach messages, etc.) to come through one routine anyone can +;;; use to wait for input. +;;; +#+(and CMU (not mp)) +(defun x-error (condition &rest keyargs) + (let ((condx (apply #'make-condition condition keyargs))) + (when (eq condition 'closed-display) + (let ((disp (closed-display-display condx))) + (warn "Disabled event handling on ~S." disp) + (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 +;;----------------------------------------------------------------------------- + +#+(and allegro-version>= (version>= 5 0)) +(eval-when (compile eval load) + #+(version>= 6 0) + (progn + (require :sock) + #-(version>= 7 0) + (require :gray-compat)) + #-(version>= 6 0) + (require :sock)) + +#+(and allegro-version>= (version>= 5 0)) +(defun host-address (host &optional (family :internet)) + (ecase family + (:internet + (cons :internet + (multiple-value-list + (socket::ipaddr-to-dotted (socket::lookup-hostname host) + :values t)))))) + +#+(and allegro-version>= (not (version>= 5 0))) +(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 (clx-values list)) + (labels ((no-host-error () + (error "Unknown host ~S" host)) + (no-address-error () + (error "Host ~S has no ~S address" host family))) + (let ((hostent 0)) + (unwind-protect + (progn + (setf hostent (ipc::gethostbyname (string host))) + (when (zerop hostent) + (no-host-error)) + (ecase family + ((:internet nil 0) + (unless (= (ipc::hostent-addrtype hostent) 2) + (no-address-error)) + (assert (= (ipc::hostent-length hostent) 4)) + (let ((addr (ipc::hostent-addr hostent))) + (when (or (member comp::.target. + '(:hp :sgi4d :sony :dec3100) + :test #'eq) + (probe-file "/lib/ld.so")) + ;; BSD 4.3 based systems require an extra indirection + (setq addr (si:memref-int addr 0 0 :unsigned-long))) + (list :internet + (si:memref-int addr 0 0 :unsigned-byte) + (si:memref-int addr 1 0 :unsigned-byte) + (si:memref-int addr 2 0 :unsigned-byte) + (si:memref-int addr 3 0 :unsigned-byte)))))) + (ff:free-cstruct hostent))))) + + +;;----------------------------------------------------------------------------- +;; 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 () + #+(or lispm Minima) t + #-(or lispm Minima) nil) + +#-(or Genera Minima) +(defun clx-macroexpand (form env) + (macroexpand form env)) + + +;;----------------------------------------------------------------------------- +;; Resource stuff +;;----------------------------------------------------------------------------- + + +;;; Utilities + +(defun getenv (name) + #+excl (sys:getenv name) + ) + +(defun get-host-name () + "Return the same hostname as gethostname(3) would" + ;; resources-pathname was using short-site-name for this purpose + #+excl (short-site-name) + ) + +(defun homedir-file-pathname (name) + (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) + (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 +#+unix +(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) + + + +;;----------------------------------------------------------------------------- +;; 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 +;;----------------------------------------------------------------------------- + +;;; 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. + +#-(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) + (type t object) + (clx-values t) + (special left-meta-keysym right-meta-keysym + left-super-keysym right-super-keysym + left-hyper-keysym right-hyper-keysym)) + (when (characterp object) + (when (logbitp (position :control +state-mask-vector+) state) + (setf (char-bit object :control) 1)) + (when (or (state-keysymp display state left-meta-keysym) + (state-keysymp display state right-meta-keysym)) + (setf (char-bit object :meta) 1)) + (when (or (state-keysymp display state left-super-keysym) + (state-keysymp display state right-super-keysym)) + (setf (char-bit object :super) 1)) + (when (or (state-keysymp display state left-hyper-keysym) + (state-keysymp display state right-hyper-keysym)) + (setf (char-bit object :hyper) 1))) + 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 () + #-(or Genera Minima) '(unsigned-byte 32) + #+(or Genera Minima) 'fixnum) + +(deftype pixarray-1 () + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-1-element-type (* *))) + +(deftype pixarray-4 () + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-4-element-type (* *))) + +(deftype pixarray-8 () + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-8-element-type (* *))) + +(deftype pixarray-16 () + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-16-element-type (* *))) + +(deftype pixarray-24 () + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-24-element-type (* *))) + +(deftype pixarray-32 () + '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) 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 + +#+excl +(defmacro with-underlying-simple-vector + ((variable element-type pixarray) &body body) + `(let ((,variable (cdr (excl::ah_data ,pixarray)))) + (declare (type (simple-array ,element-type (*)) ,variable)) + ,@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) + (#-Genera ldb #+Genera sys:%logldb + (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 + `(#-Genera dpb #+Genera sys:%logdpb + (the card8 ,byte) + (byte 8 ,(incf count 8)) + (the (unsigned-byte ,count) ,it)))) + #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) + #+Genera 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 + (#-Genera ldb #+Genera sys:%logldb + (byte 8 ,position) + #-Genera (the (unsigned-byte ,integer-size) ,integer) + #+Genera ,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 `(#-Genera dpb #+Genera sys:%logdpb + (the (unsigned-byte ,size) ,byte) + (byte ,size ,(incf count size)) + (the (unsigned-byte ,count) ,it)))) + `(the card8 ,it))) + +#+(or Genera lcl3.0 excl) +(defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) + +#+(or Genera lcl3.0 excl) +(defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) + +;;; 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 + +#+(or Genera lcl3.0 excl) +(defconstant + *image-bit-ordering-table* + '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) + ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) + ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) + ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) + ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) + ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) + ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) + ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) + ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) + ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) + ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) + ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) + +#+(or Genera lcl3.0 excl) +(defun compute-image-byte-and-bit-ordering () + (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) + ;; First compute the ordering + (let ((ordering nil) + (a (make-array '(1 32) :element-type 'bit :initial-element 0))) + (dotimes (i 4) + (push (flet ((bitpos (a i n) + (declare (optimize (speed 3) (safety 0) (space 0))) + (declare (type (simple-array bit (* *)) a) + (type fixnum i n)) + (with-underlying-simple-vector (v (unsigned-byte 8) a) + (prog2 + (setf (aref v i) n) + (dotimes (i 32) + (unless (zerop (aref a 0 i)) + (return i))) + (setf (aref v i) 0))))) + (list (bitpos a i #b10000000) + (bitpos a i #b00000001))) + ordering)) + (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) + ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p + (let ((byte-and-bit-ordering + (second (assoc ordering *image-bit-ordering-table* + :test #'equal)))) + (unless byte-and-bit-ordering + (error "Couldn't determine image byte and bit ordering~@ + measured image ordering = ~A" + ordering)) + (values-list byte-and-bit-ordering)))) + +#+(or Genera lcl3.0 excl) +(multiple-value-setq + (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (compute-image-byte-and-bit-ordering)) + +;;; 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. + +;;; FIXME: though we have some #+sbcl -conditionalized routines in +;;; here, they would appear not to work, and so are commented out in +;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate +;;; whether the unoptimized routines are often used, and also whether +;;; speeding them up while maintaining correctness is possible. + +;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y 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-1-element-type array) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (the array-index (mod (the fixnum (- x)) 8))) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (the fixnum (- (the fixnum (- width left-bits)) + right-bits))) + (middle-bytes (index-floor middle-bits 8))) + ((index>= y height)) + (declare (type array-index start y + left-bits right-bits middle-bytes) + (fixnum middle-bits)) + (cond ((< middle-bits 0) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-bits) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (array-row-major-index + array y (index+ left-bits middle-bits)))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref vector (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + ))))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type card16 x y 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-4-element-type array) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) + 2))) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) + (declare (type array-index start y + left-nibbles right-nibbles middle-nibbles middle-bytes)) + (unless (index-zerop left-nibbles) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-nibbles) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 4 4 byte)))) + ))) + t) + +#+(or Genera lcl3.0 excl CMU sbcl) +(defun fast-read-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 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* ((start (index+ index + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)))))))) + t) + +;;; COPY-BIT-RECT -- Internal +;;; +;;; This is the classic BITBLT operation, copying a rectangular subarray +;;; from one array to another (but source and destination must not overlap.) +;;; Widths are specified in bits. Neither array can have a non-zero +;;; displacement. We allow extra random bit-offset to be thrown into the X. +;;; +#+(or Genera lcl3.0 excl) +(defun fast-read-pixarray-with-swap + (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)) + (unless (index= bits-per-pixel 24) + (let ((pixarray-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (x-bits (index* x bits-per-pixel))) + (declare (type array-index pixarray-padded-bits-per-line x-bits)) + (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod x-bits 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod x-bits +image-unit+)))) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p + +image-unit+ *computed-image-byte-lsb-first-p* + *computed-image-bit-lsb-first-p*) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (with-underlying-simple-vector (dst card8 pixarray) + (funcall + (symbol-function image-swap-function) bbuf dst + (index+ boffset + (index* y padded-bytes-per-line) + (index-floor x-bits 8)) + 0 (index-ceiling (index* width bits-per-pixel) 8) + padded-bytes-per-line + (index-floor pixarray-padded-bits-per-line 8) + height image-swap-lsb-first-p))) + 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 + #+(or Genera lcl3.0 excl) + (fast-read-pixarray-with-swap + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + (let ((function + (or #+lispm + (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bytes-per-line 4)) + (zerop (index-mod + (* #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1) + bits-per-pixel) + 32)) + #'fast-read-pixarray-using-bitblt) + #+(or CMU) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-read-pixarray-using-bitblt) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 1) + #'fast-read-pixarray-1) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 4) + #'fast-read-pixarray-4) + #+(or Genera lcl3.0 excl CMU) + (and (index= bits-per-pixel 24) + #'fast-read-pixarray-24)))) + (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 lcl3.0 excl) +(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y 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-1-element-type array) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-bits middle-bits + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (array-row-major-index + array y (index+ start-x middle-bits)))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (if (index> right-bits 1) + (aref vector (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref vector (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref vector (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref vector (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref vector (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref vector (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)) + (aref vector (index+ x 2)) + (aref vector (index+ x 3)) + (aref vector (index+ x 4)) + (aref vector (index+ x 5)) + (aref vector (index+ x 6)) + (aref vector (index+ x 7)))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 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-4-element-type array) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-nibbles middle-nibbles + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)))))))) + t) + +#+(or Genera lcl3.0 excl 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 Genera lcl3.0 excl) +(defun fast-write-pixarray-with-swap + (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)) + (unless (index= bits-per-pixel 24) + (let ((pixarray-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (pixarray-start-bit-offset + (index* (array-row-major-index pixarray y x) + bits-per-pixel))) + (declare (type array-index pixarray-padded-bits-per-line + pixarray-start-bit-offset)) + (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod pixarray-start-bit-offset 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + +image-unit+ *computed-image-byte-lsb-first-p* + *computed-image-bit-lsb-first-p* + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (with-underlying-simple-vector (src card8 pixarray) + (funcall + (symbol-function image-swap-function) + src bbuf (index-floor pixarray-start-bit-offset 8) boffset + (index-ceiling (index* width bits-per-pixel) 8) + (index-floor pixarray-padded-bits-per-line 8) + padded-bytes-per-line height image-swap-lsb-first-p)) + 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 + #+(or Genera lcl3.0 excl) + (fast-write-pixarray-with-swap + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + (let ((function + (or #+lispm + (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bytes-per-line 4)) + (zerop (index-mod + (* #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1) + bits-per-pixel) + 32)) + #'fast-write-pixarray-using-bitblt) + #+(or CMU) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-write-pixarray-using-bitblt) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 1) + #'fast-write-pixarray-1) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 4) + #'fast-write-pixarray-4) + #+(or Genera lcl3.0 excl CMU) + (and (index= bits-per-pixel 24) + #'fast-write-pixarray-24)))) + (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 lispm CMU) + (let* ((pixarray-padded-pixels-per-line + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel)) + (copy-padded-pixels-per-line + #+Genera (sys:array-row-span copy) + #-Genera (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)) + + #+(or lcl3.0 excl) + (unless (index= bits-per-pixel 24) + (let ((pixarray-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (copy-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index copy 1 0) + (array-row-major-index copy 0 0)) + bits-per-pixel))) + (pixarray-start-bit-offset + (index* (array-row-major-index pixarray y x) + bits-per-pixel))) + (declare (type array-index pixarray-padded-bits-per-line + copy-padded-bits-per-line pixarray-start-bit-offset)) + (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod copy-padded-bits-per-line 8)) + (index-zerop (index-mod pixarray-start-bit-offset 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) + (with-underlying-simple-vector (src card8 pixarray) + (with-underlying-simple-vector (dst card8 copy) + (image-noswap + src dst + (index-floor pixarray-start-bit-offset 8) 0 + (index-ceiling (index* width bits-per-pixel) 8) + (index-floor pixarray-padded-bits-per-line 8) + (index-floor copy-padded-bits-per-line 8) + height nil))) + t))) + #+(or lcl3.0 excl) + (macrolet + ((copy (type element-type) + `(let ((pixarray pixarray) + (copy copy)) + (declare (type ,type pixarray copy)) + #.(declare-buffun) + (with-underlying-simple-vector (src ,element-type pixarray) + (with-underlying-simple-vector (dst ,element-type copy) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-idx (array-row-major-index copy dst-y 0) + (index1+ dst-idx)) + (dst-end (index+ dst-idx width)) + (src-idx (array-row-major-index pixarray src-y x) + (index1+ src-idx))) + ((index>= dst-idx dst-end)) + (declare (type array-index dst-idx src-idx dst-end)) + (setf (aref dst dst-idx) + (the ,element-type (aref src src-idx)))))))))) + (ecase bits-per-pixel + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))) + t))) diff --git a/clx/dep-openmcl.lisp b/clx/dep-openmcl.lisp new file mode 100644 index 000000000..c9b994a0c --- /dev/null +++ b/clx/dep-openmcl.lisp @@ -0,0 +1,1127 @@ +;;; -*- 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. +;;; + +#+cmu +(ext:file-comment "$Id: dep-openmcl.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") + +(in-package :xlib) + +(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) + +(progn + (defconstant +word-0+ 1) + (defconstant +word-1+ 0) + + (defconstant +long-0+ 3) + (defconstant +long-1+ 2) + (defconstant +long-2+ 1) + (defconstant +long-3+ 0)) + +;;; 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)) + +(progn + +(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)) + +(progn + +(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))) + +) + +(progn + +(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)))) + + +;;----------------------------------------------------------------------------- +;; 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)))) + ) + #+Genera + (progn + (defun char->card8 (char) + (declare lt:(side-effects reader reducible)) + (aref *char-to-card8-translation-table* (char-code char))) + (defun card8->char (card8) + (declare lt:(side-effects reader reducible)) + (aref *card8-to-char-translation-table* 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) + (ccl:make-lock 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. + +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore timeout display)) + `(ccl:with-lock-grabbed (,locator ,whostate) + ,@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) + `(ccl:without-interrupts ,@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-extern predicate-args)) + (apply #'ccl: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)) + nil) + +;;; CURRENT-PROCESS: Return the current process object for input locking and +;;; for calling PROCESS-WAKEUP. + +(declaim (inline current-process)) + +;;; Default return NIL, which is acceptable even if there is a scheduler. + +(defun current-process () + ccl::*current-process*) + +;;; WITHOUT-INTERRUPTS -- provide for atomic operations. + +(defmacro without-interrupts (&body body) + `(ccl:without-interrupts ,@body)) + +;;; CONDITIONAL-STORE: + +;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. +;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. + +(defmacro conditional-store (place old-value new-value) + `(ccl::conditional-store ,place ,old-value ,new-value)) + +;;;---------------------------------------------------------------------------- +;;; 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 + +(defparameter ccl::*x-server-unix-socket-format-string* "/tmp/.X11-unix/X~d") + +(defun open-x-stream (host display protocol) + (declare (ignore protocol)) + (if (or (string= host "") (string= host "unix")) + (ccl::make-socket :connect :active + :address-family :file + :remote-filename (format nil ccl::*x-server-unix-socket-format-string* display)) + (ccl::make-socket :connect :active + :remote-host host + :remote-port (+ 6000 display)))) + +;;; 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 (real 0 *)) timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (or (cond ((null stream)) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (progn + (ccl:stream-read-ivector stream vector start (- end start)) + 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) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (ccl:stream-write-ivector stream vector start (- end start))) + 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 number) timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + (t + (let* ((fd (ccl::stream-device stream :input)) + (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*))))) + (if (ccl::process-input-wait fd ticks) + 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. + +;;; The default implementation is to just use listen. + +(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) + #+clx-ansi-common-lisp (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) + (if (not (constantp type)) + `(typep ,object ,type) + (progn + (setq type (eval type)) + (let ((predicate (assoc type + '((drawable drawable-p) (window window-p) + (pixmap pixmap-p) (cursor cursor-p) + (font font-p) (gcontext gcontext-p) + (colormap colormap-p) (null null) + (integer integerp))))) + (cond (predicate + `(,(second predicate) ,object)) + ((eq type 'generalized-boolean) + 't) ; Everything is a generalized-boolean. + (+type-check?+ + `(locally (declare (optimize safety)) (typep ,object ',type))) + (t + `(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 (clx-values list)) + (ecase family + ((:internet nil 0) + (let* ((addr (ccl::host-as-inet-host host))) + (cons :internet (list + (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) + (ccl::getenv name)) + +(defun get-host-name () + "Return the same hostname as gethostname(3) would" + (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 + +(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))) + + +;;; 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 + +(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 (ignore bbuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel unit + byte-lsb-first-p bit-lsb-first-p)) + nil) + +;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s + +(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 (ignore bbuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel unit + byte-lsb-first-p bit-lsp-first-p)) + nil) + +;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another + +(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) + (declare (ignore pixarray copy x y width height bits-per-pixel)) + nil) diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp index 3d9db38e7..dc95556ce 100644 --- a/clx/depdefs.lisp +++ b/clx/depdefs.lisp @@ -17,9 +17,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/depdefs.lisp,v 1.6 1999/03/16 23:37:38 pw Exp $") +(ext:file-comment "$Id") (in-package :xlib) @@ -27,19 +27,58 @@ ;;; Declarations ;;;------------------------------------------------------------------------- +;;; fix a bug in kcl's RATIONAL... +;;; redefine both the function and the type. + +#+(or kcl ibcl) +(progn + (defun rational (x) + (if (rationalp x) + x + (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 (declaim (declaration clx-values)) +#+Genera +(setf (get 'clx-values 'si:declaration-alias) 'scl:values) + ;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides ;;; the documentation that might get generated by the real arglist of the ;;; function. +#-(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. +#-genera (declaim (declaration indentation)) ;;;------------------------------------------------------------------------- @@ -56,6 +95,14 @@ ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for ;;; Meta-. +#+lispm +(defmacro within-definition ((name type) &body body) + `(zl:local-declare + ((sys:function-parent ,name ,type)) + (sys:record-source-file-name ',name ',type) + ,@body)) + +#-lispm (defmacro within-definition ((name type) &body body) (declare (ignore name type)) `(progn ,@body)) @@ -73,35 +120,94 @@ ;;; useful for much beyond xatoms and windows (since almost nothing else ;;; ever comes back in events). ;;;-------------------------------------------------------------------------- -(defconstant *clx-cached-types* - '( drawable - window - pixmap -; gcontext - cursor - colormap - font)) +(defconstant +clx-cached-types+ + '(drawable + window + pixmap + ;; gcontext + cursor + colormap + font)) (defmacro resource-id-map-test () - '#'eql) + #+excl '#'equal + #-excl '#'eql) ; (eq fixnum fixnum) is not guaranteed. (defmacro atom-cache-map-test () - '#'eq) + #+excl '#'equal + #-excl '#'eq) (defmacro keysym->character-map-test () - '#'eql) + #+excl '#'equal + #-excl '#'eql) ;;; 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) +(eval-when (eval compile load) + (pushnew :clx-little-endian *features*)) + +#+lcl3.0 +(eval-when (compile eval load) + (ecase lucid::machine-endian + (:big nil) + (:little (pushnew :clx-little-endian *features*)))) + #+cmu (eval-when (compile eval load) (ecase #.(c:backend-byte-order c:*backend*) (:big-endian) (:little-endian (pushnew :clx-little-endian *features*)))) +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; FIXME: Ideally, we shouldn't end up with the internal + ;; :CLX-LITTLE-ENDIAN decorating user-visible *FEATURES* lists. + ;; This probably wants to be split up into :compile-toplevel + ;; :execute and :load-toplevel clauses, so that loading the compiled + ;; code doesn't push the feature. + (ecase sb-c:*backend-byte-order* + (:big-endian) + (:little-endian (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 +;;; leave the overlapping-arrays feature turned off. Lisp machines +;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays +;;; with different element types to overlap. CLX will take advantage of +;;; this to do fast array packing/unpacking when the overlapping-arrays +;;; feature is enabled. + +#+clisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless system::*big-endian* (pushnew :clx-little-endian *features*))) + +#+(and clx-little-endian lispm) +(eval-when (eval compile load) + (pushnew :clx-overlapping-arrays *features*)) + +#+(and clx-overlapping-arrays genera) +(progn +(deftype overlap16 () '(unsigned-byte 16)) +(deftype overlap32 () '(signed-byte 32)) +) + +#+(and clx-overlapping-arrays (or explorer lambda cadr)) +(progn +(deftype overlap16 () '(unsigned-byte 16)) +(deftype overlap32 () '(unsigned-byte 32)) +) + (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*))) +#+clx-overlapping-arrays +(progn +(deftype buffer-words () `(vector overlap16)) +(deftype buffer-longs () `(vector overlap32)) +) + ;;; This defines a type which is a subtype of the integers. ;;; This type is used to describe all variables that can be array indices. ;;; It is here because it is used below. @@ -111,7 +217,7 @@ ;; this is the best place to define these? - +#-Genera (progn (defun make-index-typed (form) @@ -180,14 +286,91 @@ ) +#+Genera +(progn + +(defmacro index+ (&rest numbers) `(+ ,@numbers)) +(defmacro index-logand (&rest numbers) `(logand ,@numbers)) +(defmacro index-logior (&rest numbers) `(logior ,@numbers)) +(defmacro index- (&rest numbers) `(- ,@numbers)) +(defmacro index* (&rest numbers) `(* ,@numbers)) + +(defmacro index1+ (number) `(1+ ,number)) +(defmacro index1- (number) `(1- ,number)) + +(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta))) +(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta))) + +(defmacro index-min (&rest numbers) `(min ,@numbers)) +(defmacro index-max (&rest numbers) `(max ,@numbers)) + +(defun positive-power-of-two-p (x) + (when (symbolp x) + (multiple-value-bind (constantp value) (lt:named-constant-p x) + (when constantp (setq x value)))) + (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x))))) + +(defmacro index-floor (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,divisor)) + (t `(floor ,number ,divisor)))) + +(defmacro index-ceiling (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) + `(si:%fixnum-ceiling ,number ,divisor)) + (t `(ceiling ,number ,divisor)))) + +(defmacro index-truncate (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,divisor)) + (t `(truncate ,number ,divisor)))) + +(defmacro index-mod (number divisor) + (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod)) + `(si:%fixnum-mod ,number ,divisor)) + (t `(mod ,number ,divisor)))) + +(defmacro index-ash (number count) + (cond ((eql count 0) number) + ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,(expt 2 (- count)))) + ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) + `(si:%fixnum-multiply ,number ,(expt 2 count))) + (t `(ash ,number ,count)))) + +(defmacro index-plusp (number) `(plusp ,number)) +(defmacro index-zerop (number) `(zerop ,number)) +(defmacro index-evenp (number) `(evenp ,number)) +(defmacro index-oddp (number) `(oddp ,number)) + +(defmacro index> (&rest numbers) `(> ,@numbers)) +(defmacro index= (&rest numbers) `(= ,@numbers)) +(defmacro index< (&rest numbers) `(< ,@numbers)) +(defmacro index>= (&rest numbers) `(>= ,@numbers)) +(defmacro index<= (&rest numbers) `(<= ,@numbers)) + +) ;;;; Stuff for BUFFER definition -(defconstant *replysize* 32.) +(defconstant +replysize+ 32.) ;; used in defstruct initializations to avoid compiler warnings (defvar *empty-bytes* (make-sequence 'buffer-bytes 0)) (declaim (type buffer-bytes *empty-bytes*)) +#+clx-overlapping-arrays +(progn +(defvar *empty-words* (make-sequence 'buffer-words 0)) +(declaim (type buffer-words *empty-words*)) +) +#+clx-overlapping-arrays +(progn +(defvar *empty-longs* (make-sequence 'buffer-longs 0)) +(declaim (type buffer-longs *empty-longs*)) +) (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) (:copier nil) (:predicate nil)) @@ -195,12 +378,17 @@ ;; Byte (8 bit) input buffer (ibuf8 *empty-bytes* :type buffer-bytes) ;; Word (16bit) input buffer - (next nil :type (or null reply-buffer)) + #+clx-overlapping-arrays + (ibuf16 *empty-words* :type buffer-words) + ;; Long (32bit) input buffer + #+clx-overlapping-arrays + (ibuf32 *empty-longs* :type buffer-longs) + (next nil #-explorer :type #-explorer (or null reply-buffer)) (data-size 0 :type array-index) ) -(defconstant *buffer-text16-size* 256) -(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*))) +(defconstant +buffer-text16-size+ 256) +(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+))) ;; These are here because. @@ -216,22 +404,32 @@ ;;; Pseudo-class mechanism. -(eval-when (eval compile load) -(defvar *def-clx-class-use-defclass* - #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) - #+(and cmu (not pcl)) nil - #-(or cmu) nil - "Controls whether DEF-CLX-CLASS uses DEFCLASS. - If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names - for which DEFCLASS should be used. - If it is not a list, then DEFCLASS is always used. - If it is NIL, then DEFCLASS is never used, since NIL is the empty list.") -) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; FIXME: maybe we should reevaluate this? + (defvar *def-clx-class-use-defclass* + #+(or Genera allegro) t + #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) + #+(and cmu (not pcl)) nil + #-(or Genera cmu allegro) nil + "Controls whether DEF-CLX-CLASS uses DEFCLASS. + +If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of +type names for which DEFCLASS should be used. If it is not a list, +then DEFCLASS is always used. If it is NIL, then DEFCLASS is never +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 (find-package :common-lisp)) + (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)))) (constructor t) (constructor-args t) (include nil) @@ -278,7 +476,7 @@ (setf (elt slot-types i) (getf slot :type t)))) `(progn - (eval-when (compile load eval) + (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'def-clx-class) ',slots)) ;; From here down are the system-specific expansions: @@ -310,6 +508,14 @@ `(,(kintern slot-name) ,slot-name))) constructor-args))))) ,(when predicate + #+allegro + `(progn + (,(closintern 'defmethod) ,predicate (object) + (declare (ignore object)) + nil) + (,(closintern 'defmethod) ,predicate ((object ,name)) + t)) + #-allegro `(defun ,predicate (object) (typep object ',name))) ,(when copier @@ -328,6 +534,13 @@ (defstruct (,name ,@options) ,@slots)))) +#+Genera +(progn + (scl:defprop def-clx-class "CLX Class" si:definition-type-name) + (scl:defprop def-clx-class zwei:defselect-function-spec-finder + zwei:definition-function-spec-finder)) + + ;; We need this here so we can define DISPLAY for CLX. ;; ;; This structure is :INCLUDEd in the DISPLAY structure. @@ -337,7 +550,8 @@ (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil)) ;; Lock for multi-processing systems (lock (make-process-lock "CLX Buffer Lock")) - (output-stream nil :type (or null stream)) + #-excl (output-stream nil :type (or null stream)) + #+excl (output-stream -1 :type fixnum) ;; Buffer size (size 0 :type array-index) (request-number 0 :type (unsigned-byte 16)) @@ -350,11 +564,17 @@ (boffset 0 :type array-index) ;; Byte (8 bit) output buffer (obuf8 *empty-bytes* :type buffer-bytes) + ;; Word (16bit) output buffer + #+clx-overlapping-arrays + (obuf16 *empty-words* :type buffer-words) + ;; Long (32bit) output buffer + #+clx-overlapping-arrays + (obuf32 *empty-longs* :type buffer-longs) ;; Holding buffer for 16-bit text - (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0)) + (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0)) ;; Probably EQ to Output-Stream - (input-stream nil :type (or null stream)) - + #-excl (input-stream nil :type (or null stream)) + #+excl (input-stream -1 :type fixnum) ;; T when the host connection has gotten errors (dead nil :type (or null (not null))) ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited. @@ -374,21 +594,83 @@ ;; Function to call to listen for input data (listen-function 'buffer-listen-default) + #+Genera (debug-io nil :type (or null stream)) ) ;;----------------------------------------------------------------------------- +;; 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 ;;----------------------------------------------------------------------------- -(defconstant *image-bit-lsb-first-p* +(defconstant +image-bit-lsb-first-p+ #+clx-little-endian t #-clx-little-endian nil) -(defconstant *image-byte-lsb-first-p* +(defconstant +image-byte-lsb-first-p+ #+clx-little-endian t #-clx-little-endian nil) -(defconstant *image-unit* 32) +(defconstant +image-unit+ 32) -(defconstant *image-pad* 32) +(defconstant +image-pad+ 32) + + +;;----------------------------------------------------------------------------- +;; Foreign Functions +;;----------------------------------------------------------------------------- +#+(and lucid apollo (not lcl3.0)) +(lucid::define-foreign-function '(connect-to-server "connect_to_server") + '((:val host :string) + (:val display :integer32)) + :integer32) + +#+(and lucid (not apollo) (not lcl3.0)) +(lucid::define-c-function connect-to-server (host display) + :result-type :integer) + +#+lcl3.0 +(lucid::def-foreign-function + (connect-to-server + (:language :c) + (:return-type :signed-32bit)) + (host :simple-string) + (display :signed-32bit)) diff --git a/clx/dependent.lisp b/clx/dependent.lisp index aa80fe78e..87aeb751f 100644 --- a/clx/dependent.lisp +++ b/clx/dependent.lisp @@ -17,72 +17,79 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/dependent.lisp,v 1.16 2005/06/17 13:06:18 rtoy Exp $") + +#+cmu +(ext:file-comment "$Id: dependent.lisp,v 1.17 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) (proclaim '(declaration array-register)) +#+cmu (setf (getf ext:*herald-items* :xlib) `(" CLX X Library " ,*version*)) + ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) +#+explorer +(zwei:define-indentation event-case (1 1)) + ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) -#-(or (not clx-little-endian)) +#-(or clx-overlapping-arrays (not clx-little-endian)) (progn - (defconstant *word-0* 0) - (defconstant *word-1* 1) + (defconstant +word-0+ 0) + (defconstant +word-1+ 1) - (defconstant *long-0* 0) - (defconstant *long-1* 1) - (defconstant *long-2* 2) - (defconstant *long-3* 3)) + (defconstant +long-0+ 0) + (defconstant +long-1+ 1) + (defconstant +long-2+ 2) + (defconstant +long-3+ 3)) -#-(or clx-little-endian) +#-(or clx-overlapping-arrays clx-little-endian) (progn - (defconstant *word-0* 1) - (defconstant *word-1* 0) + (defconstant +word-0+ 1) + (defconstant +word-1+ 0) - (defconstant *long-0* 3) - (defconstant *long-1* 2) - (defconstant *long-2* 1) - (defconstant *long-3* 0)) + (defconstant +long-0+ 3) + (defconstant +long-1+ 2) + (defconstant +long-2+ 1) + (defconstant +long-3+ 0)) ;;; 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.") - -(defun declare-bufmac () - `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) - -;;; 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 () - #+clx-debugging - '(declare (optimize (speed 1) (safety 1))) - #-clx-debugging - `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) - -) + (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)) - +#-Genera (progn (defun card8->int8 (x) @@ -129,9 +136,38 @@ ) -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) +#+Genera +(progn + +(defun card8->int8 (x) + (declare lt:(side-effects simple reducible)) + (if (logbitp 7 x) (- x #x100) x)) + +(defun int8->card8 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 8 0) x)) + +(defun card16->int16 (x) + (declare lt:(side-effects simple reducible)) + (if (logbitp 15 x) (- x #x10000) x)) + +(defun int16->card16 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 16 0) x)) + +(defun card32->int32 (x) + (declare lt:(side-effects simple reducible)) + (sys:%logldb (byte 32 0) x)) + +(defun int32->card32 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 32 0) x)) + +) +(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) +#-(or Genera lcl3.0 excl) (progn (defun aref-card8 (a i) @@ -164,7 +200,322 @@ ) +#+Genera +(progn + +(defun aref-card8 (a i) + (aref a i)) + +(defun aset-card8 (v a i) + (zl:aset v a i)) + +(defun aref-int8 (a i) + (card8->int8 (aref a i))) + +(defun aset-int8 (v a i) + (zl:aset (int8->card8 v) a i)) + +) + +#+(or excl lcl3.0 clx-overlapping-arrays) +(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 + aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) + +#+(and clx-overlapping-arrays Genera) +(progn + +(defun aref-card16 (a i) + (aref a i)) + +(defun aset-card16 (v a i) + (zl:aset v a i)) + +(defun aref-int16 (a i) + (card16->int16 (aref a i))) + +(defun aset-int16 (v a i) + (zl:aset (int16->card16 v) a i) + v) + +(defun aref-card32 (a i) + (int32->card32 (aref a i))) + +(defun aset-card32 (v a i) + (zl:aset (card32->int32 v) a i)) + +(defun aref-int32 (a i) (aref a i)) + +(defun aset-int32 (v a i) + (zl:aset v a i)) + +(defun aref-card29 (a i) + (aref a i)) + +(defun aset-card29 (v a i) + (zl:aset v a i)) + +) + +#+(and clx-overlapping-arrays (not Genera)) +(progn + +(defun aref-card16 (a i) + (aref a i)) + +(defun aset-card16 (v a i) + (setf (aref a i) v)) + +(defun aref-int16 (a i) + (card16->int16 (aref a i))) + +(defun aset-int16 (v a i) + (setf (aref a i) (int16->card16 v)) + v) + +(defun aref-card32 (a i) + (aref a i)) + +(defun aset-card32 (v a i) + (setf (aref a i) v)) + +(defun aref-int32 (a i) + (card32->int32 (aref a i))) + +(defun aset-int32 (v a i) + (setf (aref a i) (int32->card32 v)) + v) + +(defun aref-card29 (a i) + (aref a i)) + +(defun aset-card29 (v a i) + (setf (aref a i) v)) + +) + +#+excl +(progn + +(defun aref-card8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card8)) + #.(declare-buffun) + (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-byte))) + +(defun aset-card8 (v a i) + (declare (type card8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-byte) v)) + +(defun aref-int8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int8)) + #.(declare-buffun) + (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-byte))) + +(defun aset-int8 (v a i) + (declare (type int8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-byte) v)) + +(defun aref-card16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card16)) + #.(declare-buffun) + (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-word))) + +(defun aset-card16 (v a i) + (declare (type card16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-word) v)) + +(defun aref-int16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int16)) + #.(declare-buffun) + (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-word))) + +(defun aset-int16 (v a i) + (declare (type int16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-word) v)) + +(defun aref-card32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card32)) + #.(declare-buffun) + (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long))) + +(defun aset-card32 (v a i) + (declare (type card32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long) v)) + +(defun aref-int32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values int32)) + #.(declare-buffun) + (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-long))) + +(defun aset-int32 (v a i) + (declare (type int32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-long) v)) + +(defun aref-card29 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (clx-values card29)) + #.(declare-buffun) + (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long))) + +(defun aset-card29 (v a i) + (declare (type card29 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long) v)) + +) + +#+lcl3.0 +(progn + +(defun aref-card8 (a i) + (declare (type buffer-bytes a) + (type array-index i) + (clx-values card8)) + #.(declare-buffun) + (the card8 (lucid::%svref-8bit a i))) + +(defun aset-card8 (v a i) + (declare (type card8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (lucid::%svref-8bit a i) v)) + +(defun aref-int8 (a i) + (declare (type buffer-bytes a) + (type array-index i) + (clx-values int8)) + #.(declare-buffun) + (the int8 (lucid::%svref-signed-8bit a i))) + +(defun aset-int8 (v a i) + (declare (type int8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (lucid::%svref-signed-8bit a i) v)) + +(defun aref-card16 (a i) + (declare (type buffer-bytes a) + (type array-index i) + (clx-values card16)) + #.(declare-buffun) + (the card16 (lucid::%svref-16bit a (index-ash i -1)))) + +(defun aset-card16 (v a i) + (declare (type card16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (lucid::%svref-16bit a (index-ash i -1)) v)) + +(defun aref-int16 (a i) + (declare (type buffer-bytes a) + (type array-index i) + (clx-values int16)) + #.(declare-buffun) + (the int16 (lucid::%svref-signed-16bit a (index-ash i -1)))) + +(defun aset-int16 (v a i) + (declare (type int16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v)) + +(defun aref-card32 (a i) + (declare (type buffer-bytes a) + (type array-index i) + (clx-values card32)) + #.(declare-buffun) + (the card32 (lucid::%svref-32bit a (index-ash i -2)))) + +(defun aset-card32 (v a i) + (declare (type card32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (lucid::%svref-32bit a (index-ash i -2)) v)) + +(defun aref-int32 (a i) + (declare (type buffer-bytes a) + (type array-index i) + (clx-values int32)) + #.(declare-buffun) + (the int32 (lucid::%svref-signed-32bit a (index-ash i -2)))) + +(defun aset-int32 (v a i) + (declare (type int32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v)) + +(defun aref-card29 (a i) + (declare (type buffer-bytes a) + (type array-index i) + (clx-values card29)) + #.(declare-buffun) + (the card29 (lucid::%svref-32bit a (index-ash i -2)))) + +(defun aset-card29 (v a i) + (declare (type card29 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (lucid::%svref-32bit a (index-ash i -2)) v)) + +) + + +#-(or excl lcl3.0 clx-overlapping-arrays) (progn (defun aref-card16 (a i) @@ -174,17 +525,17 @@ #.(declare-buffun) (the card16 (logior (the card16 - (ash (the card8 (aref a (index+ i *word-1*))) 8)) + (ash (the card8 (aref a (index+ i +word-1+))) 8)) (the card8 - (aref a (index+ i *word-0*)))))) + (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))) + (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) @@ -194,17 +545,17 @@ #.(declare-buffun) (the int16 (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8)) + (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) (the card8 - (aref a (index+ i *word-0*)))))) + (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))) + (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) @@ -214,23 +565,23 @@ #.(declare-buffun) (the card32 (logior (the card32 - (ash (the card8 (aref a (index+ i *long-3*))) 24)) + (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 - (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 - (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 - (aref a (index+ i *long-0*)))))) + (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))) + (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) @@ -240,23 +591,23 @@ #.(declare-buffun) (the int32 (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24)) + (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) (the card29 - (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 - (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 - (aref a (index+ i *long-0*)))))) + (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))) + (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) @@ -266,23 +617,23 @@ #.(declare-buffun) (the card29 (logior (the card29 - (ash (the card8 (aref a (index+ i *long-3*))) 24)) + (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 - (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 - (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 - (aref a (index+ i *long-0*)))))) + (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))) + (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) ) @@ -341,15 +692,14 @@ (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) -#+cmu -(progn +#+(or cmu sbcl clisp) (progn ;;; 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 protocal encoding falls in the desired range +;;; in the value, and see if the protocol encoding falls in the desired range ;;; (64'ths of a degree.) ;;; (deftype angle () '(satisfies anglep)) @@ -373,7 +723,8 @@ (macrolet ((char-translators () (let ((alist - `(;; The normal ascii codes for the control characters. + `(#-lispm + ;; The normal ascii codes for the control characters. ,@`((#\Return . 13) (#\Linefeed . 10) (#\Rubout . 127) @@ -382,7 +733,21 @@ (#\Backspace . 8) (#\Newline . 10) (#\Space . 32)) - + ;; One the lispm, #\Newline is #\Return, but we'd really like + ;; #\Newline to translate to ascii code 10, so we swap the + ;; Ascii codes for #\Return and #\Linefeed. We also provide + ;; mappings from the counterparts of these control characters + ;; so that the character mapping from the lisp machine + ;; character set to ascii is invertible. + #+lispm + ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) + (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) + (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) + (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) + (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) + (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) + (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) + (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) ;; The rest of the common lisp charater set with the normal ;; ascii codes for them. (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) @@ -435,6 +800,7 @@ (dolist (pair alist) (setf (aref array (cdr pair)) (car pair))) array)) + #-Genera (progn (defun char->card8 (char) (declare (type base-char char)) @@ -450,6 +816,16 @@ card8) (error "Invalid CHAR code ~D." card8)))) ) + #+Genera + (progn + (defun char->card8 (char) + (declare lt:(side-effects reader reducible)) + (aref *char-to-card8-translation-table* (char-code char))) + (defun card8->char (card8) + (declare lt:(side-effects reader reducible)) + (aref *card8-to-char-translation-table* card8)) + ) + #-Minima (dotimes (i 256) (unless (= i (char->card8 (card8->char i))) (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" @@ -457,6 +833,7 @@ (card8->char i) (char->card8 (card8->char i)))) (return nil))) + #-Minima (dotimes (i (length *char-to-card8-translation-table*)) (let ((char (code-char i))) (unless (eql char (card8->char (char->card8 char))) @@ -489,15 +866,35 @@ ;;; MAKE-PROCESS-LOCK: Creating a process lock. -#-mp +#-(or LispM excl Minima sbcl (and cmu mp)) (defun make-process-lock (name) (declare (ignore name)) nil) -#+mp +#+excl +(defun make-process-lock (name) + (mp:make-process-lock :name name)) + +#+(and LispM (not Genera)) +(defun make-process-lock (name) + (vector nil name)) + +#+Genera +(defun make-process-lock (name) + (process:make-lock name :flavor 'clx-lock)) + +#+Minima +(defun make-process-lock (name) + (minima:make-lock name :recursive t)) + +#+(and cmu mp) (defun make-process-lock (name) (mp:make-lock name)) +#+sbcl +(defun make-process-lock (name) + (sb-thread:make-mutex :name name)) + ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN @@ -506,7 +903,7 @@ ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient -#-cmu +#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) ) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore locator display whostate timeout)) `(progn ,@body)) @@ -520,19 +917,20 @@ ;;; display connection. We inhibit GC notifications since display of them ;;; could cause recursive entry into CLX. ;;; -#-mp +#+(and CMU (not mp)) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) - `(let ((ext:*gc-verbose* nil) - (ext:*gc-inhibit-hook* nil) - (ext:*before-gc-hooks* nil) - (ext:*after-gc-hooks* nil)) + `(let #+cmu((ext:*gc-verbose* nil) + (ext:*gc-inhibit-hook* nil) + (ext:*before-gc-hooks* nil) + (ext:*after-gc-hooks* nil)) + #+sbcl() ,locator ,display ,whostate ,timeout (system:without-interrupts (progn ,@body)))) ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. ;;; -#+mp +#+(and cmu mp) (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) @@ -540,6 +938,152 @@ `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout))) ,@body)) +#+clisp +(defmacro holding-lock ((lock display &optional (whostate "CLX wait") + &key timeout) + &body body) + (declare (ignore lock display whostate timeout)) + `(progn + ,@body)) + +#+sbcl +(defmacro holding-lock ((lock display &optional (whostate "CLX wait") + &key timeout) + &body body) + ;; This macro is used by WITH-DISPLAY, which claims to be callable + ;; recursively. So, had better use a recursive lock. + ;; + ;; FIXME: This is hideously ugly. If WITH-TIMEOUT handled NIL + ;; timeouts... + (declare (ignore display whostate)) + (if timeout + `(if ,timeout + (handler-case + (sb-ext:with-timeout ,timeout + (sb-thread:with-recursive-lock (,lock) + ,@body)) + (sb-ext:timeout () nil)) + (sb-thread:with-recursive-lock (,lock) + ,@body)) + `(sb-thread:with-recursive-lock (,lock) + ,@body))) + +#+Genera +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore whostate)) + `(process:with-lock (,locator :timeout ,timeout) + (let ((.debug-io. (buffer-debug-io ,display))) + (scl:let-if .debug-io. ((*debug-io* .debug-io.)) + ,@body)))) + +#+(and lispm (not Genera)) +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + ;; This macro is for use in a multi-process environment. + (let ((lock (gensym)) + (have-lock (gensym)) + (timeo (gensym))) + `(let* ((,lock (zl:locf (svref ,locator 0))) + (,have-lock (eq (car ,lock) sys:current-process)) + (,timeo ,timeout)) + (unwind-protect + (when (cond (,have-lock) + ((#+explorer si:%store-conditional + #-explorer sys:store-conditional + ,lock nil sys:current-process)) + ((null ,timeo) + (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) + ((sys:process-wait-with-timeout + ,(or whostate "CLX Lock") (round (* ,timeo 60.)) + #'(lambda (lock process) + (#+explorer si:%store-conditional + #-explorer sys:store-conditional + lock nil process)) + ,lock sys:current-process))) + ,@body) + (unless ,have-lock + (#+explorer si:%store-conditional + #-explorer sys:store-conditional + ,lock sys:current-process nil)))))) + +;; Lucid has a process locking mechanism as well under release 3.0 +#+lcl3.0 +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + (if timeout + ;; Hair to support timeout. + `(let ((.have-lock. (eq ,locator lcl:*current-process*)) + (.timeout. ,timeout)) + (unwind-protect + (when (cond (.have-lock.) + ((conditional-store ,locator nil lcl:*current-process*)) + ((null .timeout.) + (lcl:process-lock ,locator) + t) + ((lcl:process-wait-with-timeout ,whostate .timeout. + #'(lambda () + (conditional-store ,locator nil lcl:*current-process*)))) + ;; abort the PROCESS-UNLOCK if actually timing out + (t + (setf .have-lock. :abort) + nil)) + ,@body) + (unless .have-lock. + (lcl:process-unlock ,locator)))) + `(lcl:with-process-lock (,locator) + ,@body))) + + +#+excl +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) + (unwind-protect + (block .hl-doit. + (when mp::*scheduler-stack-group* ; fast test for scheduler running + (setq .hl-lock. ,locator + .hl-curproc. mp::*current-process*) + (when (and .hl-curproc. ; nil if in process-wait fun + (not (eq (mp::process-lock-locker .hl-lock.) + .hl-curproc.))) + ;; Then we need to grab the lock. + ,(if timeout + `(if (not (mp::process-lock .hl-lock. .hl-curproc. + ,whostate ,timeout)) + (return-from .hl-doit. nil)) + `(mp::process-lock .hl-lock. .hl-curproc. + ,@(when whostate `(,whostate)))) + ;; There is an apparent race condition here. However, there is + ;; no actual race condition -- our implementation of mp:process- + ;; lock guarantees that the lock will still be held when it + ;; returns, and no interrupt can happen between that and the + ;; execution of the next form. -- jdi 2/27/91 + (setq .hl-obtained-lock. t))) + ,@body) + (if (and .hl-obtained-lock. + ;; Note -- next form added to allow error handler inside + ;; body to unlock the lock prematurely if it knows that + ;; the current process cannot possibly continue but will + ;; throw out (or is it throw up?). + (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) + (mp::process-unlock .hl-lock. .hl-curproc.))))) + +#+Minima +(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) + `(holding-lock-1 #'(lambda () ,@body) ,locator ,display + ,@(and whostate `(:whostate ,whostate)) + ,@(and timeout `(:timeout ,timeout)))) + +#+Minima +(defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout) + (declare (dynamic-extent continuation)) + (declare (ignore display whostate timeout)) + (minima:with-lock (lock) + (funcall continuation))) ;;; WITHOUT-ABORTS @@ -548,38 +1092,174 @@ ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. +#-(or Genera excl lcl3.0) (defmacro without-aborts (&body body) `(progn ,@body)) +#+Genera +(defmacro without-aborts (&body body) + `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") + ,@body)) + +#+excl +(defmacro without-aborts (&body body) + `(without-interrupts ,@body)) + +#+lcl3.0 +(defmacro without-aborts (&body body) + `(lcl:with-interruptions-inhibited ,@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. -#-mp + +#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp)) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler."))) -#+mp +#+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)) + (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)) + (apply #'global:process-wait whostate predicate predicate-args)) + +#+excl +(defun process-block (whostate predicate &rest predicate-args) + (if mp::*scheduler-stack-group* + (apply #'mp::process-wait whostate predicate predicate-args) + (or (apply predicate predicate-args) + (error "Program tried to wait with no scheduler.")))) + +#+lcl3.0 +(defun process-block (whostate predicate &rest predicate-args) + (declare (dynamic-extent predicate-args)) + (apply #'lcl:process-wait whostate predicate predicate-args)) + +#+Minima +(defun process-block (whostate predicate &rest predicate-args) + (declare (type function predicate) + (dynamic-extent predicate)) + (apply #'minima:process-wait whostate predicate predicate-args)) + +#+(and cmu mp) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate)) (mp:process-wait whostate #'(lambda () (apply predicate predicate-args)))) +#+(and sbcl sb-thread) +(progn + (declaim (inline yield)) + (defun yield () + (declare (optimize speed (safety 0))) + (sb-alien:alien-funcall + (sb-alien:extern-alien "sched_yield" (function sb-alien:int))) + (values))) + +#+(and sbcl sb-thread) +(defun process-block (whostate predicate &rest predicate-args) + (declare (ignore whostate)) + (declare (type function predicate)) + (loop + (when (apply predicate predicate-args) + (return)) + (yield))) + + +;;; FIXME: the below implementation for threaded PROCESS-BLOCK using +;;; queues and condition variables might seem better, but in fact it +;;; turns out to make performance extremely suboptimal, at least as +;;; measured by McCLIM on linux 2.4 kernels. -- CSR, 2003-11-10 +#+(or) +(defvar *process-conditions* (make-hash-table)) + +#+(or) +(defun process-block (whostate predicate &rest predicate-args) + (declare (ignore whostate)) + (declare (type function predicate)) + (let* ((pid (sb-thread:current-thread-id)) + (last (gethash pid *process-conditions*)) + (lock + (or (car last) + (sb-thread:make-mutex :name (format nil "lock ~A" pid)))) + (queue + (or (cdr last) + (sb-thread:make-waitqueue :name (format nil "queue ~A" pid))))) + (unless last + (setf (gethash pid *process-conditions*) (cons lock queue))) + (sb-thread:with-mutex (lock) + (loop + (when (apply predicate predicate-args) (return)) + (handler-case + (sb-ext:with-timeout .5 + (sb-thread:condition-wait queue lock)) + (sb-ext:timeout () + (format *trace-output* "thread ~A, process-block timed out~%" + (sb-thread:current-thread-id) ))))))) + ;;; PROCESS-WAKEUP: Check some other process' wait function. (declaim (inline process-wakeup)) -#-mp +#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp)) (defun process-wakeup (process) (declare (ignore process)) nil) -#+mp +#+excl +(defun process-wakeup (process) + (let ((curproc mp::*current-process*)) + (when (and curproc process) + (unless (mp::process-p curproc) + (error "~s is not a process" curproc)) + (unless (mp::process-p process) + (error "~s is not a process" process)) + (if (> (mp::process-priority process) (mp::process-priority curproc)) + (mp::process-allow-schedule process))))) + +#+Genera +(defun process-wakeup (process) + (process:wakeup process)) + +#+Minima +(defun process-wakeup (process) + (when process + (minima:process-wakeup process))) + +#+(and cmu mp) (defun process-wakeup (process) (declare (ignore process)) (mp:process-yield)) +#+(and sb-thread sbcl) +(defun process-wakeup (process) + (declare (ignore process)) + (yield)) +#+(or) +(defun process-wakeup (process) + (declare (ignore process)) + (destructuring-bind (lock . queue) + (gethash (sb-thread:current-thread-id) *process-conditions* + (cons nil nil)) + (declare (ignore lock)) + (when queue + (sb-thread:condition-notify queue)))) + + ;;; CURRENT-PROCESS: Return the current process object for input locking and ;;; for calling PROCESS-WAKEUP. @@ -587,29 +1267,90 @@ ;;; Default return NIL, which is acceptable even if there is a scheduler. -#-mp +#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp)) (defun current-process () nil) -#+mp +#+lispm +(defun current-process () + sys:current-process) + +#+excl +(defun current-process () + (and mp::*scheduler-stack-group* + mp::*current-process*)) + +#+lcl3.0 +(defun current-process () + lcl:*current-process*) + +#+Minima +(defun current-process () + (minima:current-process)) + +#+(and cmu mp) (defun current-process () mp:*current-process*) +#+sbcl +(defun current-process () + sb-thread:*current-thread*) + ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. -;; + +#-(or lispm excl lcl3.0 Minima cmu) +(defmacro without-interrupts (&body body) + `(progn ,@body)) + +#+(and lispm (not Genera)) (defmacro without-interrupts (&body body) `(sys:without-interrupts ,@body)) +#+Genera +(defmacro without-interrupts (&body body) + `(process:with-no-other-processes ,@body)) + +#+LCL3.0 +(defmacro without-interrupts (&body body) + `(lcl:with-scheduling-inhibited ,@body)) + +#+Minima +(defmacro without-interrupts (&body body) + `(minima:with-no-other-processes ,@body)) + +#+cmu +(defmacro without-interrupts (&body body) + `(system:without-interrupts ,@body)) + +#+sbcl +(defvar *without-interrupts-sic-lock* + (sb-thread:make-mutex :name "lock simulating *without-interrupts*")) +#+sbcl +(defmacro without-interrupts (&body body) + `(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*) + ,@body)) + ;;; CONDITIONAL-STORE: ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. +#-sbcl (defmacro conditional-store (place old-value new-value) `(without-interrupts (cond ((eq ,place ,old-value) (setf ,place ,new-value) t)))) +#+sbcl +(progn + (defvar *conditional-store-lock* + (sb-thread:make-mutex :name "conditional store")) + (defmacro conditional-store (place old-value new-value) + `(sb-thread:with-mutex (*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. @@ -617,16 +1358,51 @@ ;;; ;;;---------------------------------------------------------------------------- +#-Genera (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(unless (buffer-dead ,buffer) ,@body)) +#+Genera +(defmacro wrap-buf-output ((buffer) &body body) + ;; Error recovery wrapper + `(let ((.buffer. ,buffer)) + (unless (buffer-dead .buffer.) + (scl:condition-bind + (((sys:network-error) + #'(lambda (error) + (scl:condition-case () + (funcall (buffer-close-function .buffer.) .buffer. :abort t) + (sys:network-error)) + (setf (buffer-dead .buffer.) error) + (setf (buffer-output-stream .buffer.) nil) + (setf (buffer-input-stream .buffer.) nil) + nil))) + ,@body)))) + +#-Genera (defmacro wrap-buf-input ((buffer) &body body) (declare (ignore buffer)) ;; Error recovery wrapper `(progn ,@body)) +#+Genera +(defmacro wrap-buf-input ((buffer) &body body) + ;; Error recovery wrapper + `(let ((.buffer. ,buffer)) + (scl:condition-bind + (((sys:network-error) + #'(lambda (error) + (scl:condition-case () + (funcall (buffer-close-function .buffer.) .buffer. :abort t) + (sys:network-error)) + (setf (buffer-dead .buffer.) error) + (setf (buffer-output-stream .buffer.) nil) + (setf (buffer-input-stream .buffer.) nil) + nil))) + ,@body))) + ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives @@ -634,53 +1410,311 @@ ;;; the stream to the server. ;;;---------------------------------------------------------------------------- -;;; OPEN-X-STREAM - create a stream for communicating to the -;;; appropriate X server. +;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X +;;; server + +#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp) (defun open-x-stream (host display protocol) - (ecase protocol - ;; establish a TCP connection to the X11 server, which is - ;; listening on port 6000 + display-number - ((:internet :tcp nil) - (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display)))) - (unless (plusp fd) - (error 'connection-failure - :major-version *protocol-major-version* - :minor-version *protocol-minor-version* - :host host - :display display - :reason (format nil "Cannot connect to internet socket: ~S" - (unix:get-unix-error-msg)))) - (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8)))) - ;; establish a connection to the X11 server over a Unix socket - (:unix - (let ((path (make-pathname :directory '(:absolute "tmp" ".X11-unix") - :name (format nil "X~D" display)))) - (unless (probe-file path) - (error 'connection-failure - :major-version *protocol-major-version* - :minor-version *protocol-minor-version* - :host host - :display display - :reason (format nil "Unix socket ~s does not exist" path))) - (let ((fd (ext:connect-to-unix-socket (namestring path)))) - (unless (plusp fd) - (error 'connection-failure - :major-version *protocol-major-version* - :minor-version *protocol-minor-version* - :host host - :display display - :reason (format nil "Can't connect to unix socket: ~S" - (unix:get-unix-error-msg)))) - (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8))))))) + host display protocol ;; unused + (error "OPEN-X-STREAM not implemented yet.")) +#+clisp +(defun open-x-stream (host display protocol) + (declare (ignore protocol) + (type (integer 0) display)) + (let ((socket + ;; are we dealing with a localhost? + (when (or (string= host "") + (string= host "unix")) + ;; ok, try to connect to a AF_UNIX domain socket + (sys::make-socket-stream "" display)))) + (if socket + socket + ;; try to connect by hand + (let ((host (host-address host))) + (when host + ;; Fixme: get a descent ip standard in CLX: a vector! + (let ((ip (format nil + "~{~D~^.~}" + (rest host)))) + (socket:socket-connect (+ 6000 display) ip + :element-type '(unsigned-byte 8)))))))) + + +;;; Genera: + +;;; TCP and DNA are both layered products, so try to work with either one. + +#+Genera +(when (fboundp 'tcp:add-tcp-port-for-protocol) + (tcp:add-tcp-port-for-protocol :x-window-system 6000)) + +#+Genera +(when (fboundp 'dna:add-dna-contact-id-for-protocol) + (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0")) + +#+Genera +(net:define-protocol :x-window-system (:x-window-system :byte-stream) + (:invoke-with-stream ((stream :characters nil :ascii-translation nil)) + stream)) + +#+Genera +(eval-when (compile) + (compiler:function-defined 'tcp:open-tcp-stream) + (compiler:function-defined 'dna:open-dna-bidirectional-stream)) + +#+Genera +(defun open-x-stream (host display protocol) + (let ((host (net:parse-host host))) + (if (or protocol (plusp display)) + ;; The protocol was specified or the display isn't 0, so we + ;; can't use the Generic Network System. If the protocol was + ;; specified, then use that protocol, otherwise, blindly use + ;; TCP. + (ccase protocol + ((:tcp nil) + (tcp:open-tcp-stream + host (+ *x-tcp-port* display) nil + :direction :io + :characters nil + :ascii-translation nil)) + ((:dna) + (dna:open-dna-bidirectional-stream + host (format nil "X$X~D" display) + :characters nil + :ascii-translation nil))) + (let ((neti:*invoke-service-automatic-retry* t)) + (net:invoke-service-on-host :x-window-system host))))) + +#+explorer +(defun open-x-stream (host display protocol) + (declare (ignore protocol)) + (net:open-connection-on-medium + (net:parse-host host) ;Host + :byte-stream ;Medium + "X11" ;Logical contact name + :stream-type :character-stream + :direction :bidirectional + :timeout-after-open nil + :remote-port (+ *x-tcp-port* display))) + +#+explorer +(net:define-logical-contact-name + "X11" + `((:local "X11") + (:chaos "X11") + (:nsp-stream "X11") + (:tcp ,*x-tcp-port*))) + +#+lucid +(defun open-x-stream (host display protocol) + protocol ;; unused + (let ((fd (connect-to-server host display))) + (when (minusp fd) + (error "Failed to connect to server: ~A ~D" host display)) + (user::make-lisp-stream :input-handle fd + :output-handle fd + :element-type 'unsigned-byte + #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) + +#+(or kcl ibcl) +(defun open-x-stream (host display protocol) + protocol ;; unused + (let ((stream (open-socket-stream host display))) + (if (streamp stream) + stream + (error "Cannot connect to server: ~A:~D" host display)))) + +#+excl +;; +;; Note that since we don't use the CL i/o facilities to do i/o, the display +;; input and output "stream" is really a file descriptor (fixnum). +;; +(defun open-x-stream (host display protocol) + (declare (ignore protocol));; unused + (let ((fd (connect-to-server (string host) display))) + (when (minusp fd) + (error "Failed to connect to server: ~A ~D" host display)) + fd)) + +#+Minima +(defun open-x-stream (host display protocol) + (declare (ignore protocol));; unused + (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address + (cdr (host-address host))) + :foreign-port (+ *x-tcp-port* display))) + + +#+CMU +(defun open-x-stream (host display protocol) + (let ((stream-fd + (ecase protocol + ;; establish a TCP connection to the X11 server, which is + ;; listening on port 6000 + display-number + ((:internet :tcp nil) + (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display)))) + (unless (plusp fd) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Cannot connect to internet socket: ~S" + (unix:get-unix-error-msg)))) + fd)) + ;; establish a connection to the X11 server over a Unix socket + ((:unix :local) + (let ((path (make-pathname :directory '(:absolute "tmp" ".X11-unix") + :name (format nil "X~D" display)))) + (unless (probe-file path) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Unix socket ~s does not exist" path))) + (let ((fd (ext:connect-to-unix-socket (namestring path)))) + (unless (plusp fd) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Can't connect to unix socket: ~S" + (unix:get-unix-error-msg)))) + fd)))))) + (system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8)))) + + + +#+(or sbcl ecl) +(defconstant +X-unix-socket-path+ + "/tmp/.X11-unix/X" + "The location of the X socket") + +#+sbcl +(defun open-x-stream (host display protocol) + (declare (ignore protocol) + (type (integer 0) display)) + (socket-make-stream + (if (or (string= host "") (string= host "unix")) ; AF_LOCAL domain socket + (let ((s (make-instance 'local-socket :type :stream))) + (socket-connect s (format nil "~A~D" +X-unix-socket-path+ display)) + 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) +(defun buffer-read-default (display vector start end timeout) + ;; returns non-NIL if EOF encountered + ;; Returns :TIMEOUT when timeout exceeded + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (or (cond ((null stream)) + ((funcall stream :listen) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (multiple-value-bind (ignore eofp) + (funcall stream :string-in nil vector start end) + eofp)))) + + +#+excl +;; +;; Rewritten 10/89 to not use foreign function interface to do I/O. +;; +(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 (real 0 *)) timeout)) + #.(declare-buffun) + + (let* ((howmany (- end start)) + (fd (display-input-stream display))) + (declare (type array-index howmany) + (fixnum fd)) + (or (cond ((fd-char-avail-p fd) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (fd-read-bytes fd vector start howmany)))) + + +#+lcl3.0 +(defmacro with-underlying-stream ((variable stream display direction) &body body) + `(let ((,variable + (or (getf (display-plist ,display) ',direction) + (setf (getf (display-plist ,display) ',direction) + (lucid::underlying-stream + ,stream ,(if (eq direction 'input) :input :output)))))) + ,@body)) + +#+lcl3.0 +(defun buffer-read-default (display vector start end timeout) + ;;Note that LISTEN must still be done on "slow stream" or the I/O system + ;;gets confused. But reading should be done from "fast stream" for speed. + ;;We used to inhibit scheduling because there were races in Lucid's + ;;multitasking system. Empirical evidence suggests they may be gone now. + ;;Should you decide you need to inhibit scheduling, do it around the + ;;lcl:read-array. + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (or (cond ((null stream)) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (with-underlying-stream (stream stream display input) + (eq (lcl:read-array stream vector start end nil :eof) :eof))))) + +#+Minima +(defun buffer-read-default (display vector start end timeout) + ;; returns non-NIL if EOF encountered + ;; Returns :TIMEOUT when timeout exceeded + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (or (cond ((null stream)) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (eq :eof (minima:read-vector vector stream nil start end))))) + +;;; BUFFER-READ-DEFAULT for CMU Common Lisp. ;;; ;;; If timeout is 0, then we call LISTEN to see if there is any input. ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without ;;; first calling BUFFER-INPUT-WAIT-DEFAULT. ;;; -#+CMU +#+(or CMU sbcl) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) @@ -691,17 +1725,35 @@ (not (listen (display-input-stream display)))) :timeout) (t - (system:read-n-bytes (display-input-stream display) - vector start (- end start)) + (#+cmu system:read-n-bytes + #+sbcl sb-sys:read-n-bytes + (display-input-stream display) + vector start (- end start)) nil))) +#+(or ecl clisp) +(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))) ;;; WARNING: ;;; CLX performance will suffer if your lisp uses read-byte for ;;; receiving all data from the X Window System server. ;;; You are encouraged to write a specialized version of ;;; buffer-read-default that does block transfers. -#-(or CMU) +#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) @@ -725,6 +1777,55 @@ ;;; BUFFER-WRITE-DEFAULT - write data to the X stream +#+(or Genera explorer) +(defun buffer-write-default (vector display start end) + ;; The default buffer write function for use with common-lisp streams + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (write-string vector stream :start start :end end)))) + +#+excl +(defun buffer-write-default (vector display start end) + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (excl::filesys-write-bytes (display-output-stream display) vector start + (- end start))) + +#+lcl3.0 +(defun buffer-write-default (vector display start end) + ;;We used to inhibit scheduling because there were races in Lucid's + ;;multitasking system. Empirical evidence suggests they may be gone now. + ;;Should you decide you need to inhibit scheduling, do it around the + ;;lcl:write-array. + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (with-underlying-stream (stream stream display output) + (lcl:write-array stream vector start end))))) + +#+Minima +(defun buffer-write-default (vector display start end) + ;; The default buffer write function for use with common-lisp streams + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (minima:write-vector vector stream start end)))) + #+CMU (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) @@ -734,13 +1835,34 @@ (system:output-raw-bytes (display-output-stream display) vector start end) nil) +#+sbcl +(defun buffer-write-default (vector display start end) + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (sb-impl::output-raw-bytes (display-output-stream display) vector start end) + nil) + +#+(or ecl clisp) +(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) + ;;; WARNING: ;;; CLX performance will be severely degraded if your lisp uses ;;; write-byte to send all data to the X Window System server. ;;; You are STRONGLY encouraged to write a specialized version ;;; of buffer-write-default that does block transfers. -#-(or CMU) +#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) @@ -756,17 +1878,14 @@ (declare (type array-index index)) (write-byte (aref vector index) stream)))))) -#+CMU -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (system:output-raw-bytes (display-output-stream display) vector start end) - nil) - ;;; buffer-force-output-default - force output to the X stream +#+excl +(defun buffer-force-output-default (display) + ;; buffer-write-default does the actual writing. + (declare (ignore display))) + +#-(or excl) (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) @@ -777,6 +1896,15 @@ ;;; BUFFER-CLOSE-DEFAULT - close the X stream +#+excl +(defun buffer-close-default (display &key abort) + ;; The default buffer close function for use with common-lisp streams + (declare (type display display) + (ignore abort)) + #.(declare-buffun) + (excl::filesys-checking-close (display-output-stream display))) + +#-(or excl) (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) @@ -794,10 +1922,10 @@ ;;; The default implementation ;; Poll for input every *buffer-read-polling-time* SECONDS. -#-(or CMU) +#-(or Genera explorer excl lcl3.0 CMU sbcl) (defparameter *buffer-read-polling-time* 0.5) -#-(or CMU) +#-(or Genera explorer excl lcl3.0 CMU sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) @@ -821,7 +1949,7 @@ (return-from buffer-input-wait-default nil))) :timeout))))) -#+CMU +#+(or CMU sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null number) timeout)) @@ -831,19 +1959,142 @@ ((listen stream) nil) ((eql timeout 0) :timeout) (t - (if #-mp (system:wait-until-fd-usable (system:fd-stream-fd stream) - :input timeout) + (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) + :input timeout) #+mp (mp:process-wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) + #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) + (ext:socket-status stream (and timeout sec) + (round usec 1d-6))) + #-(or sbcl mp clisp) (system:wait-until-fd-usable + (system:fd-stream-fd stream) :input timeout) nil :timeout))))) +#+Genera +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout)) + (declare (clx-values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((scl:send stream :listen) nil) + ((and timeout (= timeout 0)) :timeout) + ((null timeout) (si:stream-input-block stream "CLX Input")) + (t + (scl:condition-bind ((neti:protocol-timeout + #'(lambda (error) + (when (eq stream (scl:send error :stream)) + (return-from buffer-input-wait-default :timeout))))) + (neti:with-stream-timeout (stream :input timeout) + (si:stream-input-block stream "CLX Input"))))) + nil)) + +#+explorer +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout)) + (declare (clx-values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((zl:send stream :listen) nil) + ((and timeout (= timeout 0)) :timeout) + ((null timeout) + (si:process-wait "CLX Input" stream :listen)) + (t + (unless (si:process-wait-with-timeout + "CLX Input" (round (* timeout 60.)) stream :listen) + (return-from buffer-input-wait-default :timeout)))) + nil)) + +#+excl +;; +;; This is used so an 'eq' test may be used to find out whether or not we can +;; safely throw this process out of the CLX read loop. +;; +(defparameter *read-whostate* "waiting for input from X server") + +;; +;; Note that this function returns nil on error if the scheduler is running, +;; t on error if not. This is ok since buffer-read will detect the error. +;; +#+excl +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout)) + (declare (clx-values timeout)) + (let ((fd (display-input-stream display))) + (declare (fixnum fd)) + (when (>= fd 0) + (cond ((fd-char-avail-p fd) + nil) + + ;; Otherwise no bytes were available on the socket + ((and timeout (= timeout 0)) + ;; If there aren't enough and timeout == 0, timeout. + :timeout) + + ;; If the scheduler is running let it do timeouts. + (mp::*scheduler-stack-group* + #+allegro + (if (not + (mp:wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p + :timeout timeout)) + (return-from buffer-input-wait-default :timeout)) + #-allegro + (mp::wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p)) + + ;; Otherwise we have to handle timeouts by hand, and call select() + ;; to block until input is available. Note we don't really handle + ;; the interaction of interrupts and (numberp timeout) here. XX + (t + (let ((res 0)) + (declare (fixnum res)) + (with-interrupt-checking-on + (loop + (setq res (fd-wait-for-input fd (if (null timeout) 0 + (truncate timeout)))) + (cond ((plusp res) ; success + (return nil)) + ((eq res 0) ; timeout + (return :timeout)) + ((eq res -1) ; error + (return t)) + ;; Otherwise we got an interrupt -- go around again. + ))))))))) + + +#+lcl3.0 +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout) + (clx-values timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((with-underlying-stream (stream stream display input) + (lucid::waiting-for-input-from-stream stream + (lucid::with-io-unlocked + (if (null timeout) + (lcl:process-wait "CLX Input" #'listen stream) + (lcl:process-wait-with-timeout + "CLX Input" timeout #'listen stream))))) + 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. ;;; The default implementation is to just use listen. - +#-(or excl) (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) @@ -852,6 +2103,15 @@ t (listen stream)))) +#+excl +(defun buffer-listen-default (display) + (declare (type display display)) + (let ((fd (display-input-stream display))) + (declare (type fixnum fd)) + (if (= fd -1) + t + (fd-char-avail-p fd)))) + ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks @@ -863,6 +2123,7 @@ ;; consing garbage, you may want to re-write this to allocate and ;; initialize lists from a resource. ;; +#-lispm (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) @@ -870,9 +2131,10 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - (dynamic-extent ,var)) + #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) +#-lispm (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) @@ -880,29 +2142,131 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) - (dynamic-extent ,var)) + #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) -#+cmu +#+lispm +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type vector buf1 buf2) + (type array-index start1 end1 start2)) + (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) + +#+excl +(defun buffer-replace (target-sequence source-sequence target-start + target-end &optional (source-start 0)) + (declare (type buffer-bytes target-sequence source-sequence) + (type array-index target-start target-end source-start) + (optimize (speed 3) (safety 0))) + + (let ((source-end (length source-sequence))) + (declare (type array-index source-end)) + + (excl:if* (and (eq target-sequence source-sequence) + (> target-start source-start)) + then (let ((nelts (min (- target-end target-start) + (- source-end source-start)))) + (do ((target-index (+ target-start nelts -1) (1- target-index)) + (source-index (+ source-start nelts -1) (1- source-index))) + ((= target-index (1- target-start)) target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) + else (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index target-end) (= source-index source-end)) + target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))))) + +#+cmu (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) #.(declare-buffun) (kernel:bit-bash-copy - buf2 (+ (* start2 vm:byte-bits) - (* vm:vector-data-offset vm:word-bits)) - buf1 (+ (* start1 vm:byte-bits) - (* vm:vector-data-offset vm:word-bits)) - (* (- end1 start1) vm:byte-bits))) + buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) + (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) + buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) + (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) + (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits))) + +#+lucid +;;;The compiler is *supposed* to optimize calls to replace, but in actual +;;;fact it does not. +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type buffer-bytes buf1 buf2) + (type array-index start1 end1 start2)) + #.(declare-buffun) + (let ((end2 (lucid::%simple-8bit-vector-length buf2))) + (declare (type array-index end2)) + (lucid::simple-8bit-vector-replace-internal + buf1 buf2 start1 end1 start2 end2))) + +#+(and clx-overlapping-arrays (not (or lispm excl))) +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type vector buf1 buf2) + (type array-index start1 end1 start2)) + (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) -#-CMU +#-(or lispm lucid excl CMU clx-overlapping-arrays) (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)) +#+ti +(defun with-location-bindings (sys:"e bindings &rest body) + (do ((bindings bindings (cdr bindings))) + ((null bindings) + (sys:eval-body-as-progn body)) + (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) + (sys:*eval (cadar bindings))))) + +#+ti +(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) + (let ((bindings (cadr form)) + (body (cddr form))) + `(let () + ,@(loop for (accessor value) in bindings + collect `(si:bind (si:locf ,accessor) ,value)) + ,@body))) + +#+ti +(defun (:property with-location-bindings compiler::cw-handler) (exp) + (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) + (body (compiler::cw-clause (cddr exp)))) + (and compiler::cw-return-expansion-flag + (list* (first exp) bindlist body)))) + +#+(and lispm (not ti)) +(defmacro with-location-bindings (bindings &body body) + `(sys:letf* ,bindings ,@body)) + +#+lispm +(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) + &body body) + ;; don't use svref on LHS because Symbolics didn't define locf for it + (let* ((local-state (gensym)) + (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway + (dolist (index indexes) + (push `((aref ,local-state ,index) (svref ,saved-state ,index)) + bindings)) + `(let ((,local-state (gcontext-local-state ,gc))) + (declare (type gcontext-state ,local-state)) + (unwind-protect + (with-location-bindings ,bindings + ,@body) + (setf (svref ,local-state ,ts-index) 0) + (when ,temp-gc + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (deallocate-gcontext-state ,saved-state))))) + +#-lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) (let ((local-state (gensym)) @@ -945,7 +2309,7 @@ ;;; should it also check for non-negative and less than 65536? ;;;---------------------------------------------------------------------------- -;; The *TYPE-CHECK?* constant controls how much error checking is done. +;; 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 @@ -954,7 +2318,9 @@ ;;; 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?* #+clx-debugging t #-clx-debugging nil) +(defconstant +type-check?+ + #+(or Genera Minima CMU sbcl) nil + #-(or Genera Minima CMU sbcl) t) ;; 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 @@ -967,7 +2333,32 @@ ;; dispatching, not just type checking. -- Ram. (defmacro type? (object type) - `(typep ,object ,type)) + #+(or cmu sbcl clisp) + `(typep ,object ,type) + #-(or cmu sbcl clisp) + (if (not (constantp type)) + `(typep ,object ,type) + (progn + (setq type (eval type)) + #+(or Genera explorer Minima) + (if +type-check?+ + `(locally (declare (optimize safety)) (typep ,object ',type)) + `(typep ,object ',type)) + #-(or Genera explorer Minima) + (let ((predicate (assoc type + '((drawable drawable-p) (window window-p) + (pixmap pixmap-p) (cursor cursor-p) + (font font-p) (gcontext gcontext-p) + (colormap colormap-p) (null null) + (integer integerp))))) + (cond (predicate + `(,(second predicate) ,object)) + ((eq type 'generalized-boolean) + 't) ; Everything is a generalized-boolean. + (+type-check?+ + `(locally (declare (optimize safety)) (typep ,object ',type))) + (t + `(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, @@ -996,10 +2387,31 @@ (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)) @@ -1013,7 +2425,7 @@ ;;; descriptors, Mach messages, etc.) to come through one routine anyone can ;;; use to wait for input. ;;; -#+(and CMU (not mp)) +#+(and CMU (not mp)) (defun x-error (condition &rest keyargs) (let ((condx (apply #'make-condition condition keyargs))) (when (eq condition 'closed-display) @@ -1022,15 +2434,332 @@ (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 ;;----------------------------------------------------------------------------- +#-(or explorer Genera Minima Allegro CMU sbcl ecl clisp) +(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 (clx-values list)) + host family + (error "HOST-ADDRESS not implemented yet.")) + +#+clisp +(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 (clx-values list)) + (labels ((no-host-error () + (error "Unknown host ~S" host)) + (no-address-error () + (error "Host ~S has no ~S address" host family))) + + (let ((hostent (posix::resolve-host-ipaddr (string host)))) + (when (not (posix::hostent-addr-list hostent)) + (no-host-error)) + (ecase family + ((:internet nil 0) + (unless (= (posix::hostent-addrtype hostent) 2) + (no-address-error)) + (let ((addr (first (posix::hostent-addr-list hostent)))) + (etypecase addr + (integer + (list :internet + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr))) + (string + (let ((parts (read-from-string + (nsubstitute #\Space #\. (ext:string-concat + "(" addr ")"))))) + (check-type parts (cons (unsigned-byte 8) + (cons (unsigned-byte 8) + (cons (unsigned-byte 8) + (cons (unsigned-byte 8) + NULL))))) + (cons :internet parts)))))))))) + + +#+explorer +(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 (clx-values list)) + (ecase family + ((:internet nil 0) + (let ((addr (ip:get-ip-address host))) + (unless addr (error "~s isn't an internet host name" host)) + (list :internet + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr)))) + ((:chaos 2) + (let ((addr (first (chaos:chaos-addresses host)))) + (unless addr (error "~s isn't a chaos host name" host)) + (list :chaos + (ldb (byte 8 0) addr) + (ldb (byte 8 8) addr)))))) + +#+Genera +(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 (clx-values list)) + (setf host (string host)) + (let ((net-type (ecase family + ((:internet nil 0) :internet) + ((:DECnet 1) :dna) + ((:chaos 2) :chaos)))) + (dolist (addr + (sys:send (net:parse-host host) :network-addresses) + (error "~S isn't a valid ~(~A~) host name" host family)) + (let ((network (car addr)) + (address (cadr addr))) + (when (sys:send network :network-typep net-type) + (return (ecase family + ((:internet nil 0) + (multiple-value-bind (a b c d) (tcp:explode-internet-address address) + (list :internet a b c d))) + ((:DECnet 1) + (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address))) + ((:chaos 2) + (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) + +#+Minima +(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 (clx-values list)) + (etypecase family + ((:internet nil 0) + (list* :internet + (multiple-value-list + (minima:ip-address-components (minima:parse-ip-address (string host)))))))) + +#+Allegro +(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 (clx-values list)) + (labels ((no-host-error () + (error "Unknown host ~S" host)) + (no-address-error () + (error "Host ~S has no ~S address" host family))) + (let ((hostent 0)) + (unwind-protect + (progn + (setf hostent (ipc::gethostbyname (string host))) + (when (zerop hostent) + (no-host-error)) + (ecase family + ((:internet nil 0) + (unless (= (ipc::hostent-addrtype hostent) 2) + (no-address-error)) + (assert (= (ipc::hostent-length hostent) 4)) + (let ((addr (ipc::hostent-addr hostent))) + (when (or (member comp::.target. + '(:hp :sgi4d :sony :dec3100) + :test #'eq) + (probe-file "/lib/ld.so")) + ;; BSD 4.3 based systems require an extra indirection + (setq addr (si:memref-int addr 0 0 :unsigned-long))) + (list :internet + (si:memref-int addr 0 0 :unsigned-byte) + (si:memref-int addr 1 0 :unsigned-byte) + (si:memref-int addr 2 0 :unsigned-byte) + (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) ;; and cdr is a list of network address bytes. @@ -1048,12 +2777,98 @@ ((:internet nil 0) (unless (= (ext::host-entry-addr-type hostent) 2) (no-address-error)) - (let ((addr (first (ext::host-entry-addr-list hostent)))) - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr)))))))) + (append (list :internet) + (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 +(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 (clx-values list)) + (let ((hostent (get-host-by-name (string host)))) + (ecase family + ((:internet nil 0) + (cons :internet (coerce (host-ent-address hostent) 'list)))))) + +#+ecl +(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 (clx-values list)) + (labels ((no-host-error () + (error "Unknown host ~S" host))) + (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host)))))) + (unless addr + (no-host-error)) + (list :internet + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr))))) + +#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts +(defun get-host (host-object) + ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type list host-object)) + (declare (clx-values string family)) + (let* ((family (first host-object)) + (address (ecase family + (:internet + (dpb (second host-object) + (byte 8 24) + (dpb (third host-object) + (byte 8 16) + (dpb (fourth host-object) + (byte 8 8) + (fifth host-object))))) + (:chaos + (dpb (third host-object) (byte 8 8) (second host-object)))))) + (when (eq family :internet) (setq family :ip)) + (let ((host (si:get-host-from-address address family))) + (values (and host (funcall host :name)) family)))) + +;;; This isn't required, but it helps make sense of the results from access-hosts +#+Genera +(defun get-host (host-object) + ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type list host-object)) + (declare (clx-values string family)) + (let ((family (first host-object))) + (values (sys:send (net:get-host-from-address + (ecase family + (:internet + (apply #'tcp:build-internet-address (rest host-object))) + ((:chaos :DECnet) + (dpb (third host-object) (byte 8 8) (second host-object)))) + (net:local-network-of-type (if (eq family :DECnet) + :DNA + family))) + :name) + family))) + +;;; This isn't required, but it helps make sense of the results from access-hosts +#+Minima +(defun get-host (host-object) + ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type list host-object)) + (declare (clx-values string family)) + (let ((family (first host-object))) + (values (ecase family + (:internet + (minima:ip-address-string + (apply #'minima:make-ip-address (rest host-object))))) + family))) ;;----------------------------------------------------------------------------- @@ -1067,8 +2882,15 @@ ;;; want to make this expand to T, as it makes the code more compact. (defmacro use-closures () - t) ;; emarsden2003-06-04 was NIL + #+(or lispm Minima) t + #-(or lispm Minima) nil) + +#+(or Genera Minima) +(defun clx-macroexpand (form env) + (declare (ignore env)) + form) +#-(or Genera Minima) (defun clx-macroexpand (form env) (macroexpand form env)) @@ -1081,7 +2903,24 @@ ;;; Utilities (defun getenv (name) - (cdr (assoc name ext:*environment-list* :test #'string=))) + #+excl (sys:getenv name) + #+lcl3.0 (lcl:environment-variable name) + #+CMU (cdr (assoc name ext:*environment-list* :test #'string=)) + #+sbcl (sb-ext:posix-getenv name) + #+ecl (si:getenv name) + #+clisp (ext:getenv name) + #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil)) + +(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 + #+(or cmu sbcl) (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")) (defun homedir-file-pathname (name) (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) @@ -1100,7 +2939,8 @@ (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) - (homedir-file-pathname (concatenate 'string ".Xdefaults-" (machine-instance))))) + (homedir-file-pathname + (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. @@ -1110,6 +2950,50 @@ (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) +;;; this particular defaulting behaviour is typical to most Unices, I think +#+unix +(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 @@ -1129,6 +3013,41 @@ (setq *temp-gcontext-cache* nil) nil) +#+Genera +(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.))) ;;----------------------------------------------------------------------------- @@ -1146,7 +3065,30 @@ ;;; 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) + (type t object) + (clx-values t) + (special left-meta-keysym right-meta-keysym + left-super-keysym right-super-keysym + left-hyper-keysym right-hyper-keysym)) + (when (characterp object) + (when (logbitp (position :control +state-mask-vector+) state) + (setf (char-bit object :control) 1)) + (when (or (state-keysymp display state left-meta-keysym) + (state-keysymp display state right-meta-keysym)) + (setf (char-bit object :meta) 1)) + (when (or (state-keysymp display state left-super-keysym) + (state-keysymp display state right-super-keysym)) + (setf (char-bit object :super) 1)) + (when (or (state-keysymp display state left-hyper-keysym) + (state-keysymp display state right-hyper-keysym)) + (setf (char-bit object :hyper) 1))) + object) +#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) @@ -1178,25 +3120,31 @@ '(unsigned-byte 24)) (deftype pixarray-32-element-type () - '(unsigned-byte 32)) + #-(or Genera Minima) '(unsigned-byte 32) + #+(or Genera Minima) 'fixnum) (deftype pixarray-1 () - '(simple-array pixarray-1-element-type (* *))) + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-1-element-type (* *))) (deftype pixarray-4 () - '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *))) + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-4-element-type (* *))) (deftype pixarray-8 () - '(simple-array pixarray-8-element-type (* *))) + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-8-element-type (* *))) (deftype pixarray-16 () - '(simple-array pixarray-16-element-type (* *))) + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-16-element-type (* *))) (deftype pixarray-24 () - '(simple-array pixarray-24-element-type (* *))) + '(#+(or cmu sbcl) simple-array + #-(or cmu sbcl) array pixarray-24-element-type (* *))) (deftype pixarray-32 () - '(simple-array pixarray-32-element-type (* *))) + '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) @@ -1206,70 +3154,110 @@ ;;; WITH-UNDERLYING-SIMPLE-VECTOR -#+CMU +#+Genera +(defmacro with-underlying-simple-vector + ((variable element-type pixarray) &body body) + (let ((bits-per-element + (sys:array-bits-per-element + (symbol-value (sys:type-array-element-type element-type))))) + `(scl:stack-let ((,variable + (make-array + (index-ceiling + (index* (array-total-size ,pixarray) + (sys:array-element-size ,pixarray)) + ,bits-per-element) + :element-type ',element-type + :displaced-to ,pixarray))) + (declare (type (vector ,element-type) ,variable)) + ,@body))) + +#+lcl3.0 +(defmacro with-underlying-simple-vector + ((variable element-type pixarray) &body body) + `(let ((,variable (sys:underlying-simple-vector ,pixarray))) + (declare (type (simple-array ,element-type (*)) ,variable)) + ,@body)) + +#+excl +(defmacro with-underlying-simple-vector + ((variable element-type pixarray) &body body) + `(let ((,variable (cdr (excl::ah_data ,pixarray)))) + (declare (type (simple-array ,element-type (*)) ,variable)) + ,@body)) + +#+(or CMU sbcl) ;;; We do *NOT* support viewing an array as having a different element type. ;;; Element-type is ignored. ;;; (defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) + ((variable element-type pixarray) &body body) (declare (ignore element-type)) - `(lisp::with-array-data ((,variable ,pixarray) - (start) - (end)) - (declare (ignore start end)) - ,@body)) + `(#+cmu lisp::with-array-data #+sbcl sb-kernel:with-array-data + ((,variable ,pixarray) (start) (end)) + (declare (ignore start end)) + ,@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))) + (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) - (ldb (byte ,size ,position)(the card8 ,integer)))) + (#-Genera ldb #+Genera sys:%logldb + (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))) + (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it - `(dpb + `(#-Genera dpb #+Genera sys:%logdpb (the card8 ,byte) (byte 8 ,(incf count 8)) (the (unsigned-byte ,count) ,it)))) - `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) - + #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) + #+Genera 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))) + (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 - (ldb + (#-Genera ldb #+Genera sys:%logldb (byte 8 ,position) - (the (unsigned-byte ,integer-size) ,integer)))) + #-Genera (the (unsigned-byte ,integer-size) ,integer) + #+Genera ,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))) + (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 + (setq it `(#-Genera dpb #+Genera sys:%logdpb (the (unsigned-byte ,size) ,byte) (byte ,size ,(incf count size)) (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) +#+(or Genera lcl3.0 excl) +(defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) + +#+(or Genera lcl3.0 excl) +(defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) + ;;; 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 @@ -1301,15 +3289,256 @@ ;;; 2Ll 07-00 15-08 23-16 31-24 ;;; 4Ll 07-00 15-08 23-16 31-24 +#+(or Genera lcl3.0 excl) +(defconstant + *image-bit-ordering-table* + '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) + ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) + ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) + ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) + ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) + ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) + ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) + ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) + ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) + ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) + ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) + ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) + +#+(or Genera lcl3.0 excl) +(defun compute-image-byte-and-bit-ordering () + (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) + ;; First compute the ordering + (let ((ordering nil) + (a (make-array '(1 32) :element-type 'bit :initial-element 0))) + (dotimes (i 4) + (push (flet ((bitpos (a i n) + (declare (optimize (speed 3) (safety 0) (space 0))) + (declare (type (simple-array bit (* *)) a) + (type fixnum i n)) + (with-underlying-simple-vector (v (unsigned-byte 8) a) + (prog2 + (setf (aref v i) n) + (dotimes (i 32) + (unless (zerop (aref a 0 i)) + (return i))) + (setf (aref v i) 0))))) + (list (bitpos a i #b10000000) + (bitpos a i #b00000001))) + ordering)) + (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) + ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p + (let ((byte-and-bit-ordering + (second (assoc ordering *image-bit-ordering-table* + :test #'equal)))) + (unless byte-and-bit-ordering + (error "Couldn't determine image byte and bit ordering~@ + measured image ordering = ~A" + ordering)) + (values-list byte-and-bit-ordering)))) + +#+(or Genera lcl3.0 excl) +(multiple-value-setq + (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (compute-image-byte-and-bit-ordering)) ;;; 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. +;;; FIXME: though we have some #+sbcl -conditionalized routines in +;;; here, they would appear not to work, and so are commented out in +;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate +;;; whether the unoptimized routines are often used, and also whether +;;; speeding them up while maintaining correctness is possible. + ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s -#+(or CMU) +#+(or lcl3.0 excl) +(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y 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-1-element-type array) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (the array-index (mod (the fixnum (- x)) 8))) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (the fixnum (- (the fixnum (- width left-bits)) + right-bits))) + (middle-bytes (index-floor middle-bits 8))) + ((index>= y height)) + (declare (type array-index start y + left-bits right-bits middle-bytes) + (fixnum middle-bits)) + (cond ((< middle-bits 0) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-bits) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (array-row-major-index + array y (index+ left-bits middle-bits)))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref vector (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + ))))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type card16 x y 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-4-element-type array) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) + 2))) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) + (declare (type array-index start y + left-nibbles right-nibbles middle-nibbles middle-bytes)) + (unless (index-zerop left-nibbles) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-nibbles) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 4 4 byte)))) + ))) + t) + +#+(or Genera lcl3.0 excl CMU sbcl) (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) @@ -1340,7 +3569,22 @@ (aref buffer-bbuf (index+ i 2)))))))) t) -#+CMU +#+lispm +(defun fast-read-pixarray-using-bitblt + (bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) + (#+Genera sys:stack-let* #-Genera let* + ((dimensions (list (+ y height) + (floor (* padded-bytes-per-line 8) bits-per-pixel))) + (a (make-array + dimensions + :element-type (array-element-type pixarray) + :displaced-to bbuf + :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) + (sys:bitblt boole-1 width height a x y pixarray 0 0)) + t) + +#+(or CMU sbcl) (defun pixarray-element-size (pixarray) (let ((eltype (array-element-type pixarray))) (cond ((eq eltype 'bit) 1) @@ -1360,36 +3604,58 @@ (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) - (lisp::with-array-data ((sdata source) - (sstart) - (send)) - (declare (ignore send)) - (lisp::with-array-data ((ddata dest) - (dstart) - (dend)) - (declare (ignore dend)) - (assert (and (zerop sstart) (zerop dstart))) - (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits) - sx (index* sy source-width)) - (index+ src-idx source-width)) - (dest-idx (index+ (* vm:vector-data-offset vm: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)) - (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) - -#+CMU + #.(declare-buffun) + (lisp::with-array-data ((sdata source) + (sstart) + (send)) + (declare (ignore send)) + (lisp::with-array-data ((ddata dest) + (dstart) + (dend)) + (declare (ignore dend)) + (assert (and (zerop sstart) (zerop dstart))) + (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) + sx (index* sy source-width)) + (index+ src-idx source-width)) + (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl 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)) + (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) + + +#+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))))) + +#+(or CMU 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 vm:byte-bits) - (index* boffset vm:byte-bits) 0 + (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 @@ -1397,6 +3663,51 @@ (index* width bits-per-pixel)) t) +#+(or Genera lcl3.0 excl) +(defun fast-read-pixarray-with-swap + (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)) + (unless (index= bits-per-pixel 24) + (let ((pixarray-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (x-bits (index* x bits-per-pixel))) + (declare (type array-index pixarray-padded-bits-per-line x-bits)) + (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod x-bits 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod x-bits +image-unit+)))) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p + +image-unit+ *computed-image-byte-lsb-first-p* + *computed-image-bit-lsb-first-p*) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (with-underlying-simple-vector (dst card8 pixarray) + (funcall + (symbol-function image-swap-function) bbuf dst + (index+ boffset + (index* y padded-bytes-per-line) + (index-floor x-bits 8)) + 0 (index-ceiling (index* width bits-per-pixel) 8) + padded-bytes-per-line + (index-floor pixarray-padded-bits-per-line 8) + height image-swap-lsb-first-p))) + t)))) + (defun fast-read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel @@ -1412,9 +3723,30 @@ (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 + #+(or Genera lcl3.0 excl) + (fast-read-pixarray-with-swap + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function - (or (and (index= (pixarray-element-size pixarray) bits-per-pixel) + (or #+lispm + (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bytes-per-line 4)) + (zerop (index-mod + (* #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1) + bits-per-pixel) + 32)) + #'fast-read-pixarray-using-bitblt) + #+(or CMU) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-read-pixarray-using-bitblt) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 1) + #'fast-read-pixarray-1) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 4) + #'fast-read-pixarray-4) + #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-read-pixarray-24)))) (when function @@ -1422,11 +3754,115 @@ 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*))))) + +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) +#+(or lcl3.0 excl) +(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y 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-1-element-type array) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-bits middle-bits + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (array-row-major-index + array y (index+ start-x middle-bits)))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (if (index> right-bits 1) + (aref vector (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref vector (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref vector (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref vector (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref vector (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref vector (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)) + (aref vector (index+ x 2)) + (aref vector (index+ x 3)) + (aref vector (index+ x 4)) + (aref vector (index+ x 5)) + (aref vector (index+ x 6)) + (aref vector (index+ x 7)))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 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-4-element-type array) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-nibbles middle-nibbles + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)))))))) + t) + +#+(or Genera lcl3.0 excl 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) @@ -1459,7 +3895,22 @@ (write-image-load-byte 16 pixel 24))))))) t) -#+CMU +#+lispm +(defun fast-write-pixarray-using-bitblt + (bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) + (#+Genera sys:stack-let* #-Genera let* + ((dimensions (list (+ y height) + (floor (* padded-bytes-per-line 8) bits-per-pixel))) + (a (make-array + dimensions + :element-type (array-element-type pixarray) + :displaced-to bbuf + :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) + (sys:bitblt boole-1 width height pixarray x y a 0 0)) + t) + +#+(or CMU sbcl) (defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) @@ -1468,12 +3919,56 @@ (index* (array-dimension pixarray 1) bits-per-pixel) x y bbuf - (index* padded-bytes-per-line vm:byte-bits) - (index* boffset vm:byte-bits) 0 + (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) +#+(or Genera lcl3.0 excl) +(defun fast-write-pixarray-with-swap + (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)) + (unless (index= bits-per-pixel 24) + (let ((pixarray-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (pixarray-start-bit-offset + (index* (array-row-major-index pixarray y x) + bits-per-pixel))) + (declare (type array-index pixarray-padded-bits-per-line + pixarray-start-bit-offset)) + (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod pixarray-start-bit-offset 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + +image-unit+ *computed-image-byte-lsb-first-p* + *computed-image-bit-lsb-first-p* + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (with-underlying-simple-vector (src card8 pixarray) + (funcall + (symbol-function image-swap-function) + src bbuf (index-floor pixarray-start-bit-offset 8) boffset + (index-ceiling (index* width bits-per-pixel) 8) + (index-floor pixarray-padded-bits-per-line 8) + padded-bytes-per-line height image-swap-lsb-first-p)) + 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) @@ -1487,16 +3982,37 @@ (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 + #+(or Genera lcl3.0 excl) + (fast-write-pixarray-with-swap + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function - (or (and (index= (pixarray-element-size pixarray) bits-per-pixel) + (or #+lispm + (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bytes-per-line 4)) + (zerop (index-mod + (* #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1) + bits-per-pixel) + 32)) #'fast-write-pixarray-using-bitblt) + #+(or CMU) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-write-pixarray-using-bitblt) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 1) + #'fast-write-pixarray-1) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 4) + #'fast-write-pixarray-4) + #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-write-pixarray-24)))) (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* + +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 @@ -1506,19 +4022,95 @@ (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) - (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))) - (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)) + (or + #+(or lispm CMU) + (let* ((pixarray-padded-pixels-per-line + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel)) + (copy-padded-pixels-per-line + #+Genera (sys:array-row-span copy) + #-Genera (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)) + + #+(or lcl3.0 excl) + (unless (index= bits-per-pixel 24) + (let ((pixarray-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (copy-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index copy 1 0) + (array-row-major-index copy 0 0)) + bits-per-pixel))) + (pixarray-start-bit-offset + (index* (array-row-major-index pixarray y x) + bits-per-pixel))) + (declare (type array-index pixarray-padded-bits-per-line + copy-padded-bits-per-line pixarray-start-bit-offset)) + (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod copy-padded-bits-per-line 8)) + (index-zerop (index-mod pixarray-start-bit-offset 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) + (with-underlying-simple-vector (src card8 pixarray) + (with-underlying-simple-vector (dst card8 copy) + (image-noswap + src dst + (index-floor pixarray-start-bit-offset 8) 0 + (index-ceiling (index* width bits-per-pixel) 8) + (index-floor pixarray-padded-bits-per-line 8) + (index-floor copy-padded-bits-per-line 8) + height nil))) + t))) + #+(or lcl3.0 excl) + (macrolet + ((copy (type element-type) + `(let ((pixarray pixarray) + (copy copy)) + (declare (type ,type pixarray copy)) + #.(declare-buffun) + (with-underlying-simple-vector (src ,element-type pixarray) + (with-underlying-simple-vector (dst ,element-type copy) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-idx (array-row-major-index copy dst-y 0) + (index1+ dst-idx)) + (dst-end (index+ dst-idx width)) + (src-idx (array-row-major-index pixarray src-y x) + (index1+ src-idx))) + ((index>= dst-idx dst-end)) + (declare (type array-index dst-idx src-idx dst-end)) + (setf (aref dst dst-idx) + (the ,element-type (aref src src-idx)))))))))) + (ecase bits-per-pixel + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))) t))) diff --git a/clx/display.lisp b/clx/display.lisp index 4a2937ee8..5cf54a991 100644 --- a/clx/display.lisp +++ b/clx/display.lisp @@ -17,101 +17,121 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/display.lisp,v 1.12 2004/08/13 12:24:30 emarsden Exp $") +(ext:file-comment "$Id: display.lisp,v 1.13 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) -;;; X11 Authorization: to prevent malicious users from snooping on an +;;; Authorizaton + +(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1")) + +;;; X11 Authorization: to prevent malicious users from snooping on a ;;; display, X servers may require connection requests to be ;;; authorized. The X server (or display manager) will create a random ;;; key on startup, and store it as an entry in a file generally named -;;; $HOME/.Xauthority (see the function AUTHORITY-PATHNAME). Clients -;;; must extract from this file the "magic cookie" that corresponds to -;;; the server they wish to connect to, and send it as authorization -;;; data when opening the display. -;;; -;;; Users can manipulate the contents of their .Xauthority file using -;;; the xauth command. -;;; -;;; The function GET-BEST-AUTHORIZATION is responsible for parsing the -;;; .Xauthority file and extracting the cookie for DISPLAY on HOST. -;;; The HOST argument is the hostname of the target display as a -;;; string, and DISPLAY is a number. The PROTOCOL argument determines -;;; whether the server connection is using an Internet protocol -;;; (values of :tcp or :internet) or a non-network protocol such as -;;; Unix domain sockets (value of :unix). GET-BEST-AUTHORITY returns -;;; two strings: an authorization name (very likely the string -;;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as -;;; fixnums in a vector. If the function fails to find an appropriate -;;; cookie, it returns two empty strings. -;;; +;;; $HOME/.Xauthority (see xauth(1) and the AUTHORITY-PATHNAME +;;; function). Clients must extract from this file the "magic cookie" +;;; that corresponds to the server they wish to connect to, and send +;;; it as authorization data when opening the display. + ;;; The format of the .Xauthority file is documented in the XFree ;;; sources, in the file xc/lib/Xau/README. -(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1")) +;;; Stolen from the cmucl sources, with patches by Hannu Rummukainen and +;;; Scott Fahlman. -(defun get-best-authorization (host display protocol) +(defun read-xauth-entry (stream) (labels ((read-short (stream &optional (eof-errorp t)) - (let ((high-byte (read-byte stream eof-errorp))) - (and high-byte - (dpb high-byte (byte 8 8) (read-byte stream))))) - (read-short-length-string (stream) - (let ((length (read-short stream))) - (let ((string (make-string length))) - (dotimes (k length) - (setf (schar string k) (card8->char (read-byte stream)))) - string))) - (read-short-length-vector (stream) - (let ((length (read-short stream))) - (let ((vector (make-array length :element-type '(unsigned-byte 8)))) - (dotimes (k length) - (setf (aref vector k) (read-byte stream))) - vector)))) - (let ((pathname (authority-pathname))) - (when pathname - (with-open-file (stream pathname :element-type '(unsigned-byte 8) - :if-does-not-exist nil) - (when stream - (let* ((host-family (ecase protocol - ((:tcp :internet nil) 0) - ((:dna :DECnet) 1) - ((:chaos) 2) - ((:unix) 256))) - (host-address (if (eq protocol :unix) - (map 'list #'char-int (machine-instance)) - (rest (host-address host host-family)))) - (best-name nil) - (best-data nil)) - ;; Check for the localhost address, in which case we're - ;; really FamilyLocal. - (when (and (= host-family 0) - (equal host-address '(127 0 0 1))) - (setq host-address (map 'list #'char-int (machine-instance))) - (setq host-family 256)) - (loop - (let ((family (read-short stream nil))) - (when (null family) - (return)) - (let* ((address (read-short-length-vector stream)) - (number (parse-integer (read-short-length-string stream))) - (name (read-short-length-string stream)) - (data (read-short-length-vector stream))) - (when (and (= family host-family) - (equal host-address (coerce address 'list)) - (= number display) - (let ((pos1 (position name *known-authorizations* :test #'string=))) - (and pos1 - (or (null best-name) - (< pos1 (position best-name *known-authorizations* - :test #'string=)))))) - (setf best-name name) - (setf best-data data))))) - (when best-name - (return-from get-best-authorization - (values best-name best-data))))))))) - (values "" "")) + (let ((high-byte (read-byte stream eof-errorp))) + (and high-byte + (dpb high-byte (byte 8 8) (read-byte stream))))) + (read-short-length-string (stream) + (let ((length (read-short stream))) + (let ((string (make-string length))) + (dotimes (k length) + (setf (schar string k) (card8->char (read-byte stream)))) + string))) + (read-short-length-vector (stream) + (let ((length (read-short stream))) + (let ((vector (make-array length + :element-type '(unsigned-byte 8)))) + (dotimes (k length) + (setf (aref vector k) (read-byte stream))) + vector)))) + (let ((family-id (read-short stream nil))) + (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))) + (name (read-short-length-string stream)) + (data (read-short-length-vector stream)) + (family (car (rassoc family-id *protocol-families*)))) + (unless family + (return-from read-xauth-entry + ;; we return FAMILY-ID to signal to + ;; GET-BEST-AUTHORIZATION that we haven't finished + ;; with the stream. + (list family-id nil nil nil nil))) + (let ((address + (case family + (:local (map 'string #'code-char address-data)) + (:internet (coerce address-data 'list)) + ;; FIXME: we can probably afford not to support + ;; :DECNET or :CHAOSNET in this modern age, but + ;; :INTERNET6 probably deserve support. -- CSR, + ;; 2005-08-07 + (t nil)))) + ;; if ADDRESS is NIL by this time, we will never match + ;; the address of DISPLAY. + (list family address number name data))))))) + +(defun get-best-authorization (host display protocol) + ;; parse .Xauthority, extract the cookie for DISPLAY on HOST. + ;; PROTOCOL determines whether the server connection is using an + ;; Internet protocol (value of :internet) or a non-network + ;; protocol such as Unix domain sockets (value of :local). Returns + ;; two strings: an authorization name (very likely the string + ;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as + ;; fixnums in a vector. If we fail to find an appropriate cookie, + ;; return two empty strings. + (let ((pathname (authority-pathname))) + (when pathname + (with-open-file (stream pathname :element-type '(unsigned-byte 8) + :if-does-not-exist nil) + (when stream + (let* ((host-address (and (eql protocol :internet) + (rest (host-address host protocol)))) + (best-name nil) (best-pos nil) + (best-data nil)) + ;; Check for the localhost address, in which case we're + ;; really FamilyLocal. + (when (or (eql protocol :local) + (and (eql protocol :internet) + (equal host-address '(127 0 0 1)))) + (setq host-address (get-host-name)) + (setq protocol :local)) + (loop + (destructuring-bind (family address number name data) + (read-xauth-entry stream) + (unless family (return)) + (when (and (eql family protocol) + (equal host-address address) + (= number display) + (let ((pos1 (position name *known-authorizations* + :test #'string=))) + (and pos1 + (or (null best-pos) + (< pos1 best-pos))))) + (setf best-name name + best-pos (position name *known-authorizations* + :test #'string=) + best-data data)))) + (when best-name + (return-from get-best-authorization + (values best-name best-data))))))) + (values "" ""))) ;; ;; Resource id management @@ -138,7 +158,7 @@ (defmacro allocate-resource-id (display object type) ;; Allocate a resource-id for OBJECT in DISPLAY - (if (member (eval type) *clx-cached-types*) + (if (member (eval type) +clx-cached-types+) `(let ((id (funcall (display-xid ,display) ,display))) (save-id ,display id ,object) id) @@ -146,7 +166,7 @@ (defmacro deallocate-resource-id (display id type) ;; Deallocate a resource-id for OBJECT in DISPLAY - (when (member (eval type) *clx-cached-types*) + (when (member (eval type) +clx-cached-types+) `(deallocate-resource-id-internal ,display ,id))) (defun deallocate-resource-id-internal (display id) @@ -175,19 +195,19 @@ (declare (type display display) (type resource-id id)) (declare (clx-values ,type)) - ,(if (member type *clx-cached-types*) + ,(if (member type +clx-cached-types+) `(let ((,type (lookup-resource-id display id))) (cond ((null ,type) ;; Not found, create and save it. (setq ,type (,(xintern 'make- type) :display display :id id)) (save-id display id ,type)) ;; Found. Check the type - ,(cond ((null *type-check?*) + ,(cond ((null +type-check?+) `(t ,type)) ((member type '(window pixmap)) `((type? ,type 'drawable) ,type)) (t `((type? ,type ',type) ,type))) - ,@(when *type-check?* + ,@(when +type-check?+ `((t (x-error 'lookup-error :id id :display display @@ -235,9 +255,9 @@ (defsetf atom-id set-atom-id) (defun initialize-predefined-atoms (display) - (dotimes (i (length *predefined-atoms*)) + (dotimes (i (length +predefined-atoms+)) (declare (type resource-id i)) - (setf (atom-id (svref *predefined-atoms* i) display) i))) + (setf (atom-id (svref +predefined-atoms+ i) display) i))) (defun visual-info (display visual-id) (declare (type display display) @@ -261,15 +281,17 @@ ;; (defmacro with-display ((display &key timeout inline) &body body) - ;; This macro is for use in a multi-process environment. It provides exclusive - ;; access to the local display object for multiple request generation. It need not - ;; provide immediate exclusive access for replies; that is, if another process is - ;; waiting for a reply (while not in a with-display), then synchronization need not - ;; (but can) occur immediately. Except where noted, all routines effectively - ;; contain an implicit with-display where needed, so that correct synchronization - ;; is always provided at the interface level on a per-call basis. Nested uses of - ;; this macro will work correctly. This macro does not prevent concurrent event - ;; processing; see with-event-queue. + ;; This macro is for use in a multi-process environment. It + ;; provides exclusive access to the local display object for + ;; multiple request generation. It need not provide immediate + ;; exclusive access for replies; that is, if another process is + ;; waiting for a reply (while not in a with-display), then + ;; synchronization need not (but can) occur immediately. Except + ;; where noted, all routines effectively contain an implicit + ;; with-display where needed, so that correct synchronization is + ;; always provided at the interface level on a per-call basis. + ;; Nested uses of this macro will work correctly. This macro does + ;; not prevent concurrent event processing; see with-event-queue. `(with-buffer (,display ,@(and timeout `(:timeout ,timeout)) ,@(and inline `(:inline ,inline))) @@ -285,6 +307,7 @@ ,@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.)) @@ -300,7 +323,12 @@ (declare (type display display) (type (or null number) timeout) (type function function) - (dynamic-extent 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)) (with-event-queue (display :timeout timeout :inline t) (funcall function))) @@ -312,37 +340,49 @@ ,@(and timeout `(:timeout ,timeout))) ,@body)))) -(defun open-display (host &key (display 0) (protocol :tcp) authorization-name authorization-data) - ;; Implementation specific routine to setup the buffer for a specific host and display. - ;; This must interface with the local network facilities, and will probably do special - ;; things to circumvent the network when displaying on the local host. +(defun open-default-display (&optional display-name) + "Open a connection to DISPLAY-NAME if supplied, or to the appropriate +default display as given by GET-DEFAULT-DISPLAY otherwise. + +OPEN-DISPLAY-NAME always attempts to do display authorization. The +hostname is resolved to an address, then authorization data for the +(protocol, host-address, displaynumber) triple is looked up in the +file given by AUTHORITY_PATHNAME (typically $HOME/.Xauthority). If +the protocol is :local, or if the hostname resolves to the local host, +authority data for the local machine's actual hostname - as returned by +gethostname(3) - is used instead." + (destructuring-bind (host display screen protocol) + (get-default-display display-name) + (let ((display (open-display host :display display :protocol protocol))) + (setf (display-default-screen display) (nth screen (display-roots display))) + display))) + +(defun open-display (host &key (display 0) protocol authorization-name authorization-data) + ;; Implementation specific routine to setup the buffer for a + ;; specific host and display. This must interface with the local + ;; network facilities, and will probably do special things to + ;; circumvent the nework when displaying on the local host. ;; ;; A string must be acceptable as a host, but otherwise the possible types ;; for host and protocol are not constrained, and will likely be very - ;; system dependent. The default protocol is system specific. + ;; system dependent. The default protocol is system specific. Authorization, + ;; if any, is assumed to come from the environment somehow. (declare (type integer display)) (declare (clx-values display)) - ;; If the HOST argument is empty (for instance the $DISPLAY environment variable was - ;; ":0") or if it is the special case of "unix", we connect to the X server using - ;; the :unix protocol. This is the most efficient transport to the local host, most - ;; often a Unix-domain socket. In this case, X11 does not store authorization data - ;; under the name "localhost", since that would make it impossible to store - ;; authorization data for concurrent X11 sessions on different hosts in the same - ;; $XAUTHORITY file. Rather, the authorization data is stored under the local host's - ;; hostname. - (let ((auth-host host)) - (when (or (equal host "") (equal host "unix")) - (setf protocol :unix) - (setf auth-host (machine-instance))) - ;; If no authorization data was specified by the user, attempt to extract - ;; authorization data from the environment. + + (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 auth-host display protocol))) - ;; PROTOCOL is the network protocol used to connect to the server - ;; (either :TCP or :UNIX). + (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 + (disp (make-buffer *output-buffer-size* #'make-display-internal :host host :display display :output-stream stream :input-stream stream)) (ok-p nil)) @@ -356,9 +396,14 @@ (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))) + disp)) + ) + (defun display-force-output (display) ; Output is normally buffered, this forces any buffered output to the server. @@ -374,10 +419,10 @@ (defun display-connect (display &key authorization-name authorization-data) (with-buffer-output (display :sizes (8 16)) (card8-put - 0 - (ecase (display-byte-order display) - (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First - (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First + 0 + (ecase (display-byte-order display) + (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First + (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First (card16-put 2 *protocol-major-version*) (card16-put 4 *protocol-minor-version*) (card16-put 6 (length authorization-name)) @@ -392,112 +437,112 @@ (let ((reply-buffer nil)) (declare (type (or null reply-buffer) reply-buffer)) (unwind-protect - (progn - (setq reply-buffer (allocate-reply-buffer #x1000)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (buffer-input display buffer-bbuf 0 8) - (let ((success (boolean-get 0)) - (reason-length (card8-get 1)) - (major-version (card16-get 2)) - (minor-version (card16-get 4)) - (total-length (card16-get 6)) - vendor-length - num-roots - num-formats) - (declare (ignore total-length)) - (unless success - (x-error 'connection-failure - :major-version major-version - :minor-version minor-version - :host (display-host display) - :display (display-display display) - :reason - (progn (buffer-input display buffer-bbuf 0 reason-length) - (string-get reason-length 0 :reply-buffer reply-buffer)))) - (buffer-input display buffer-bbuf 0 32) - (setf (display-protocol-major-version display) major-version) - (setf (display-protocol-minor-version display) minor-version) - (setf (display-release-number display) (card32-get 0)) - (setf (display-resource-id-base display) (card32-get 4)) - (setf (display-resource-id-mask display) (card32-get 8)) - (setf (display-motion-buffer-size display) (card32-get 12)) - (setq vendor-length (card16-get 16)) - (setf (display-max-request-length display) (card16-get 18)) - (setq num-roots (card8-get 20)) - (setq num-formats (card8-get 21)) - ;; Get the image-info - (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) - (let ((format (display-bitmap-format display))) - (declare (type bitmap-format format)) - (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) - (setf (bitmap-format-unit format) (card8-get 24)) - (setf (bitmap-format-pad format) (card8-get 25))) - (setf (display-min-keycode display) (card8-get 26)) - (setf (display-max-keycode display) (card8-get 27)) - ;; 4 bytes unused - ;; Get the vendor string - (buffer-input display buffer-bbuf 0 (lround vendor-length)) - (setf (display-vendor-name display) - (string-get vendor-length 0 :reply-buffer reply-buffer)) - ;; Initialize the pixmap formats - (dotimes (i num-formats) ;; loop gathering pixmap formats - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 8) - (push (make-pixmap-format :depth (card8-get 0) - :bits-per-pixel (card8-get 1) - :scanline-pad (card8-get 2)) - ; 5 unused bytes - (display-pixmap-formats display))) - (setf (display-pixmap-formats display) - (nreverse (display-pixmap-formats display))) - ;; Initialize the screens - (dotimes (i num-roots) - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 40) - (let* ((root-id (card32-get 0)) - (root (make-window :id root-id :display display)) - (root-visual (card32-get 32)) - (default-colormap-id (card32-get 4)) - (default-colormap + (progn + (setq reply-buffer (allocate-reply-buffer #x1000)) + (with-buffer-input (reply-buffer :sizes (8 16 32)) + (buffer-input display buffer-bbuf 0 8) + (let ((success (boolean-get 0)) + (reason-length (card8-get 1)) + (major-version (card16-get 2)) + (minor-version (card16-get 4)) + (total-length (card16-get 6)) + vendor-length + num-roots + num-formats) + (declare (ignore total-length)) + (unless success + (x-error 'connection-failure + :major-version major-version + :minor-version minor-version + :host (display-host display) + :display (display-display display) + :reason + (progn (buffer-input display buffer-bbuf 0 reason-length) + (string-get reason-length 0 :reply-buffer reply-buffer)))) + (buffer-input display buffer-bbuf 0 32) + (setf (display-protocol-major-version display) major-version) + (setf (display-protocol-minor-version display) minor-version) + (setf (display-release-number display) (card32-get 0)) + (setf (display-resource-id-base display) (card32-get 4)) + (setf (display-resource-id-mask display) (card32-get 8)) + (setf (display-motion-buffer-size display) (card32-get 12)) + (setq vendor-length (card16-get 16)) + (setf (display-max-request-length display) (card16-get 18)) + (setq num-roots (card8-get 20)) + (setq num-formats (card8-get 21)) + ;; Get the image-info + (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) + (let ((format (display-bitmap-format display))) + (declare (type bitmap-format format)) + (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) + (setf (bitmap-format-unit format) (card8-get 24)) + (setf (bitmap-format-pad format) (card8-get 25))) + (setf (display-min-keycode display) (card8-get 26)) + (setf (display-max-keycode display) (card8-get 27)) + ;; 4 bytes unused + ;; Get the vendor string + (buffer-input display buffer-bbuf 0 (lround vendor-length)) + (setf (display-vendor-name display) + (string-get vendor-length 0 :reply-buffer reply-buffer)) + ;; Initialize the pixmap formats + (dotimes (i num-formats) ;; loop gathering pixmap formats + (declare (ignorable i)) + (buffer-input display buffer-bbuf 0 8) + (push (make-pixmap-format :depth (card8-get 0) + :bits-per-pixel (card8-get 1) + :scanline-pad (card8-get 2)) + ; 5 unused bytes + (display-pixmap-formats display))) + (setf (display-pixmap-formats display) + (nreverse (display-pixmap-formats display))) + ;; Initialize the screens + (dotimes (i num-roots) + (declare (ignorable i)) + (buffer-input display buffer-bbuf 0 40) + (let* ((root-id (card32-get 0)) + (root (make-window :id root-id :display display)) + (root-visual (card32-get 32)) + (default-colormap-id (card32-get 4)) + (default-colormap (make-colormap :id default-colormap-id :display display)) - (screen + (screen (make-screen - :root root - :default-colormap default-colormap - :white-pixel (card32-get 8) - :black-pixel (card32-get 12) - :event-mask-at-open (card32-get 16) - :width (card16-get 20) - :height (card16-get 22) - :width-in-millimeters (card16-get 24) - :height-in-millimeters (card16-get 26) - :min-installed-maps (card16-get 28) - :max-installed-maps (card16-get 30) - :backing-stores (member8-get 36 :never :when-mapped :always) - :save-unders-p (boolean-get 37) - :root-depth (card8-get 38))) - (num-depths (card8-get 39)) - (depths nil)) - ;; Save root window for event reporting - (save-id display root-id root) - (save-id display default-colormap-id default-colormap) - ;; Create the depth AList for a screen, (depth . visual-infos) - (dotimes (j num-depths) - (declare (ignorable j)) - (buffer-input display buffer-bbuf 0 8) - (let ((depth (card8-get 0)) - (num-visuals (card16-get 2)) - (visuals nil)) ;; 4 bytes unused - (dotimes (k num-visuals) - (declare (ignorable k)) - (buffer-input display buffer-bbuf 0 24) - (let* ((visual (card32-get 0)) - (visual-info (make-visual-info + :root root + :default-colormap default-colormap + :white-pixel (card32-get 8) + :black-pixel (card32-get 12) + :event-mask-at-open (card32-get 16) + :width (card16-get 20) + :height (card16-get 22) + :width-in-millimeters (card16-get 24) + :height-in-millimeters (card16-get 26) + :min-installed-maps (card16-get 28) + :max-installed-maps (card16-get 30) + :backing-stores (member8-get 36 :never :when-mapped :always) + :save-unders-p (boolean-get 37) + :root-depth (card8-get 38))) + (num-depths (card8-get 39)) + (depths nil)) + ;; Save root window for event reporting + (save-id display root-id root) + (save-id display default-colormap-id default-colormap) + ;; Create the depth AList for a screen, (depth . visual-infos) + (dotimes (j num-depths) + (declare (ignorable j)) + (buffer-input display buffer-bbuf 0 8) + (let ((depth (card8-get 0)) + (num-visuals (card16-get 2)) + (visuals nil)) ;; 4 bytes unused + (dotimes (k num-visuals) + (declare (ignorable k)) + (buffer-input display buffer-bbuf 0 24) + (let* ((visual (card32-get 0)) + (visual-info (make-visual-info :id visual :display display :class (member8-get 4 :static-gray :gray-scale - :static-color :pseudo-color - :true-color :direct-color) + :static-color :pseudo-color + :true-color :direct-color) :bits-per-rgb (card8-get 5) :colormap-entries (card16-get 6) :red-mask (card32-get 8) @@ -505,16 +550,16 @@ :blue-mask (card32-get 16) ;; 4 bytes unused ))) - (push visual-info visuals) - (when (funcall (resource-id-map-test) root-visual visual) - (setf (screen-root-visual-info screen) - (setf (colormap-visual-info default-colormap) - visual-info))))) - (push (cons depth (nreverse visuals)) depths))) - (setf (screen-depths screen) (nreverse depths)) - (push screen (display-roots display)))) - (setf (display-roots display) (nreverse (display-roots display))) - (setf (display-default-screen display) (first (display-roots display)))))) + (push visual-info visuals) + (when (funcall (resource-id-map-test) root-visual visual) + (setf (screen-root-visual-info screen) + (setf (colormap-visual-info default-colormap) + visual-info))))) + (push (cons depth (nreverse visuals)) depths))) + (setf (screen-depths screen) (nreverse depths)) + (push screen (display-roots display)))) + (setf (display-roots display) (nreverse (display-roots display))) + (setf (display-default-screen display) (first (display-roots display)))))) (when reply-buffer (deallocate-reply-buffer reply-buffer)))) display) @@ -537,13 +582,14 @@ #+comment ;; defined by the DISPLAY defstruct (defsetf display-error-handler (display) (handler) - ;; All errors (synchronous and asynchronous) are processed by calling an error - ;; handler in the display. If handler is a sequence it is expected to contain - ;; handler functions specific to each error; the error code is used to index the - ;; sequence, fetching the appropriate handler. Any results returned by the handler - ;; are ignored; it is assumed the handler either takes care of the error - ;; completely, or else signals. For all core errors, the keyword/value argument - ;; pairs are: + ;; All errors (synchronous and asynchronous) are processed by + ;; calling an error handler in the display. If handler is a + ;; sequence it is expected to contain handler functions specific to + ;; each error; the error code is used to index the sequence, + ;; fetching the appropriate handler. Any results returned by the + ;; handler are ignored; it is assumed the handler either takes care + ;; of the error completely, or else signals. For all core errors, + ;; the keyword/value argument pairs are: ;; :display display ;; :error-key error-key ;; :major integer @@ -560,11 +606,12 @@ ) ;; setf'able - ;; If defined, called after every protocol request is generated, even those inside - ;; explicit with-display's, but never called from inside the after-function itself. - ;; The function is called inside the effective with-display for the associated - ;; request. Default value is nil. Can be set, for example, to - ;; #'display-force-output or #'display-finish-output. + ;; If defined, called after every protocol request is generated, + ;; even those inside explicit with-display's, but never called from + ;; inside the after-function itself. The function is called inside + ;; the effective with-display for the associated request. Default + ;; value is nil. Can be set, for example, to #'display-force-output + ;; or #'display-finish-output. (defvar *inside-display-after-function* nil) @@ -580,7 +627,7 @@ ;; Forces output, then causes a round-trip to ensure that all possible ;; errors and events have been received. (declare (type display display)) - (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32)) + (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) () ) ;; Report asynchronous errors here if the user wants us to. diff --git a/clx/dpms.lisp b/clx/dpms.lisp new file mode 100644 index 000000000..1413b7ddb --- /dev/null +++ b/clx/dpms.lisp @@ -0,0 +1,171 @@ + +;;;; Original Author: Matthew Kennedy <mkennedy@gentoo.org> +;;;; +;;;; Documentation strings derived from DPMS.txt distributed with the Xorg X11 +;;;; server implementation. DPMS.txt contains the following copyright: +;;;; +;;;; Copyright (C) Digital Equipment Corporation, 1996 +;;;; +;;;; Permission to use, copy, modify, distribute, and sell this documentation +;;;; for any purpose is hereby granted without fee, provided that the above +;;;; copyright notice and this permission notice appear in all copies. Digital +;;;; Equipment Corporation makes no representations about the suitability for +;;;; any purpose of the information in this document. This documentation is +;;;; provided ``as is'' without express or implied warranty. + +#+cmu +(ext:file-comment "$Id") + +(defpackage :dpms + (:use :common-lisp) + (:import-from :xlib + "DEFINE-EXTENSION" + "DISPLAY" + "WITH-BUFFER-REQUEST-AND-REPLY" + "WITH-BUFFER-REQUEST" + "EXTENSION-OPCODE" + "CARD8-GET" + "CARD16-GET" + "BOOLEAN-GET" + "CARD8" + "CARD16" + "DATA") + (:export "DPMS-GET-VERSION" + "DPMS-CAPABLE" + "DPMS-GET-TIMEOUTS" + "DPMS-SET-TIMEOUTS" + "DPMS-ENABLE" + "DPMS-DISABLE" + "DPMS-FORCE-LEVEL" + "DPMS-INFO")) + +(in-package :dpms) + +(define-extension "DPMS") + +(defmacro dpms-opcode (display) + `(extension-opcode ,display "DPMS")) + +(defconstant +get-version+ 0) +(defconstant +capable+ 1) +(defconstant +get-timeouts+ 2) +(defconstant +set-timeouts+ 3) +(defconstant +enable+ 4) +(defconstant +disable+ 5) +(defconstant +force-level+ 6) +(defconstant +info+ 7) + +(defun dpms-get-version (display &optional (major-version 1) (minor-version 1)) + "Return two values: the major and minor version of the DPMS +implementation the server supports. + +If supplied, the MAJOR-VERSION and MINOR-VERSION indicate what +version of the protocol the client wants the server to implement." + (declare (type display display)) + (with-buffer-request-and-reply (display (dpms-opcode display) nil) + ((data +get-version+) + (card16 major-version) + (card16 minor-version)) + (values (card16-get 8) + (card16-get 10)))) + +(defun dpms-capable (display) + "True if the currently running server's devices are capable of +DPMS operations. + +The truth value of this request is implementation defined, but is +generally based on the capabilities of the graphic card and +monitor combination. Also, the return value in the case of +heterogeneous multi-head servers is implementation defined." + (declare (type display display)) + (with-buffer-request-and-reply (display (dpms-opcode display) nil) + ((data +capable+)) + (boolean-get 8))) + +(defun dpms-get-timeouts (display) + "Return three values: the current values of the DPMS timeout +values. The timeout values are (in order returned): standby, +suspend and off. All values are in units of seconds. A value of +zero for any timeout value indicates that the mode is disabled." + (declare (type display display)) + (with-buffer-request-and-reply (display (dpms-opcode display) nil) + ((data +get-timeouts+)) + (values (card16-get 8) + (card16-get 10) + (card16-get 12)))) + +(defun dpms-set-timeouts (display standby suspend off) + "Set the values of the DPMS timeouts. All values are in units +of seconds. A value of zero for any timeout value disables that +mode." + (declare (type display display)) + (with-buffer-request (display (dpms-opcode display)) + (data +set-timeouts+) + (card16 standby) + (card16 suspend) + (card16 off) + (card16 0)) ;unused + (values)) + +(defun dpms-enable (display) + "Enable the DPMS characteristics of the server using the +server's currently stored timeouts. If DPMS is already enabled, +no change is affected." + (declare (type display display)) + (with-buffer-request (display (dpms-opcode display)) + (data +enable+)) + (values)) + +(defun dpms-disable (display) + "Disable the DPMS characteristics of the server. It does not +affect the core or extension screen savers. If DPMS is already +disabled, no change is effected. + +This request is provided so that DPMS may be disabled without +damaging the server's stored timeout values." + (declare (type display display)) + (with-buffer-request (display (dpms-opcode display)) + ((data +disable+))) + (values)) + +(defun dpms-force-level (display power-level) + "Forces a specific DPMS level on the server. Valid keyword +values for POWER-LEVEL are: DPMS-MODE-ON, DPMS-MODE-STANDBY, +DPMS-MODE-SUSPEND and DPMS-MODE-OFF." + (declare (type display display)) + (with-buffer-request (display (dpms-opcode display)) + (data +force-level+) + (card16 (ecase power-level + (:dpms-mode-on 0) + (:dpms-mode-standby 1) + (:dpms-mode-suspend 2) + (:dpms-mode-off 3))) + (card16 0)) ;unused + (values)) + +(defun dpms-info (display) + "Returns two valus: the DPMS power-level and state value for the display. + +State is one of the keywords DPMS-ENABLED or DPMS-DISABLED. + +If state is DPMS-ENABLED, then power level is returned as one of +the keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND +or DPMS-MODE-OFF. If state is DPMS-DISABLED, then power-level is +undefined and returned as NIL." + (declare (type display display)) + (with-buffer-request-and-reply (display (dpms-opcode display) nil) + ((data +info+)) + (let ((state (if (boolean-get 10) + :dpms-enabled + :dpms-disabled))) + (values (unless (eq state :dpms-disabled) + (ecase (card16-get 8) + (0 :dpms-mode-on) + (1 :dpms-mode-standby) + (2 :dpms-mode-suspend) + (3 :dpms-mode-off))) + state)))) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; End: diff --git a/clx/exclMakefile b/clx/exclMakefile new file mode 100644 index 000000000..3890d23a4 --- /dev/null +++ b/clx/exclMakefile @@ -0,0 +1,170 @@ +# +# Makefile for CLX +# (X11 R4.4 release, Franz Allegro Common Lisp version) +# +# $Id: exclMakefile,v 1.4 2007/08/21 15:49:28 fgilham Exp $ +# + +# ************************************************************************* +# * Change the next line to point to where you have Common Lisp installed * +# * (make sure the Lisp doesn't already have CLX loaded in) * +# ************************************************************************* +CL = /usr/local/bin/cl + +RM = /bin/rm +SHELL = /bin/sh +ECHO = /bin/echo +TAGS = /usr/local/lib/emacs/etc/etags + +# Name of dumped lisp +CLX = CLX + +CLOPTS = -qq + +# Use this one for Suns +CFLAGS = -O -DUNIXCONN +# Use this one for Silicon Graphics & Mips Inc MIPS based machines +# CFLAGS = -O -G 0 -I/usr/include/bsd +# Use this one for DEC MIPS based machines +# CFLAGS = -O -G 0 -DUNIXCONN +# Use this one for HP machines +# CFLAGS = -O -DSYSV -DUNIXCONN + + +# Lisp optimization for compiling +SPEED = 3 +SAFETY = 0 + + +C_SRC = excldep.c socket.c +C_OBJS = excldep.o socket.o + +L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \ + dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \ + display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \ + graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \ + manager.fasl image.fasl resource.fasl + +L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx.fasl \ + dependent.fasl buffer.fasl display.fasl gcontext.fasl \ + requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \ + attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \ + resource.fasl + +L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \ + dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \ + display.cl gcontext.cl requests.cl input.cl fonts.cl \ + graphics.cl text.cl attributes.cl translate.cl keysyms.cl \ + manager.cl image.cl resource.cl + +# default and aliases +all: no-clos +# all: partial-clos +compile-CLX-for-CLUE: compile-partial-clos-CLX +clue: partial-clos + +# +# Three build rules are provided: no-clos, partial-clos, and full-clos. +# The first is no-clos, which results in a CLX whose datastructures are +# all defstructs. partial-clos results in xlib:window, xlib:pixmap, and +# xlib:drawable being CLOS instances, all others defstructs. full-clos +# makes all CLX complex datatypes into CLOS instances. +# +# (note that the :clos feature implies native CLOS *not* PCL). +# + +no-clos: $(C_OBJS) compile-no-clos-CLX cat + +# +# This rule is used to compile CLX to be used with XCW version 2, or CLUE. +# +partial-clos: $(C_OBJS) compile-partial-clos-CLX cat + +full-clos: $(C_OBJS) compile-full-clos-CLX cat + + +c: $(C_OBJS) + + +compile-no-clos-CLX: $(C_OBJS) + $(ECHO) " \ + (set-case-mode :case-sensitive-lower) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ + (load \"defsystem\") \ + #+allegro (compile-system :clx) \ + #-allegro (compile-clx) \ + #+allegro (compile-system :clx-debug)" \ + | $(CL) $(CLOPTS) -batch + +compile-partial-clos-CLX: $(C_OBJS) + $(ECHO) " \ + #+clos (set-case-mode :case-sensitive-lower) \ + #-clos (setq excl::*print-nickname* t) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (unless (or (find-package 'clos) (find-package 'pcl)) \ + (let ((spread (sys:gsgc-parameter :generation-spread))) \ + (setf (sys:gsgc-parameter :generation-spread) 1) \ + (require :pcl) \ + (provide :pcl) \ + (gc) (gc) \ + (setf (sys:gsgc-parameter :generation-spread) spread))) \ + #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ + (load \"defsystem\") \ + (load \"package\") \ + (setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \ + #+allegro (compile-system :clx) \ + #-allegro (compile-clx \"\" \"\" :for-clue t) \ + #+allegro (compile-system :clx-debug)" \ + | $(CL) $(CLOPTS) -batch + +compile-full-clos-CLX: $(C_OBJS) + $(ECHO) " \ + #+clos (set-case-mode :case-sensitive-lower) \ + #-clos (setq excl::*print-nickname* t) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (unless (or (find-package 'clos) (find-package 'pcl)) \ + (let ((spread (sys:gsgc-parameter :generation-spread))) \ + (setf (sys:gsgc-parameter :generation-spread) 1) \ + (require :pcl) \ + (provide :pcl) \ + (gc) (gc) \ + (setf (sys:gsgc-parameter :generation-spread) spread))) \ + #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ + (load \"defsystem\") \ + (load \"package\") \ + (setq xlib::*def-clx-class-use-defclass* t) \ + #+allegro (compile-system :clx) \ + #-allegro (compile-clx \"\" \"\" :for-clue t) \ + #+allegro (compile-system :clx-debug)" \ + | $(CL) $(CLOPTS) -batch + + +cat: + -cat $(L_NOMACROS_OBJS) > CLX.fasl + + +load-CLX: + $(ECHO) " \ + (let ((spread (sys:gsgc-parameter :generation-spread))) \ + (setf (sys:gsgc-parameter :generation-spread) 1) \ + (load \"defsystem\") \ + #+allegro (load-system :clx) \ + #-allegro (load-clx) \ + (gc :tenure) \ + (setf (sys:gsgc-parameter :generation-spread) spread)) \ + (gc t)" \ + '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ + "(exit)" | $(CL) $(CLOPTS) + +clean: + $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out + + +install: + mv CLX.fasl $(DEST)/clx.fasl + mv *.o $(DEST) + + +tags: + $(TAGS) $(L_SRC) $(C_SRC) diff --git a/clx/exclREADME b/clx/exclREADME new file mode 100644 index 000000000..2ecd2b9b0 --- /dev/null +++ b/clx/exclREADME @@ -0,0 +1,58 @@ +$Id: exclREADME,v 1.4 2007/08/21 15:49:28 fgilham Exp $ + + This file contains instructions on how to make CLX work with Franz +Common Lisp. CLX should work on any machine that supports Allegro Common +Lisp version 3.0.1 or greater. It also works under ExCL version 2.0.10. +However it has been tested extensively with only Allegro CL versions 3.0, +3.1, and 4.0. + + There are three steps to compile and install CLX. The first is simply +moving files around. In this directory, execute (assuming you using csh): + +% foreach i (*.l */*.l) +? mv $i $i:r.cl +? end +% mv exclMakefile Makefile + + The second is compiling the source files into fasl files. The fasl files +will be combined into one big fasl file, CLX.fasl. This file is then installed +in your Common Lisp library directory in the next step. You may need to edit +the Makefile to select the proper CFLAGS for your machine -- look in Makefile +for examples. Then just: + +% make + + Now you must move the CLX.fasl file into the standard CL library. +This is normally "/usr/local/lib/cl/code", but you can find out for sure +by typing: + +<cl> (directory-namestring excl::*library-code-pathname*) + +to a running Lisp. If it prints something other than "/usr/local/lib/cl/code" +substitute what it prints in the below instructions. + +% mv CLX.fasl /usr/local/lib/cl/code/clx.fasl +% mv *.o /usr/local/lib/cl/code + +Now you can just start up Lisp and type: + +<cl> (load "clx") + +to load in CLX. You may want to dump a lisp at this point since CLX is a large +package and can take some time to load into Lisp. You probably also want to +set the :generation-spread to 1 while loading CLX. Please see your Allegro CL +User Guide for more information on :generation-spread. + + + Sophisticated users may wish to peruse the Makefile and defsystem.cl +and note how things are set up. For example we hardwire the compiler +interrupt check switch on, so that CL can still be interrupted while it +is reading from the X11 socket. Please see chapter 7 of the CL User's +guide for more information on compiler switches and their effects. + + +Please report Franz specific CLX bugs to: + + ucbvax!franz!bugs + or + bugs@Franz.COM diff --git a/clx/excldefsys.lisp b/clx/excldefsys.lisp new file mode 100644 index 000000000..379c4f971 --- /dev/null +++ b/clx/excldefsys.lisp @@ -0,0 +1,189 @@ +;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- +;;; +;;; Copyright (c) 1988, 1989 Franz Inc, Berkeley, Ca. +;;; +;;; Permission is granted to any individual or institution to use, copy, +;;; modify, and distribute this software, provided that this complete +;;; copyright and permission notice is maintained, intact, in all copies and +;;; supporting documentation. +;;; +;;; Franz Incorporated provides this software "as is" without express or +;;; implied warranty. +;;; + +#+cmu +(ext:file-comment "$Id") + +(in-package :xlib :use '(:foreign-functions :lisp :excl)) + +#+allegro +(require :defsystem "defsys") + +(eval-when (load) + (require :clxexcldep "excldep")) + +;; +;; The following is a suggestion. If you comment out this form be +;; prepared for possible deadlock, since no interrupts will be recognized +;; while reading from the X socket if the scheduler is not running. +;; +(setq compiler::generate-interrupt-checks-switch + (compile nil '(lambda (safety size speed) + (declare (ignore size)) + (or (< speed 3) (> safety 0))))) + + +#+allegro +(excl:defsystem :clx + () + |depdefs| + (|clx| :load-before-compile (|depdefs|) + :recompile-on (|depdefs|)) + (|dependent| :load-before-compile (|depdefs| |clx|) + :recompile-on (|clx|)) + (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|) + :recompile-on (|dependent|)) + (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|) + :recompile-on (|exclcmac|)) + (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros|) + :recompile-on (|macros|)) + (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac|) + :recompile-on (|bufmac|)) + (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer|) + :recompile-on (|buffer|)) + (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) + (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) + (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display| |input|) + :recompile-on (|display|)) + (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) + (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display| |fonts|) + :recompile-on (|fonts|)) + (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| + |bufmac| |buffer| |display| + |gcontext| |fonts|) + :recompile-on (|gcontext| |fonts|) + :load-after (|translate|)) + ;; The above line gets around a compiler macro expansion bug. + + (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) + (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display| |text|) + :recompile-on (|display|)) + (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display| |translate|) + :recompile-on (|translate|)) + (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) + (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) + + ;; Don't know if l-b-c list is correct. XX + (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) + ) + +#+allegro +(excl:defsystem :clx-debug + (:default-pathname "debug/" + :needed-systems (:clx) + :load-before-compile (:clx)) + |describe| |keytrans| |trace| |util|) + + +(defun compile-clx (&optional pathname-defaults) + (let ((*default-pathname-defaults* + (or pathname-defaults *default-pathname-defaults*))) + (declare (special *default-pathname-defaults*)) + (compile-file "depdefs") + (load "depdefs") + (compile-file "clx") + (load "clx") + (compile-file "dependent") + (load "dependent") + (compile-file "macros") + (load "macros") + (compile-file "bufmac") + (load "bufmac") + (compile-file "buffer") + (load "buffer") + (compile-file "display") + (load "display") + (compile-file "gcontext") + (load "gcontext") + (compile-file "input") + (load "input") + (compile-file "requests") + (load "requests") + (compile-file "fonts") + (load "fonts") + (compile-file "graphics") + (load "graphics") + (compile-file "text") + (load "text") + (compile-file "attributes") + (load "attributes") + (load "translate") + (compile-file "translate") ; work-around bug in 2.0 and 2.2 + (load "translate") + (compile-file "keysyms") + (load "keysyms") + (compile-file "manager") + (load "manager") + (compile-file "image") + (load "image") + (compile-file "resource") + (load "resource") + )) + + +(defun load-clx (&optional pathname-defaults) + (let ((*default-pathname-defaults* + (or pathname-defaults *default-pathname-defaults*))) + (declare (special *default-pathname-defaults*)) + (load "depdefs") + (load "clx") + (load "dependent") + (load "macros") + (load "bufmac") + (load "buffer") + (load "display") + (load "gcontext") + (load "input") + (load "requests") + (load "fonts") + (load "graphics") + (load "text") + (load "attributes") + (load "translate") + (load "keysyms") + (load "manager") + (load "image") + (load "resource") + )) diff --git a/clx/excldep.c b/clx/excldep.c new file mode 100644 index 000000000..5b96a44d2 --- /dev/null +++ b/clx/excldep.c @@ -0,0 +1,77 @@ +/* + * Allegro CL dependent C helper routines for CLX + */ + +/* + * $Id: excldep.c,v 1.3 2007/08/21 15:49:28 fgilham Exp $ + */ + +/* + * This code requires select and interval timers. + * This means you probably need BSD, or a version + * of Unix with select and interval timers added. + */ + +#include <sys/types.h> +#include <sys/errno.h> +#include <sys/time.h> +#include <stdio.h> + +#define ERROR -1 +#define INTERRUPT -2 +#define TIMEOUT 0 +#define SUCCESS 1 + +#ifdef FD_SETSIZE +#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ +#else +#define NUMBER_OF_FDS 32 +#endif + +/* Length of array needed to hold all file descriptor bits */ +#define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int))) + +extern int errno; + +/* + * This function waits for input to become available on 'fd'. If timeout is + * 0, wait forever. Otherwise wait 'timeout' seconds. If input becomes + * available before the timer expires, return SUCCESS. If the timer expires + * return TIMEOUT. If an error occurs, return ERROR. If an interrupt occurs + * while waiting, return INTERRUPT. + */ +int fd_wait_for_input(fd, timeout) + register int fd; + register int timeout; +{ + struct timeval timer; + register int i; + int checkfds[CHECKLEN]; + + if (fd < 0 || fd >= NUMBER_OF_FDS) { + fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); + fflush(stderr); + } + + for (i = 0; i < CHECKLEN; i++) + checkfds[i] = 0; + checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); + + if (timeout) { + timer.tv_sec = timeout; + timer.tv_usec = 0; + i = select(32, checkfds, (int *)0, (int *)0, &timer); + } else + i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); + + if (i < 0) + /* error condition */ + if (errno == EINTR) + return (INTERRUPT); + else + return (ERROR); + else if (i == 0) + return (TIMEOUT); + else + return (SUCCESS); +} diff --git a/clx/excldep.lisp b/clx/excldep.lisp new file mode 100644 index 000000000..93ee776bc --- /dev/null +++ b/clx/excldep.lisp @@ -0,0 +1,438 @@ +;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- +;;; +;;; CLX -- excldep.cl +;;; +;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca. +;;; +;;; Permission is granted to any individual or institution to use, copy, +;;; modify, and distribute this software, provided that this complete +;;; copyright and permission notice is maintained, intact, in all copies and +;;; supporting documentation. +;;; +;;; Franz Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +#+cmu +(ext:file-comment "$Id: excldep.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $") + +(in-package :xlib) + +(eval-when (compile load eval) + (require :foreign) + (require :process) ; Needed even if scheduler is not + ; running. (Must be able to make + ; a process-lock.) + ) + +(eval-when (load) + (provide :clx)) + + +#-(or little-endian big-endian) +(eval-when (eval compile load) + (let ((x '#(1))) + (if (not (eq 0 (sys::memref x + #.(sys::mdparam 'comp::md-lvector-data0-norm) + 0 :unsigned-byte))) + (pushnew :little-endian *features*) + (pushnew :big-endian *features*)))) + + +(defmacro correct-case (string) + ;; This macro converts the given string to the + ;; current preferred case, or leaves it alone in a case-sensitive mode. + (let ((str (gensym))) + `(let ((,str ,string)) + (case excl::*current-case-mode* + (:case-insensitive-lower + (string-downcase ,str)) + (:case-insensitive-upper + (string-upcase ,str)) + ((:case-sensitive-lower :case-sensitive-upper) + ,str))))) + + +(defconstant type-pred-alist + '(#-(version>= 4 1 devel 16) + (card8 . card8p) + #-(version>= 4 1 devel 16) + (card16 . card16p) + #-(version>= 4 1 devel 16) + (card29 . card29p) + #-(version>= 4 1 devel 16) + (card32 . card32p) + #-(version>= 4 1 devel 16) + (int8 . int8p) + #-(version>= 4 1 devel 16) + (int16 . int16p) + #-(version>= 4 1 devel 16) + (int32 . int32p) + #-(version>= 4 1 devel 16) + (mask16 . card16p) + #-(version>= 4 1 devel 16) + (mask32 . card32p) + #-(version>= 4 1 devel 16) + (pixel . card32p) + #-(version>= 4 1 devel 16) + (resource-id . card29p) + #-(version>= 4 1 devel 16) + (keysym . card32p) + (angle . anglep) + (color . color-p) + (bitmap-format . bitmap-format-p) + (pixmap-format . pixmap-format-p) + (display . display-p) + (drawable . drawable-p) + (window . window-p) + (pixmap . pixmap-p) + (visual-info . visual-info-p) + (colormap . colormap-p) + (cursor . cursor-p) + (gcontext . gcontext-p) + (screen . screen-p) + (font . font-p) + (image-x . image-x-p) + (image-xy . image-xy-p) + (image-z . image-z-p) + (wm-hints . wm-hints-p) + (wm-size-hints . wm-size-hints-p) + )) + +;; This (if (and ...) t nil) stuff has a purpose -- it lets the old +;; sun4 compiler opencode the `and'. + +#-(version>= 4 1 devel 16) +(defun card8p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun card16p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun card29p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) + (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) + (>= (the bignum x) 0))) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun card32p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) + (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) + (>= (the bignum x) 0))) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun int8p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun int16p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun int32p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (excl:fixnump x) + (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) + (>= (the bignum x) #.(expt -2 31)))) + t + nil)) + +;; This one can be handled better by knowing a little about what we're +;; testing for. Plus this version can handle (single-float pi), which +;; is otherwise larger than pi! +(defun anglep (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) + (<= (the fixnum x) #.(truncate (* 2 pi)))) + (and (excl::single-float-p x) + (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) + (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) + (and (excl::double-float-p x) + (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) + (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) + t + nil)) + +(eval-when (load eval) + #+(version>= 4 1 devel 16) + (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) + type-pred-alist) + #-(version>= 4 1 devel 16) + (nconc excl::type-pred-alist type-pred-alist)) + + +;; Return t if there is a character available for reading or on error, +;; otherwise return nil. +#-(version>= 6 0) +(progn + +#-(or (version>= 4 2) mswindows) +(defun fd-char-avail-p (fd) + (multiple-value-bind (available-p errcode) + (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd) + (excl:if* errcode + then t + else available-p))) + +#+(and (version>= 4 2) (not mswindows)) +(defun fd-char-avail-p (fd) + (excl::filesys-character-available-p fd)) + +#+mswindows +(defun fd-char-avail-p (socket-stream) + (listen socket-stream)) +) + +#+(version>= 6 0) +(defun fd-char-avail-p (socket-stream) + (excl::read-no-hang-p socket-stream)) + +(defmacro with-interrupt-checking-on (&body body) + `(locally (declare (optimize (safety 1))) + ,@body)) + +;; Read from the given fd into 'vector', which has element type card8. +;; Start storing at index 'start-index' and read exactly 'length' bytes. +;; Return t if an error or eof occurred, nil otherwise. +(defun fd-read-bytes (fd vector start-index length) + ;; Read from the given stream fd into 'vector', which has element type card8. + ;; Start storing at index 'start-index' and read exactly 'length' bytes. + ;; Return t if an error or eof occurred, nil otherwise. + (declare (fixnum next-index start-index length)) + (with-interrupt-checking-on + (let ((end-index (+ start-index length))) + (loop + (let ((next-index (excl:read-vector vector fd + :start start-index + :end end-index))) + (excl:if* (eq next-index start-index) + then ; end of file before was all filled up + (return t) + elseif (eq next-index end-index) + then ; we're all done + (return nil) + else (setq start-index next-index))))))) + + +;; special patch for CLX (various process fixes) +;; patch1000.2 + +(eval-when (compile load eval) + (unless (find-package :patch) + (make-package :patch :use '(:lisp :excl)))) + +(in-package :patch) + +(defvar *patches* nil) + +#+allegro +(eval-when (compile eval load) + (when (and (= excl::cl-major-version-number 3) + (or (= excl::cl-minor-version-number 0) + (and (= excl::cl-minor-version-number 1) + excl::cl-generation-number + (< excl::cl-generation-number 9)))) + (push :clx-r4-process-patches *features*))) + +#+clx-r4-process-patches +(push (cons 1000.2 "special patch for CLX (various process fixes)") + *patches*) + + +(in-package :mp) + +#+clx-r4-process-patches +(export 'wait-for-input-available) + + +#+clx-r4-process-patches +(defun with-timeout-event (seconds fnc args) + (unless *scheduler-stack-group* (start-scheduler)) ;[spr670] + (let ((clock-event (make-clock-event))) + (when (<= seconds 0) (setq seconds 0)) + (multiple-value-bind (secs msecs) (truncate seconds) + ;; secs is now a nonegative integer, and msecs is either fixnum zero + ;; or else something interesting. + (unless (eq 0 msecs) + (setq msecs (truncate (* 1000.0 msecs)))) + ;; Now msecs is also a nonnegative fixnum. + (multiple-value-bind (now mnow) (excl::cl-internal-real-time) + (incf secs now) + (incf msecs mnow) + (when (>= msecs 1000) + (decf msecs 1000) + (incf secs)) + (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) + (setf (clock-event-secs clock-event) secs + (clock-event-msecs clock-event) msecs + (clock-event-function clock-event) fnc + (clock-event-args clock-event) args))) + clock-event)) + + +#+clx-r4-process-patches +(defmacro with-timeout ((seconds &body timeout-body) &body body) + `(let* ((clock-event (with-timeout-event ,seconds + #'process-interrupt + (cons *current-process* + '(with-timeout-internal)))) + (excl::*without-interrupts* t) + ret) + (unwind-protect + ;; Warning: Branch tensioner better not reorder this code! + (setq ret (catch 'with-timeout-internal + (add-to-clock-queue clock-event) + (let ((excl::*without-interrupts* nil)) + (multiple-value-list (progn ,@body))))) + (excl:if* (eq ret 'with-timeout-internal) + then (let ((excl::*without-interrupts* nil)) + (setq ret (multiple-value-list (progn ,@timeout-body)))) + else (remove-from-clock-queue clock-event))) + (values-list ret))) + + +#+clx-r4-process-patches +(defun process-lock (lock &optional (lock-value *current-process*) + (whostate "Lock") timeout) + (declare (optimize (speed 3))) + (unless (process-lock-p lock) + (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock)) + (without-interrupts + (excl:if* (null (process-lock-locker lock)) + then (setf (process-lock-locker lock) lock-value) + else (excl:if* timeout + then (excl:if* (or (eq 0 timeout) ;for speed + (zerop timeout)) + then nil + else (with-timeout (timeout) + (process-lock-1 lock lock-value whostate))) + else (process-lock-1 lock lock-value whostate))))) + + +#+clx-r4-process-patches +(defun process-lock-1 (lock lock-value whostate) + (declare (type process-lock lock) + (optimize (speed 3))) + (let ((process *current-process*)) + (declare (type process process)) + (unless process + (error + "PROCESS-LOCK may not be called on the scheduler's stack group.")) + (loop (unless (process-lock-locker lock) + (return (setf (process-lock-locker lock) lock-value))) + (push process (process-lock-waiting lock)) + (let ((saved-whostate (process-whostate process))) + (unwind-protect + (progn (setf (process-whostate process) whostate) + (process-add-arrest-reason process lock)) + (setf (process-whostate process) saved-whostate)))))) + + +#+clx-r4-process-patches +(defun process-wait (whostate function &rest args) + (declare (optimize (speed 3))) + ;; Run the wait function once here both for efficiency and as a + ;; first line check for errors in the function. + (unless (apply function args) + (process-wait-1 whostate function args))) + + +#+clx-r4-process-patches +(defun process-wait-1 (whostate function args) + (declare (optimize (speed 3))) + (let ((process *current-process*)) + (declare (type process process)) + (unless process + (error + "Process-wait may not be called within the scheduler's stack group.")) + (let ((saved-whostate (process-whostate process))) + (unwind-protect + (without-scheduling-internal + (without-interrupts + (setf (process-whostate process) whostate + (process-wait-function process) function + (process-wait-args process) args) + (chain-rem-q process) + (chain-ins-q process *waiting-processes*)) + (process-resume-scheduler nil)) + (setf (process-whostate process) saved-whostate + (process-wait-function process) nil + (process-wait-args process) nil))))) + + +#+clx-r4-process-patches +(defun process-wait-with-timeout (whostate seconds function &rest args) + ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh + ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code. + ;; -- 28Feb90 smh + ;; Run the wait function once here both for efficiency and as a + ;; first line check for errors in the function. + (excl:if* (apply function args) + then t + else (let ((ret (list nil))) + (without-interrupts + (let ((clock-event + (with-timeout-event seconds #'identity '(nil)))) + (add-to-clock-queue clock-event) + (process-wait-1 whostate + #'(lambda (clock-event function args ret) + (or (null (chain-next clock-event)) + (and (apply function args) + (setf (car ret) 't)))) + (list clock-event function args ret)))) + (car ret)))) + + +;; +;; Returns nil on timeout, otherwise t. +;; +#+clx-r4-process-patches +(defun wait-for-input-available + (stream-or-fd &key (wait-function #'listen) + (whostate "waiting for input") + timeout) + (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd + elseif (streamp stream-or-fd) + then (excl::stream-input-fn stream-or-fd) + else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) + ;; At this point fd could be nil, since stream-input-fn returns nil for + ;; streams that are output only, or for certain special purpose streams. + (if fd + (unwind-protect + (progn + (mp::mpwatchfor fd) + (excl:if* timeout + then (mp::process-wait-with-timeout + whostate timeout wait-function stream-or-fd) + else (mp::process-wait whostate wait-function stream-or-fd) + t)) + (mp::mpunwatchfor fd)) + (excl:if* timeout + then (mp::process-wait-with-timeout + whostate timeout wait-function stream-or-fd) + else (mp::process-wait whostate wait-function stream-or-fd) + t)))) diff --git a/clx/fonts.lisp b/clx/fonts.lisp index d8403ae53..5a84b6698 100644 --- a/clx/fonts.lisp +++ b/clx/fonts.lisp @@ -15,9 +15,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/fonts.lisp,v 1.5 1998/12/19 15:21:17 dtc Exp $") +(ext:file-comment "$Id: fonts.lisp,v 1.6 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) @@ -159,13 +159,15 @@ (setq font (make-font :display display :name name-string)) (setq font-id (allocate-resource-id display font 'font)) (setf (font-id-internal font) font-id) - (with-buffer-request (display *x-openfont*) + (with-buffer-request (display +x-openfont+) (resource-id font-id) (card16 (length name-string)) (pad16 nil) (string name-string)) (push font (display-font-cache display))) (incf (font-reference-count font)) + (unless (font-font-info-internal font) + (query-font font)) font)) (defun open-font-internal (font) @@ -176,7 +178,7 @@ (display (font-display font)) (id (allocate-resource-id display font 'font))) (setf (font-id-internal font) id) - (with-buffer-request (display *x-openfont*) + (with-buffer-request (display +x-openfont+) (resource-id id) (card16 (length name-string)) (pad16 nil) @@ -201,7 +203,7 @@ font-info props) (setq font-id (font-id font)) ;; May issue an open-font request - (with-buffer-request-and-reply (display *x-queryfont* 60) + (with-buffer-request-and-reply (display +x-queryfont+ 60) ((resource-id font-id)) (let* ((min-byte2 (card16-get 40)) (max-byte2 (card16-get 42)) @@ -252,7 +254,7 @@ ;; Remove font from cache (setf (display-font-cache display) (delete font (display-font-cache display))) ;; Close the font - (with-buffer-request (display *x-closefont*) + (with-buffer-request (display +x-closefont+) (resource-id id))))) (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) @@ -262,12 +264,12 @@ (type t result-type)) ;; CL type (declare (clx-values (clx-sequence string))) (let ((string (string pattern))) - (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16)) + (with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16)) ((card16 max-fonts (length string)) (string string)) (values (read-sequence-string - buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*))))) + buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))) (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) ;; Note: Was called list-fonts-with-info. @@ -283,7 +285,7 @@ (declare (clx-values (clx-sequence font))) (let ((string (string pattern)) (result nil)) - (with-buffer-request-and-reply (display *x-listfontswithinfo* 60 + (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60 :sizes (8 16) :multiple-reply t) ((card16 max-fonts (length string)) (string string)) @@ -334,11 +336,11 @@ (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence (or string pathname)))) - (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16)) + (with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16)) () (values (read-sequence-string - buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*)))) + buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))) (defun set-font-path (display paths) (declare (type display display) @@ -350,7 +352,7 @@ (let* ((string (string (elt paths i))) (len (length string))) (incf request-length (1+ len)))) - (with-buffer-request (display *x-setfontpath* :length request-length) + (with-buffer-request (display +x-setfontpath+ :length request-length) (length (ceiling request-length 4)) (card16 path-length) (pad16 nil) diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp index f4f6134b5..5039ae3fc 100644 --- a/clx/gcontext.lisp +++ b/clx/gcontext.lisp @@ -41,25 +41,24 @@ ;;; lisps will have problems. Fortunately, most other lisps don't care, ;;; because they don't run in a multi-processing shared-address space ;;; environment. + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/gcontext.lisp,v 1.7 2004/03/24 13:35:04 emarsden Exp $") +(ext:file-comment "$Id: gcontext.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) ;; GContext state accessors ;; The state vector contains all card32s to speed server updating -(eval-when (eval compile load) - -(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*)) +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant +gcontext-fast-change-length+ #.(length +gcontext-components+)) (macrolet ((def-gc-internals (name &rest extras) (let ((macros nil) (indexes nil) (masks nil) (index 0)) - (dolist (name *gcontext-components*) + (dolist (name +gcontext-components+) (push `(defmacro ,(xintern 'gcontext-internal- name) (state) `(svref ,state ,,index)) macros) @@ -75,37 +74,40 @@ (setf (getf indexes (or (second extra) (first extra))) index)) (push (logior (ash 1 index) (if (second extra) - (ash 1 (position (second extra) *gcontext-components*)) + (ash 1 (position (second extra) +gcontext-components+)) 0)) masks) (incf index)) `(within-definition (def-gc-internals ,name) ,@(nreverse macros) - (eval-when (eval compile load) - (defconstant *gcontext-data-length* ,index) - (defconstant *gcontext-indexes* ',indexes) - (defconstant *gcontext-masks* - ',(coerce (nreverse masks) 'simple-vector))))))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *gcontext-data-length* ,index) + (defvar *gcontext-indexes* ',indexes) + (defvar *gcontext-masks* + ',(coerce (nreverse masks) 'simple-vector) + )))))) (def-gc-internals ignore (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) ) ;; end EVAL-WHEN -(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*)) +(deftype gcmask () '(unsigned-byte #.+gcontext-fast-change-length+)) (deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*)) (defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named (name nil :type symbol :read-only t) (default nil :type t :read-only t) + ;; FIXME: these used to have glorious, but wrong, type declarations. + ;; See if we can't return them to their former glory. (set-function #'(lambda (gcontext value) (declare (ignore gcontext)) value) - :type (function (gcontext t) t) :read-only t) + :type (or function symbol) :read-only t) (copy-function #'(lambda (from-gc to-gc value) (declare (ignore from-gc to-gc)) value) - :type (function (gcontext gcontext t) t) :read-only t)) + :type (or function symbol) :read-only t)) (defvar *gcontext-extensions* nil) ;; list of gcontext-extension @@ -164,7 +166,7 @@ ;; Generate all the accessors and defsetf's for GContext (defmacro xgcmask->gcmask (mask) - `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*))))) + `(the gcmask (logand ,mask #.(1- (ash 1 +gcontext-fast-change-length+))))) (defmacro access-gcontext ((gcontext local-state) &body body) `(let ((,local-state (gcontext-local-state ,gcontext))) @@ -321,15 +323,12 @@ (declare (type gcontext gcontext) (type (or card8 sequence) dashes)) (multiple-value-bind (dashes dash) - (cond ((type? dashes 'sequence) - (if (zerop (length dashes)) - (x-type-error dashes '(or card8 sequence) "non-empty sequence") - (values nil (or (copy-seq dashes) (vector))))) - ((eql dashes 0) - (x-type-error dashes '(or card8 sequence) "non-zero card8")) - (t - (values (encode-type card8 dashes) nil))) - (modify-gcontext (gcontext local-state) + (if (type? dashes 'sequence) + (if (zerop (length dashes)) + (x-type-error dashes '(or card8 sequence) "non-empty sequence") + (values nil (or (copy-seq dashes) (vector)))) + (values (encode-type card8 dashes) nil)) + (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) (declare (type gcontext-state server-state)) (without-interrupts @@ -409,7 +408,7 @@ (block no-changes (let ((last-request (buffer-last-request display))) - (with-buffer-request (display *x-changegc*) + (with-buffer-request (display +x-changegc+) (gcontext gcontext) (progn (do ((i 0 (index+ i 1)) @@ -417,7 +416,7 @@ (nbyte 12) (mask 0) (local 0)) - ((index>= i *gcontext-fast-change-length*) + ((index>= i +gcontext-fast-change-length+) (when (zerop mask) ;; If nothing changed, restore last-request and quit (setf (buffer-last-request display) @@ -457,7 +456,7 @@ (unless (equalp local-clip server-clip) (setf (gcontext-internal-clip server-state) nil) (unless (null local-clip) - (with-buffer-request (display *x-setcliprectangles*) + (with-buffer-request (display +x-setcliprectangles+) (data (first local-clip)) (gcontext gcontext) ;; XXX treat nil correctly @@ -475,7 +474,7 @@ (unless (equalp local-dash server-dash) (setf (gcontext-internal-dash server-state) nil) (unless (null local-dash) - (with-buffer-request (display *x-setdashes*) + (with-buffer-request (display +x-setdashes+) (gcontext gcontext) ;; XXX treat nil correctly (card16 (or (gcontext-internal-dash-offset local-state) 0) @@ -607,13 +606,13 @@ (gcontext-server-state temp-gc) saved-state (gcontext-local-state temp-gc) saved-state) ;; Create a new (temporary) gcontext - (with-buffer-request (display *x-creategc*) + (with-buffer-request (display +x-creategc+) (gcontext temp-gc) (drawable (gcontext-drawable gcontext)) (card29 0)) ;; Copy changed components to the temporary gcontext (when (plusp temp-mask) - (with-buffer-request (display *x-copygc*) + (with-buffer-request (display +x-copygc+) (gcontext gcontext) (gcontext temp-gc) (card29 (xgcmask->gcmask temp-mask)))) @@ -636,7 +635,7 @@ (let ((display (gcontext-display gcontext))) (declare (type display display)) (with-display (display) - (with-buffer-request (display *x-copygc*) + (with-buffer-request (display +x-copygc+) (gcontext temp-gc) (gcontext gcontext) (card29 (xgcmask->gcmask temp-mask))) @@ -649,7 +648,7 @@ (let ((copy-function (gcontext-extension-copy-function (car extensions)))) (funcall copy-function temp-gc gcontext (svref local-state i)))) ;; free gcontext - (with-buffer-request (display *x-freegc*) + (with-buffer-request (display +x-freegc+) (gcontext temp-gc)) (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) (deallocate-temp-gcontext temp-gc) @@ -776,7 +775,7 @@ ;; No, mark local state "unmodified" 1)) - (with-buffer-request (display *x-creategc*) + (with-buffer-request (display +x-creategc+) (resource-id gcontextid) (drawable drawable) (progn (do* ((i 0 (index+ i 1)) @@ -784,7 +783,7 @@ (nbyte 16) (mask 0) (local (svref local-state i) (svref local-state i))) - ((index>= i *gcontext-fast-change-length*) + ((index>= i +gcontext-fast-change-length+) (card29-put 12 mask) (card16-put 2 (index-ash nbyte -2)) (index-incf (buffer-boffset display) nbyte)) @@ -846,12 +845,11 @@ (if i (setq mask (the xgcmask (logior mask (the xgcmask (svref *gcontext-masks* i))))) - (multiple-value-bind (extension index) - (find key *gcontext-extensions* :key #'gcontext-extension-name) + (let ((extension (find key *gcontext-extensions* :key #'gcontext-extension-name))) (if extension (funcall (gcontext-extension-copy-function extension) src dst (svref (gcontext-local-state src) - (index+ index *gcontext-data-length*))) + (index+ (position extension *gcontext-extensions*) *gcontext-data-length*))) (x-type-error key 'gcontext-key)))))) (when (plusp mask) @@ -869,14 +867,14 @@ (when (oddp bit) (setf (svref dst-local-state i) (setf (svref dst-server-state i) (svref src-server-state i))))) - (with-buffer-request (display *x-copygc*) + (with-buffer-request (display +x-copygc+) (gcontext src dst) (card29 (xgcmask->gcmask mask)))))))) (defun copy-gcontext (src dst) (declare (type gcontext src dst)) ;; Copies all components. - (apply #'copy-gcontext-components src dst *gcontext-components*) + (apply #'copy-gcontext-components src dst +gcontext-components+) (do ((extensions *gcontext-extensions* (cdr extensions)) (i *gcontext-data-length* (index+ i 1))) ((endp extensions)) @@ -886,7 +884,7 @@ (defun free-gcontext (gcontext) (declare (type gcontext gcontext)) (let ((display (gcontext-display gcontext))) - (with-buffer-request (display *x-freegc*) + (with-buffer-request (display +x-freegc+) (gcontext gcontext)) (deallocate-resource-id display (gcontext-id gcontext) 'gcontext) (deallocate-gcontext-state (gcontext-server-state gcontext)) @@ -911,7 +909,7 @@ (declare (type symbol name) (type t default) (type symbol set-function) ;; required - (type symbol copy-function)) + (type (or symbol list) copy-function)) (let* ((gc-name (intern (concatenate 'string (string 'gcontext-) (string name)))) ;; in current package @@ -928,7 +926,7 @@ (,set-function dst-gc value) (error "Can't copy unknown GContext component ~a" ',name))))) `(progn - (eval-when (compile load eval) + (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter ,internal-state-index (add-gcontext-extension ',key-name ,default ',internal-set-function ',internal-copy-function)) @@ -964,8 +962,8 @@ (defun add-gcontext-extension (name default-value set-function copy-function) (declare (type symbol name) (type t default-value) - (type (function (gcontext t) t) set-function) - (type (function (gcontext gcontext t) t) copy-function)) + (type (or function symbol) set-function) + (type (or function symbol) copy-function)) (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) (prog1 (length *gcontext-extensions*) (push nil *gcontext-extensions*))))) diff --git a/clx/generalock.lisp b/clx/generalock.lisp new file mode 100644 index 000000000..aa1a6fbe9 --- /dev/null +++ b/clx/generalock.lisp @@ -0,0 +1,75 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- + +;;; Copyright (C) 1990 Symbolics, Inc. +;;; +;;; 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. +;;; +;;; Symbolics, Inc. provides this software "as is" without +;;; express or implied warranty. + +#+cmu +(ext:file-comment "$Id: generalock.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $") + +(defflavor xlib::clx-lock () (simple-recursive-normal-lock) + (:init-keywords :flavor)) + +(defwhopper (lock-internal xlib::clx-lock) (lock-argument) + (catch 'timeout + (continue-whopper lock-argument))) + +(defmethod (lock-block-internal xlib::clx-lock) (lock-argument) + (declare (dbg:locking-function describe-process-lock-for-debugger self)) + (when (null waiter-queue) + (setf waiter-queue (make-scheduler-queue :name name)) + (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) + (let ((process (lock-argument-process lock-argument))) + (unwind-protect + (progn + (lock-map-over-conflicting-owners + self lock-argument + #'(lambda (other-lock-arg) + (add-promotion process lock-argument + (lock-argument-process other-lock-arg) other-lock-arg))) + (unless (timer-pending-p timer) + (when (and (safe-to-use-timers %real-current-process) + (not dbg:*debugger-might-have-system-problems*)) + (reset-timer-relative-timer-units timer *lock-timer-interval*))) + (assert (store-conditional (locf latch) process nil)) + (sys:with-aborts-enabled (lock-latch) + (let ((timeout (lock-argument-getf lock-argument :timeout nil))) + (cond ((null timeout) + (promotion-block waiter-queue name #'lock-lockable self lock-argument)) + ((and (plusp timeout) + (using-resource (timer process-block-timers) + ;; Yeah, we know about the internal representation + ;; of timers here. + (setf (car (timer-args timer)) %real-current-process) + (with-scheduler-locked + (reset-timer-relative timer timeout) + (flet ((lock-lockable-or-timeout (timer lock lock-argument) + (or (not (timer-pending-p timer)) + (lock-lockable lock lock-argument)))) + (let ((priority (process-process-priority *current-process*))) + (if (ldb-test %%scheduler-priority-preemption-field priority) + (promotion-block waiter-queue name + #'lock-lockable-or-timeout + timer self lock-argument) + ;; Change to preemptive priority so that when + ;; unlock-internal wakes us up so we can have the lock, + ;; we will really wake up right away + (with-process-priority + (dpb 1 %%scheduler-priority-preemption-field + priority) + (promotion-block waiter-queue name + #'lock-lockable-or-timeout + timer self lock-argument))))) + (lock-lockable self lock-argument))))) + (t (throw 'timeout nil)))))) + (unless (store-conditional (locf latch) nil process) + (lock-latch-wait-internal self)) + (remove-promotions process lock-argument)))) + +(compile-flavor-methods xlib::clx-lock) diff --git a/clx/gl.lisp b/clx/gl.lisp new file mode 100644 index 000000000..391af3f21 --- /dev/null +++ b/clx/gl.lisp @@ -0,0 +1,3695 @@ +#+cmu +(ext:file-comment "$Id: gl.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") + +(defpackage :gl + (:use :common-lisp :xlib) + (:import-from :glx + "*CURRENT-CONTEXT*" + "CONTEXT" + "CONTEXT-P" + "CONTEXT-DISPLAY" + "CONTEXT-TAG" + "CONTEXT-RBUF" + "CONTEXT-INDEX" + ) + (:import-from :xlib + "DATA" + "WITH-BUFFER-REQUEST" + "WITH-BUFFER-REQUEST-AND-REPLY" + "CARD32-GET" + "SEQUENCE-GET" + + "WITH-DISPLAY" + "DISPLAY-FORCE-OUTPUT" + + "INT8" "INT16" "INT32" "INTEGER" + "CARD8" "CARD16" "CARD32" + + "ASET-CARD8" + "ASET-CARD16" + "ASET-CARD32" + "ASET-INT8" + "ASET-INT16" + "ASET-INT32" + + "DECLARE-BUFFUN" + + ;; Types + "ARRAY-INDEX" + "BUFFER-BYTES" + ) + + (:export "GET-STRING" + + ;; Rendering commands (alphabetical order) + + "ACCUM" + "ACTIVE-TEXTURE-ARB" + "ALPHA-FUNC" + "BEGIN" + "BIND-TEXTURE" + "BLEND-COLOR" + "BLEND-EQUOTION" + "BLEND-FUNC" + "CALL-LIST" + "CLEAR" + "CLEAR-ACCUM" + "CLEAR-COLOR" + "CLEAR-DEPTH" + "CLEAR-INDEX" + "CLEAR-STENCIL" + "CLIP-PLANE" + "COLOR-3B" + "COLOR-3D" + "COLOR-3F" + "COLOR-3I" + "COLOR-3S" + "COLOR-3UB" + "COLOR-3UI" + "COLOR-3US" + "COLOR-4B" + "COLOR-4D" + "COLOR-4F" + "COLOR-4I" + "COLOR-4S" + "COLOR-4UB" + "COLOR-4UI" + "COLOR-4US" + "COLOR-MASK" + "COLOR-MATERIAL" + "CONVOLUTION-PARAMETER-F" + "CONVOLUTION-PARAMETER-I" + "COPY-COLOR-SUB-TABLE" + "COPY-COLOR-TABLE" + "COPY-CONVOLUTION-FILTER-ID" + "COPY-CONVOLUTION-FILTER-2D" + "COPY-PIXELS" + "COPY-TEX-IMAGE-1D" + "COPY-TEX-IMAGE-2D" + "COPY-TEX-SUB-IMAGE-1D" + "COPY-TEX-SUB-IMAGE-2D" + "COPY-TEX-SUB-IMAGE-3D" + "CULL-FACE" + "DEPTH-FUNC" + "DEPTH-MASK" + "DEPTH-RANGE" + "DRAW-BUFFER" + "EDGE-FLAG-V" + "END" + "EVAL-COORD-1D" + "EVAL-COORD-1F" + "EVAL-COORD-2D" + "EVAL-COORD-2F" + "EVAL-MESH-1" + "EVAL-MESH-2" + "EVAL-POINT-1" + "EVAL-POINT-2" + "FOG-F" + "FOG-I" + "FRONT-FACE" + "FRUSTUM" + "HINT" + "HISTOGRAM" + "INDEX-MASK" + "INDEX-D" + "INDEX-F" + "INDEX-I" + "INDEX-S" + "INDEX-UB" + "INIT-NAMES" + "LIGHT-MODEL-F" + "LIGHT-MODEL-I" + "LIGHT-F" + "LIGHT-FV" + "LIGHT-I" + "LIGHT-IV" + "LINE-STIPPLE" + "LINE-WIDTH" + "LIST-BASE" + "LOAD-IDENTITY" + "LOAD-NAME" + "LOGIC-OP" + "MAP-GRID-1D" + "MAP-GRID-1F" + "MAP-GRID-2D" + "MAP-GRID-2F" + "MATERIAL-F" + "MATERIAL-FV" + "MATERIAL-I" + "MATERIAL-IV" + "MATRIX-MODE" + "MINMAX" + "MULTI-TEX-COORD-1D-ARB" + "MULTI-TEX-COORD-1F-ARB" + "MULTI-TEX-COORD-1I-ARB" + "MULTI-TEX-COORD-1S-ARB" + "MULTI-TEX-COORD-2D-ARB" + "MULTI-TEX-COORD-2F-ARB" + "MULTI-TEX-COORD-2I-ARB" + "MULTI-TEX-COORD-2S-ARB" + "MULTI-TEX-COORD-3D-ARB" + "MULTI-TEX-COORD-3F-ARB" + "MULTI-TEX-COORD-3I-ARB" + "MULTI-TEX-COORD-3S-ARB" + "MULTI-TEX-COORD-4D-ARB" + "MULTI-TEX-COORD-4F-ARB" + "MULTI-TEX-COORD-4I-ARB" + "MULTI-TEX-COORD-4S-ARB" + "NORMAL-3B" + "NORMAL-3D" + "NORMAL-3F" + "NORMAL-3I" + "NORMAL-3S" + "ORTHO" + "PASS-THROUGH" + "PIXEL-TRANSFER-F" + "PIXEL-TRANSFER-I" + "PIXEL-ZOOM" + "POINT-SIZE" + "POLYGON-MODE" + "POLYGON-OFFSET" + "POP-ATTRIB" + "POP-MATRIX" + "POP-NAME" + "PUSH-ATTRIB" + "PUSH-MATRIX" + "PUSH-NAME" + "RASTER-POS-2D" + "RASTER-POS-2F" + "RASTER-POS-2I" + "RASTER-POS-2S" + "RASTER-POS-3D" + "RASTER-POS-3F" + "RASTER-POS-3I" + "RASTER-POS-3S" + "RASTER-POS-4D" + "RASTER-POS-4F" + "RASTER-POS-4I" + "RASTER-POS-4S" + "READ-BUFFER" + "RECT-D" + "RECT-F" + "RECT-I" + "RECT-S" + "RESET-HISTOGRAM" + "RESET-MINMAX" + "ROTATE-D" + "ROTATE-F" + "SCALE-D" + "SCALE-F" + "SCISSOR" + "SHADE-MODEL" + "STENCIL-FUNC" + "STENCIL-MASK" + "STENCIL-OP" + "TEX-ENV-F" + "TEX-ENV-I" + "TEX-GEN-D" + "TEX-GEN-F" + "TEX-GEN-I" + "TEX-PARAMETER-F" + "TEX-PARAMETER-I" + "TRANSLATE-D" + "TRANSLATE-F" + "VERTEX-2D" + "VERTEX-2F" + "VERTEX-2I" + "VERTEX-2S" + "VERTEX-3D" + "VERTEX-3F" + "VERTEX-3I" + "VERTEX-3S" + "VERTEX-4D" + "VERTEX-4F" + "VERTEX-4I" + "VERTEX-4S" + "VIEWPORT" + + ;; * Where did this come from? + ;;"NO-FLOATS" + + ;; Non-rendering commands + "NEW-LIST" + "END-LIST" + "GEN-LISTS" + "ENABLE" + "DISABLE" + "FLUSH" + "FINISH" + + ;; Constants + + ;; Boolean + + "+FALSE+" + "+TRUE+" + + ;; Types + + "+BYTE+" + "+UNSIGNED-BYTE+" + "+SHORT+" + "+UNSIGNED-SHORT+" + "+INT+" + "+UNSIGNED-INT+" + "+FLOAT+" + "+DOUBLE+" + "+2-BYTES+" + "+3-BYTES+" + "+4-BYTES+" + + ;; Primitives + + "+POINTS+" + "+LINES+" + "+LINE-LOOP+" + "+LINE-STRIP+" + "+TRIANGLES+" + "+TRIANGLE-STRIP+" + "+triangle-fan+" + "+QUADS+" + "+QUAD-STRIP+" + "+POLYGON+" + + ;; Arrays + + "+VERTEX-ARRAY+" + "+NORMAL-ARRAY+" + "+COLOR-ARRAY+" + "+INDEX-ARRAY+" + "+TEXTURE-COORD-ARRAY+" + "+EDGE-FLAG-ARRAY+" + "+VERTEX-ARRAY-SIZE+" + "+VERTEX-ARRAY-TYPE+" + "+VERTEX-ARRAY-STRIDE+" + "+NORMAL-ARRAY-TYPE+" + "+NORMAL-ARRAY-STRIDE+" + "+COLOR-ARRAY-SIZE+" + "+COLOR-ARRAY-TYPE+" + "+COLOR-ARRAY-STRIDE+" + "+INDEX-ARRAY-TYPE+" + "+INDEX-ARRAY-STRIDE+" + "+TEXTURE-COORD-ARRAY-SIZE+" + "+TEXTURE-COORD-ARRAY-TYPE+" + "+TEXTURE-COORD-ARRAY-STRIDE+" + "+EDGE-FLAG-ARRAY-STRIDE+" + "+VERTEX-ARRAY-POINTER+" + "+NORMAL-ARRAY-POINTER+" + "+COLOR-ARRAY-POINTER+" + "+INDEX-ARRAY-POINTER+" + "+TEXTURE-COORD-ARRAY-POINTER+" + "+EDGE-FLAG-ARRAY-POINTER+" + + ;; Array formats + + "+V2F+" + "+V3F+" + "+C4UB-V2F+" + "+C4UB-V3F+" + "+C3F-V3F+" + "+N3F-V3F+" + "+C4F-N3F-V3F+" + "+T2F-V3F+" + "+T4F-V4F+" + "+T2F-C4UB-V3F+" + "+T2F-C3F-V3F+" + "+T2F-N3F-V3F+" + "+T2F-C4F-N3F-V3F+" + "+T4F-C4F-N3F-V4F+" + + ;; Matrices + + "+MATRIX-MODE+" + "+MODELVIEW+" + "+PROJECTION+" + "+TEXTURE+" + + ;; Points + + "+POINT-SMOOTH+" + "+POINT-SIZE+" + "+POINT-SIZE-GRANULARITY+" + "+POINT-SIZE-RANGE+" + + ;; Lines + + "+LINE-SMOOTH+" + "+LINE-STIPPLE+" + "+LINE-STIPPLE-PATTERN+" + "+LINE-STIPPLE-REPEAT+" + "+LINE-WIDTH+" + "+LINE-WIDTH-GRANULARITY+" + "+LINE-WIDTH-RANGE+" + + ;; Polygons + + "+POINT+" + "+LINE+" + "+FILL+" + "+CW+" + "+CCW+" + "+FRONT+" + "+BACK+" + "+POLYGON-MODE+" + "+POLYGON-SMOOTH+" + "+POLYGON-STIPPLE+" + "+EDGE-FLAG+" + "+CULL-FACE+" + "+CULL-FACE-MODE+" + "+FRONT-FACE+" + "+POLYGON-OFFSET-FACTOR+" + "+POLYGON-OFFSET-UNITS+" + "+POLYGON-OFFSET-POINT+" + "+POLYGON-OFFSET-LINE+" + "+POLYGON-OFFSET-FILL+" + + ;; Display Lists + + "+COMPILE+" + "+COMPILE-AND-EXECUTE+" + "+LIST-BASE+" + "+LIST-INDEX+" + "+LIST-MODE+" + + ;; Depth Buffer + + "+NEVER+" + "+LESS+" + "+EQUAL+" + "+LEQUAL+" + "+GREATER+" + "+NOTEQUAL+" + "+GEQUAL+" + "+ALWAYS+" + "+DEPTH-TEST+" + "+DEPTH-BITS+" + "+DEPTH-CLEAR-VALUE+" + "+DEPTH-FUNC+" + "+DEPTH-RANGE+" + "+DEPTH-WRITEMASK+" + "+DEPTH-COMPONENT+" + + ;; Lighting + + "+LIGHTING+" + "+LIGHT0+" + "+LIGHT1+" + "+LIGHT2+" + "+LIGHT3+" + "+LIGHT4+" + "+LIGHT5+" + "+LIGHT6+" + "+LIGHT7+" + "+SPOT-EXPONENT+" + "+SPOT-CUTOFF+" + "+CONSTANT-ATTENUATION+" + "+LINEAR-ATTENUATION+" + "+QUADRATIC-ATTENUATION+" + "+AMBIENT+" + "+DIFFUSE+" + "+SPECULAR+" + "+SHININESS+" + "+EMISSION+" + "+POSITION+" + "+SPOT-DIRECTION+" + "+AMBIENT-AND-DIFFUSE+" + "+COLOR-INDEXES+" + "+LIGHT-MODEL-TWO-SIDE+" + "+LIGHT-MODEL-LOCAL-VIEWER+" + "+LIGHT-MODEL-AMBIENT+" + "+FRONT-AND-BACK+" + "+SHADE-MODEL+" + "+FLAT+" + "+SMOOTH+" + "+COLOR-MATERIAL+" + "+COLOR-MATERIAL-FACE+" + "+COLOR-MATERIAL-PARAMETER+" + "+NORMALIZE+" + + ;; Clipping planes + + "+CLIP-PLANE0+" + "+CLIP-PLANE1+" + "+CLIP-PLANE2+" + "+CLIP-PLANE3+" + "+CLIP-PLANE4+" + "+CLIP-PLANE5+" + + ;; Accumulation buffer + + "+ACCUM-RED-BITS+" + "+ACCUM-GREEN-BITS+" + "+ACCUM-BLUE-BITS+" + "+ACCUM-ALPHA-BITS+" + "+ACCUM-CLEAR-VALUE+" + "+ACCUM+" + "+ADD+" + "+LOAD+" + "+MULT+" + "+RETURN+" + + ;; Alpha Testing + + "+ALPHA-TEST+" + "+ALPHA-TEST-REF+" + "+ALPHA-TEST-FUNC+" + + ;; Blending + + "+BLEND+" + "+BLEND-SRC+" + "+BLEND-DST+" + "+ZERO+" + "+ONE+" + "+SRC-COLOR+" + "+ONE-MINUS-SRC-COLOR+" + "+DST-COLOR+" + "+ONE-MINUS-DST-COLOR+" + "+SRC-ALPHA+" + "+ONE-MINUS-SRC-ALPHA+" + "+DST-ALPHA+" + "+ONE-MINUS-DST-ALPHA+" + "+SRC-ALPHA-SATURATE+" + "+CONSTANT-COLOR+" + "+ONE-MINUS-CONSTANT-COLOR+" + "+CONSTANT-ALPHA+" + "+ONE-MINUS-CONSTANT-ALPHA+" + + ;; Render mode + + "+FEEDBACK+" + "+RENDER+" + "+SELECT+" + + ;; Feedback + + "+2D+" + "+3D+" + "+3D-COLOR+" + "+3D-COLOR-TEXTURE+" + "+4D-COLOR-TEXTURE+" + "+POINT-TOKEN+" + "+LINE-TOKEN+" + "+LINE-RESET-TOKEN+" + "+POLYGON-TOKEN+" + "+BITMAP-TOKEN+" + "+DRAW-PIXEL-TOKEN+" + "+COPY-PIXEL-TOKEN+" + "+PASS-THROUGH-TOKEN+" + "+FEEDBACK-BUFFER-POINTER+" + "+FEEDBACK-BUFFER-SIZE+" + "+FEEDBACK-BUFFER-TYPE+" + + ;; Selection + + "+SELECTION-BUFFER-POINTER+" + "+SELECTION-BUFFER-SIZE+" + + ;; Fog + + "+FOG+" + "+FOG-MODE+" + "+FOG-DENSITY+" + "+FOG-COLOR+" + "+FOG-INDEX+" + "+FOG-START+" + "+FOG-END+" + "+LINEAR+" + "+EXP+" + "+EXP2+" + + ;; Logic operations + + "+LOGIC-OP+" + "+INDEX-LOGIC-OP+" + "+COLOR-LOGIC-OP+" + "+LOGIC-OP-MODE+" + "+CLEAR+" + "+SET+" + "+COPY+" + "+COPY-INVERTED+" + "+NOOP+" + "+INVERT+" + "+AND+" + "+NAND+" + "+OR+" + "+NOR+" + "+XOR+" + "+EQUIV+" + "+AND-REVERSE+" + "+AND-INVERTED+" + "+OR-REVERSE+" + "+OR-INVERTED+" + + ;; Stencil + + "+STENCIL-TEST+" + "+STENCIL-WRITEMASK+" + "+STENCIL-BITS+" + "+STENCIL-FUNC+" + "+STENCIL-VALUE-MASK+" + "+STENCIL-REF+" + "+STENCIL-FAIL+" + "+STENCIL-PASS-DEPTH-PASS+" + "+STENCIL-PASS-DEPTH-FAIL+" + "+STENCIL-CLEAR-VALUE+" + "+STENCIL-INDEX+" + "+KEEP+" + "+REPLACE+" + "+INCR+" + "+DECR+" + + ;; Buffers, Pixel Drawing/Reading + + "+NONE+" + "+LEFT+" + "+RIGHT+" + "+FRONT-LEFT+" + "+FRONT-RIGHT+" + "+BACK-LEFT+" + "+BACK-RIGHT+" + "+AUX0+" + "+AUX1+" + "+AUX2+" + "+AUX3+" + "+COLOR-INDEX+" + "+RED+" + "+GREEN+" + "+BLUE+" + "+ALPHA+" + "+LUMINANCE+" + "+LUMINANCE-ALPHA+" + "+ALPHA-BITS+" + "+RED-BITS+" + "+GREEN-BITS+" + "+BLUE-BITS+" + "+INDEX-BITS+" + "+SUBPIXEL-BITS+" + "+AUX-BUFFERS+" + "+READ-BUFFER+" + "+DRAW-BUFFER+" + "+DOUBLEBUFFER+" + "+STEREO+" + "+BITMAP+" + "+COLOR+" + "+DEPTH+" + "+STENCIL+" + "+DITHER+" + "+RGB+" + "+RGBA+" + + ;; Implementation Limits + + "+MAX-LIST-NESTING+" + "+MAX-ATTRIB-STACK-DEPTH+" + "+MAX-MODELVIEW-STACK-DEPTH+" + "+MAX-NAME-STACK-DEPTH+" + "+MAX-PROJECTION-STACK-DEPTH+" + "+MAX-TEXTURE-STACK-DEPTH+" + "+MAX-EVAL-ORDER+" + "+MAX-LIGHTS+" + "+MAX-CLIP-PLANES+" + "+MAX-TEXTURE-SIZE+" + "+MAX-PIXEL-MAP-TABLE+" + "+MAX-VIEWPORT-DIMS+" + "+MAX-CLIENT-ATTRIB-STACK-DEPTH+" + + ;; Gets + + "+ATTRIB-STACK-DEPTH+" + "+CLIENT-ATTRIB-STACK-DEPTH+" + "+COLOR-CLEAR-VALUE+" + "+COLOR-WRITEMASK+" + "+CURRENT-INDEX+" + "+CURRENT-COLOR+" + "+CURRENT-NORMAL+" + "+CURRENT-RASTER-COLOR+" + "+CURRENT-RASTER-DISTANCE+" + "+current-raster-index+" + "+CURRENT-RASTER-POSITION+" + "+CURRENT-RASTER-TEXTURE-COORDS+" + "+CURRENT-RASTER-POSITION-VALID+" + "+CURRENT-TEXTURE-COORDS+" + "+INDEX-CLEAR-VALUE+" + "+INDEX-MODE+" + "+INDEX-WRITEMASK+" + "+MODELVIEW-MATRIX+" + "+MODELVIEW-STACK-DEPTH+" + "+NAME-STACK-DEPTH+" + "+PROJECTION-MATRIX+" + "+PROJECTION-STACK-DEPTH+" + "+RENDER-MODE+" + "+RGBA-MODE+" + "+TEXTURE-MATRIX+" + "+TEXTURE-STACK-DEPTH+" + "+VIEWPORT+" + + ;; GL Evaluators + + "+AUTO-NORMAL+" + "+MAP1-COLOR-4+" + "+MAP1-GRID-DOMAIN+" + "+MAP1-GRID-SEGMENTS+" + "+MAP1-INDEX+" + "+MAP1-NORMAL+" + "+MAP1-TEXTURE-COORD-1+" + "+MAP1-TEXTURE-COORD-2+" + "+MAP1-TEXTURE-COORD-3+" + "+MAP1-TEXTURE-COORD-4+" + "+MAP1-VERTEX-3+" + "+MAP1-VERTEX-4+" + "+MAP2-COLOR-4+" + "+MAP2-GRID-DOMAIN+" + "+MAP2-GRID-SEGMENTS+" + "+MAP2-INDEX+" + "+MAP2-NORMAL+" + "+MAP2-TEXTURE-COORD-1+" + "+MAP2-TEXTURE-COORD-2+" + "+MAP2-TEXTURE-COORD-3+" + "+MAP2-TEXTURE-COORD-4+" + "+MAP2-VERTEX-3+" + "+MAP2-VERTEX-4+" + "+COEFF+" + "+DOMAIN+" + "+ORDER+" + + ;; Hints + + "+FOG-HINT+" + "+LINE-SMOOTH-HINT+" + "+PERSPECTIVE-CORRECTION-HINT+" + "+POINT-SMOOTH-HINT+" + "+POLYGON-SMOOTH-HINT+" + "+DONT-CARE+" + "+FASTEST+" + "+NICEST+" + + ;; Scissor box + + "+SCISSOR-TEST+" + "+SCISSOR-BOX+" + + ;; Pixel Mode / Transfer + + "+MAP-COLOR+" + "+MAP-STENCIL+" + "+INDEX-SHIFT+" + "+INDEX-OFFSET+" + "+RED-SCALE+" + "+RED-BIAS+" + "+GREEN-SCALE+" + "+GREEN-BIAS+" + "+BLUE-SCALE+" + "+BLUE-BIAS+" + "+ALPHA-SCALE+" + "+ALPHA-BIAS+" + "+DEPTH-SCALE+" + "+DEPTH-BIAS+" + "+PIXEL-MAP-S-TO-S-SIZE+" + "+PIXEL-MAP-I-TO-I-SIZE+" + "+PIXEL-MAP-I-TO-R-SIZE+" + "+PIXEL-MAP-I-TO-G-SIZE+" + "+PIXEL-MAP-I-TO-B-SIZE+" + "+PIXEL-MAP-I-TO-A-SIZE+" + "+PIXEL-MAP-R-TO-R-SIZE+" + "+PIXEL-MAP-G-TO-G-SIZE+" + "+PIXEL-MAP-B-TO-B-SIZE+" + "+PIXEL-MAP-A-TO-A-SIZE+" + "+PIXEL-MAP-S-TO-S+" + "+PIXEL-MAP-I-TO-I+" + "+PIXEL-MAP-I-TO-R+" + "+PIXEL-MAP-I-TO-G+" + "+PIXEL-MAP-I-TO-B+" + "+PIXEL-MAP-I-TO-A+" + "+PIXEL-MAP-R-TO-R+" + "+PIXEL-MAP-G-TO-G+" + "+PIXEL-MAP-B-TO-B+" + "+PIXEL-MAP-A-TO-A+" + "+PACK-ALIGNMENT+" + "+PACK-LSB-FIRST+" + "+PACK-ROW-LENGTH+" + "+PACK-SKIP-PIXELS+" + "+PACK-SKIP-ROWS+" + "+PACK-SWAP-BYTES+" + "+UNPACK-ALIGNMENT+" + "+UNPACK-LSB-FIRST+" + "+UNPACK-ROW-LENGTH+" + "+UNPACK-SKIP-PIXELS+" + "+UNPACK-SKIP-ROWS+" + "+UNPACK-SWAP-BYTES+" + "+ZOOM-X+" + "+ZOOM-Y+" + + ;; Texture Mapping + + "+TEXTURE-ENV+" + "+TEXTURE-ENV-MODE+" + "+TEXTURE-1D+" + "+TEXTURE-2D+" + "+TEXTURE-WRAP-S+" + "+TEXTURE-WRAP-T+" + "+TEXTURE-MAG-FILTER+" + "+TEXTURE-MIN-FILTER+" + "+TEXTURE-ENV-COLOR+" + "+TEXTURE-GEN-S+" + "+TEXTURE-GEN-T+" + "+TEXTURE-GEN-MODE+" + "+TEXTURE-BORDER-COLOR+" + "+TEXTURE-WIDTH+" + "+TEXTURE-HEIGHT+" + "+TEXTURE-BORDER+" + "+TEXTURE-COMPONENTS+" + "+TEXTURE-RED-SIZE+" + "+TEXTURE-GREEN-SIZE+" + "+TEXTURE-BLUE-SIZE+" + "+TEXTURE-ALPHA-SIZE+" + "+TEXTURE-LUMINANCE-SIZE+" + "+TEXTURE-INTENSITY-SIZE+" + "+NEAREST-MIPMAP-NEAREST+" + "+NEAREST-MIPMAP-LINEAR+" + "+LINEAR-MIPMAP-NEAREST+" + "+LINEAR-MIPMAP-LINEAR+" + "+OBJECT-LINEAR+" + "+OBJECT-PLANE+" + "+EYE-LINEAR+" + "+EYE-PLANE+" + "+SPHERE-MAP+" + "+DECAL+" + "+MODULATE+" + "+NEAREST+" + "+REPEAT+" + "+CLAMP+" + "+S+" + "+T+" + "+R+" + "+Q+" + "+TEXTURE-GEN-R+" + "+TEXTURE-GEN-Q+" + + ;; GL 1.1 Texturing + + "+PROXY-TEXTURE-1D+" + "+PROXY-TEXTURE-2D+" + "+TEXTURE-PRIORITY+" + "+TEXTURE-RESIDENT+" + "+TEXTURE-BINDING-1D+" + "+TEXTURE-BINDING-2D+" + "+TEXTURE-INTERNAL-FORMAT+" + "+PACK-SKIP-IMAGES+" + "+PACK-IMAGE-HEIGHT+" + "+UNPACK-SKIP-IMAGES+" + "+UNPACK-IMAGE-HEIGHT+" + "+TEXTURE-3D+" + "+PROXY-TEXTURE-3D+" + "+TEXTURE-DEPTH+" + "+TEXTURE-WRAP-R+" + "+MAX-3D-TEXTURE-SIZE+" + "+TEXTURE-BINDING-3D+" + + ;; Internal texture formats (GL 1.1) + "+ALPHA4+" + "+ALPHA8+" + "+ALPHA12+" + "+ALPHA16+" + "+LUMINANCE4+" + "+LUMINANCE8+" + "+LUMINANCE12+" + "+LUMINANCE16+" + "+LUMINANCE4-ALPHA4+" + "+LUMINANCE6-ALPHA2+" + "+LUMINANCE8-ALPHA8+" + "+LUMINANCE12-ALPHA4+" + "+LUMINANCE12-ALPHA12+" + "+LUMINANCE16-ALPHA16+" + "+INTENSITY+" + "+INTENSITY4+" + "+INTENSITY8+" + "+INTENSITY12+" + "+INTENSITY16+" + "+R3-G3-B2+" + "+RGB4+" + "+RGB5+" + "+RGB8+" + "+RGB10+" + "+RGB12+" + "+RGB16+" + "+RGBA2+" + "+RGBA4+" + "+RGB5-A1+" + "+RGBA8+" + "+rgb10-a2+" + "+RGBA12+" + "+RGBA16+" + + ;; Utility + + "+VENDOR+" + "+RENDERER+" + "+VERSION+" + "+EXTENSIONS+" + + ;; Errors + + "+NO-ERROR+" + "+INVALID-VALUE+" + "+INVALID-ENUM+" + "+INVALID-OPERATION+" + "+STACK-OVERFLOW+" + "+STACK-UNDERFLOW+" + "+OUT-OF-MEMORY+" + + ;; OpenGL 1.2 + + "+RESCALE-NORMAL+" + "+CLAMP-TO-EDGE+" + "+MAX-ELEMENTS-VERTICES+" + "+MAX-ELEMENTS-INDICES+" + "+BGR+" + "+BGRA+" + "+UNSIGNED-BYTE-3-3-2+" + "+UNSIGNED-BYTE-2-3-3-REV+" + "+UNSIGNED-SHORT-5-6-5+" + "+UNSIGNED-SHORT-5-6-5-REV+" + "+UNSIGNED-SHORT-4-4-4-4+" + "+UNSIGNED-SHORT-4-4-4-4-REV+" + "+UNSIGNED-SHORT-5-5-5-1+" + "+UNSIGNED-SHORT-1-5-5-5-REV+" + "+UNSIGNED-INT-8-8-8-8+" + "+UNSIGNED-INT-8-8-8-8-REV+" + "+UNSIGNED-INT-10-10-10-2+" + "+UNSIGNED-INT-2-10-10-10-REV+" + "+LIGHT-MODEL-COLOR-CONTROL+" + "+SINGLE-COLOR+" + "+SEPARATE-SPECULAR-COLOR+" + "+TEXTURE-MIN-LOD+" + "+TEXTURE-MAX-LOD+" + "+TEXTURE-BASE-LEVEL+" + "+TEXTURE-MAX-LEVEL+" + "+SMOOTH-POINT-SIZE-RANGE+" + "+SMOOTH-POINT-SIZE-GRANULARITY+" + "+SMOOTH-LINE-WIDTH-RANGE+" + "+SMOOTH-LINE-WIDTH-GRANULARITY+" + "+ALIASED-POINT-SIZE-RANGE+" + "+ALIASED-LINE-WIDTH-RANGE+" + + ;; OpenGL 1.2 Imaging subset + ;; GL_EXT_color_table + "+COLOR-TABLE+" + "+POST-CONVOLUTION-COLOR-TABLE+" + "+POST-COLOR-MATRIX-COLOR-TABLE+" + "+PROXY-COLOR-TABLE+" + "+PROXY-POST-CONVOLUTION-COLOR-TABLE+" + "+PROXY-POST-COLOR-MATRIX-COLOR-TABLE+" + "+COLOR-TABLE-SCALE+" + "+COLOR-TABLE-BIAS+" + "+COLOR-TABLE-FORMAT+" + "+COLOR-TABLE-WIDTH+" + "+COLOR-TABLE-RED-SIZE+" + "+COLOR-TABLE-GREEN-SIZE+" + "+COLOR-TABLE-BLUE-SIZE+" + "+COLOR-TABLE-ALPHA-SIZE+" + "+COLOR-TABLE-LUMINANCE-SIZE+" + "+COLOR-TABLE-INTENSITY-SIZE+" + ;; GL_EXT_convolution and GL_HP_convolution + "+CONVOLUTION-1D+" + "+CONVOLUTION-2D+" + "+SEPARABLE-2D+" + "+CONVOLUTION-BORDER-MODE+" + "+CONVOLUTION-FILTER-SCALE+" + "+CONVOLUTION-FILTER-BIAS+" + "+REDUCE+" + "+CONVOLUTION-FORMAT+" + "+CONVOLUTION-WIDTH+" + "+CONVOLUTION-HEIGHT+" + "+MAX-CONVOLUTION-WIDTH+" + "+MAX-CONVOLUTION-HEIGHT+" + "+POST-CONVOLUTION-RED-SCALE+" + "+POST-CONVOLUTION-GREEN-SCALE+" + "+POST-CONVOLUTION-BLUE-SCALE+" + "+POST-CONVOLUTION-ALPHA-SCALE+" + "+POST-CONVOLUTION-RED-BIAS+" + "+POST-CONVOLUTION-GREEN-BIAS+" + "+POST-CONVOLUTION-BLUE-BIAS+" + "+POST-CONVOLUTION-ALPHA-BIAS+" + "+CONSTANT-BORDER+" + "+REPLICATE-BORDER+" + "+CONVOLUTION-BORDER-COLOR+" + ;; GL_SGI_color_matrix + "+COLOR-MATRIX+" + "+COLOR-MATRIX-STACK-DEPTH+" + "+MAX-COLOR-MATRIX-STACK-DEPTH+" + "+POST-COLOR-MATRIX-RED-SCALE+" + "+POST-COLOR-MATRIX-GREEN-SCALE+" + "+POST-COLOR-MATRIX-BLUE-SCALE+" + "+POST-COLOR-MATRIX-ALPHA-SCALE+" + "+POST-COLOR-MATRIX-RED-BIAS+" + "+POST-COLOR-MATRIX-GREEN-BIAS+" + "+POST-COLOR-MATRIX-BLUE-BIAS+" + "+POST-COLOR-MATRIX-ALPHA-BIAS+" + ;; GL_EXT_histogram + "+HISTOGRAM+" + "+PROXY-HISTOGRAM+" + "+HISTOGRAM-WIDTH+" + "+HISTOGRAM-FORMAT+" + "+HISTOGRAM-RED-SIZE+" + "+HISTOGRAM-GREEN-SIZE+" + "+HISTOGRAM-BLUE-SIZE+" + "+HISTOGRAM-ALPHA-SIZE+" + "+HISTOGRAM-LUMINANCE-SIZE+" + "+HISTOGRAM-SINK+" + "+MINMAX+" + "+MINMAX-FORMAT+" + "+MINMAX-SINK+" + "+TABLE-TOO-LARGE+" + ;; GL_EXT_blend_color, GL_EXT_blend_minmax + "+BLEND-EQUATION+" + "+MIN+" + "+MAX+" + "+FUNC-ADD+" + "+FUNC-SUBTRACT+" + "+FUNC-REVERSE-SUBTRACT+" + + ;; glPush/PopAttrib bits + + "+CURRENT-BIT+" + "+POINT-BIT+" + "+LINE-BIT+" + "+POLYGON-BIT+" + "+POLYGON-STIPPLE-BIT+" + "+PIXEL-MODE-BIT+" + "+LIGHTING-BIT+" + "+FOG-BIT+" + "+DEPTH-BUFFER-BIT+" + "+ACCUM-BUFFER-BIT+" + "+STENCIL-BUFFER-BIT+" + "+VIEWPORT-BIT+" + "+TRANSFORM-BIT+" + "+ENABLE-BIT+" + "+COLOR-BUFFER-BIT+" + "+HINT-BIT+" + "+EVAL-BIT+" + "+LIST-BIT+" + "+TEXTURE-BIT+" + "+SCISSOR-BIT+" + "+ALL-ATTRIB-BITS+" + "+CLIENT-PIXEL-STORE-BIT+" + "+CLIENT-VERTEX-ARRAY-BIT+" + "+CLIENT-ALL-ATTRIB-BITS+" + + ;; ARB Multitexturing extension + + "+ARB-MULTITEXTURE+" + "+TEXTURE0-ARB+" + "+TEXTURE1-ARB+" + "+TEXTURE2-ARB+" + "+TEXTURE3-ARB+" + "+TEXTURE4-ARB+" + "+TEXTURE5-ARB+" + "+TEXTURE6-ARB+" + "+TEXTURE7-ARB+" + "+TEXTURE8-ARB+" + "+TEXTURE9-ARB+" + "+TEXTURE10-ARB+" + "+TEXTURE11-ARB+" + "+TEXTURE12-ARB+" + "+TEXTURE13-ARB+" + "+TEXTURE14-ARB+" + "+TEXTURE15-ARB+" + "+TEXTURE16-ARB+" + "+TEXTURE17-ARB+" + "+TEXTURE18-ARB+" + "+TEXTURE19-ARB+" + "+TEXTURE20-ARB+" + "+TEXTURE21-ARB+" + "+TEXTURE22-ARB+" + "+TEXTURE23-ARB+" + "+TEXTURE24-ARB+" + "+TEXTURE25-ARB+" + "+TEXTURE26-ARB+" + "+TEXTURE27-ARB+" + "+TEXTURE28-ARB+" + "+TEXTURE29-ARB+" + "+TEXTURE30-ARB+" + "+TEXTURE31-ARB+" + "+ACTIVE-TEXTURE-ARB+" + "+CLIENT-ACTIVE-TEXTURE-ARB+" + "+MAX-TEXTURE-UNITS-ARB+" + +;;; Misc extensions + + "+EXT-ABGR+" + "+ABGR-EXT+" + "+EXT-BLEND-COLOR+" + "+CONSTANT-COLOR-EXT+" + "+ONE-MINUS-CONSTANT-COLOR-EXT+" + "+CONSTANT-ALPHA-EXT+" + "+ONE-MINUS-CONSTANT-ALPHA-EXT+" + "+blend-color-ext+" + "+EXT-POLYGON-OFFSET+" + "+POLYGON-OFFSET-EXT+" + "+POLYGON-OFFSET-FACTOR-EXT+" + "+POLYGON-OFFSET-BIAS-EXT+" + "+EXT-TEXTURE3D+" + "+PACK-SKIP-IMAGES-EXT+" + "+PACK-IMAGE-HEIGHT-EXT+" + "+UNPACK-SKIP-IMAGES-EXT+" + "+UNPACK-IMAGE-HEIGHT-EXT+" + "+TEXTURE-3D-EXT+" + "+PROXY-TEXTURE-3D-EXT+" + "+TEXTURE-DEPTH-EXT+" + "+TEXTURE-WRAP-R-EXT+" + "+MAX-3D-TEXTURE-SIZE-EXT+" + "+TEXTURE-3D-BINDING-EXT+" + "+EXT-TEXTURE-OBJECT+" + "+TEXTURE-PRIORITY-EXT+" + "+TEXTURE-RESIDENT-EXT+" + "+TEXTURE-1D-BINDING-EXT+" + "+TEXTURE-2D-BINDING-EXT+" + "+EXT-RESCALE-NORMAL+" + "+RESCALE-NORMAL-EXT+" + "+EXT-VERTEX-ARRAY+" + "+VERTEX-ARRAY-EXT+" + "+NORMAL-ARRAY-EXT+" + "+COLOR-ARRAY-EXT+" + "+INDEX-ARRAY-EXT+" + "+TEXTURE-COORD-ARRAY-EXT+" + "+EDGE-FLAG-ARRAY-EXT+" + "+VERTEX-ARRAY-SIZE-EXT+" + "+VERTEX-ARRAY-TYPE-EXT+" + "+VERTEX-ARRAY-STRIDE-EXT+" + "+VERTEX-ARRAY-COUNT-EXT+" + "+NORMAL-ARRAY-TYPE-EXT+" + "+NORMAL-ARRAY-STRIDE-EXT+" + "+NORMAL-ARRAY-COUNT-EXT+" + "+COLOR-ARRAY-SIZE-EXT+" + "+COLOR-ARRAY-TYPE-EXT+" + "+COLOR-ARRAY-STRIDE-EXT+" + "+COLOR-ARRAY-COUNT-EXT+" + "+INDEX-ARRAY-TYPE-EXT+" + "+INDEX-ARRAY-STRIDE-EXT+" + "+INDEX-ARRAY-COUNT-EXT+" + "+TEXTURE-COORD-ARRAY-SIZE-EXT+" + "+TEXTURE-COORD-ARRAY-TYPE-EXT+" + "+TEXTURE-COORD-ARRAY-STRIDE-EXT+" + "+TEXTURE-COORD-ARRAY-COUNT-EXT+" + "+EDGE-FLAG-ARRAY-STRIDE-EXT+" + "+EDGE-FLAG-ARRAY-COUNT-EXT+" + "+VERTEX-ARRAY-POINTER-EXT+" + "+NORMAL-ARRAY-POINTER-EXT+" + "+COLOR-ARRAY-POINTER-EXT+" + "+INDEX-ARRAY-POINTER-EXT+" + "+TEXTURE-COORD-ARRAY-POINTER-EXT+" + "+EDGE-FLAG-ARRAY-POINTER-EXT+" + "+SGIS-TEXTURE-EDGE-CLAMP+" + "+CLAMP-TO-EDGE-SGIS+" + "+EXT-BLEND-MINMAX+" + "+FUNC-ADD-EXT+" + "+MIN-EXT+" + "+MAX-EXT+" + "+BLEND-EQUATION-EXT+" + "+EXT-BLEND-SUBTRACT+" + "+FUNC-SUBTRACT-EXT+" + "+FUNC-REVERSE-SUBTRACT-EXT+" + "+EXT-BLEND-LOGIC-OP+" + "+EXT-POINT-PARAMETERS+" + "+POINT-SIZE-MIN-EXT+" + "+POINT-SIZE-MAX-EXT+" + "+POINT-FADE-THRESHOLD-SIZE-EXT+" + "+DISTANCE-ATTENUATION-EXT+" + "+EXT-PALETTED-TEXTURE+" + "+TABLE-TOO-LARGE-EXT+" + "+COLOR-TABLE-FORMAT-EXT+" + "+COLOR-TABLE-WIDTH-EXT+" + "+COLOR-TABLE-RED-SIZE-EXT+" + "+COLOR-TABLE-GREEN-SIZE-EXT+" + "+COLOR-TABLE-BLUE-SIZE-EXT+" + "+COLOR-TABLE-ALPHA-SIZE-EXT+" + "+COLOR-TABLE-LUMINANCE-SIZE-EXT+" + "+COLOR-TABLE-INTENSITY-SIZE-EXT+" + "+TEXTURE-INDEX-SIZE-EXT+" + "+COLOR-INDEX1-EXT+" + "+COLOR-INDEX2-EXT+" + "+COLOR-INDEX4-EXT+" + "+COLOR-INDEX8-EXT+" + "+COLOR-INDEX12-EXT+" + "+COLOR-INDEX16-EXT+" + "+EXT-CLIP-VOLUME-HINT+" + "+CLIP-VOLUME-CLIPPING-HINT-EXT+" + "+EXT-COMPILED-VERTEX-ARRAY+" + "+ARRAY-ELEMENT-LOCK-FIRST-EXT+" + "+ARRAY-ELEMENT-LOCK-COUNT-EXT+" + "+HP-OCCLUSION-TEST+" + "+OCCLUSION-TEST-HP+" + "+OCCLUSION-TEST-RESULT-HP+" + "+EXT-SHARED-TEXTURE-PALETTE+" + "+SHARED-TEXTURE-PALETTE-EXT+" + "+EXT-STENCIL-WRAP+" + "+INCR-WRAP-EXT+" + "+DECR-WRAP-EXT+" + "+NV-TEXGEN-REFLECTION+" + "+NORMAL-MAP-NV+" + "+REFLECTION-MAP-NV+" + "+EXT-TEXTURE-ENV-ADD+" + "+MESA-WINDOW-POS+" + "+MESA-RESIZE-BUFFERS+" + + )) + + +(in-package :gl) + + + +;;; Opcodes. + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant +get-string+ 129) +(defconstant +new-list+ 101) +(defconstant +end-list+ 102) +(defconstant +gen-lists+ 104) +(defconstant +finish+ 108) +(defconstant +disable+ 138) +(defconstant +enable+ 139) +(defconstant +flush+ 142) + + + +;;; Constants. +;;; Shamelessly taken from CL-SDL. + +;; Boolean + +(defconstant +false+ #x0) +(defconstant +true+ #x1) + +;; Types + +(defconstant +byte+ #x1400) +(defconstant +unsigned-byte+ #x1401) +(defconstant +short+ #x1402) +(defconstant +unsigned-short+ #x1403) +(defconstant +int+ #x1404) +(defconstant +unsigned-int+ #x1405) +(defconstant +float+ #x1406) +(defconstant +double+ #x140a) +(defconstant +2-bytes+ #x1407) +(defconstant +3-bytes+ #x1408) +(defconstant +4-bytes+ #x1409) + +;; Primitives + +(defconstant +points+ #x0000) +(defconstant +lines+ #x0001) +(defconstant +line-loop+ #x0002) +(defconstant +line-strip+ #x0003) +(defconstant +triangles+ #x0004) +(defconstant +triangle-strip+ #x0005) +(defconstant +triangle-fan+ #x0006) +(defconstant +quads+ #x0007) +(defconstant +quad-strip+ #x0008) +(defconstant +polygon+ #x0009) + +;; Arrays + +(defconstant +vertex-array+ #x8074) +(defconstant +normal-array+ #x8075) +(defconstant +color-array+ #x8076) +(defconstant +index-array+ #x8077) +(defconstant +texture-coord-array+ #x8078) +(defconstant +edge-flag-array+ #x8079) +(defconstant +vertex-array-size+ #x807a) +(defconstant +vertex-array-type+ #x807b) +(defconstant +vertex-array-stride+ #x807c) +(defconstant +normal-array-type+ #x807e) +(defconstant +normal-array-stride+ #x807f) +(defconstant +color-array-size+ #x8081) +(defconstant +color-array-type+ #x8082) +(defconstant +color-array-stride+ #x8083) +(defconstant +index-array-type+ #x8085) +(defconstant +index-array-stride+ #x8086) +(defconstant +texture-coord-array-size+ #x8088) +(defconstant +texture-coord-array-type+ #x8089) +(defconstant +texture-coord-array-stride+ #x808a) +(defconstant +edge-flag-array-stride+ #x808c) +(defconstant +vertex-array-pointer+ #x808e) +(defconstant +normal-array-pointer+ #x808f) +(defconstant +color-array-pointer+ #x8090) +(defconstant +index-array-pointer+ #x8091) +(defconstant +texture-coord-array-pointer+ #x8092) +(defconstant +edge-flag-array-pointer+ #x8093) + +;; Array formats + +(defconstant +v2f+ #x2a20) +(defconstant +v3f+ #x2a21) +(defconstant +c4ub-v2f+ #x2a22) +(defconstant +c4ub-v3f+ #x2a23) +(defconstant +c3f-v3f+ #x2a24) +(defconstant +n3f-v3f+ #x2a25) +(defconstant +c4f-n3f-v3f+ #x2a26) +(defconstant +t2f-v3f+ #x2a27) +(defconstant +t4f-v4f+ #x2a28) +(defconstant +t2f-c4ub-v3f+ #x2a29) +(defconstant +t2f-c3f-v3f+ #x2a2a) +(defconstant +t2f-n3f-v3f+ #x2a2b) +(defconstant +t2f-c4f-n3f-v3f+ #x2a2c) +(defconstant +t4f-c4f-n3f-v4f+ #x2a2d) + +;; Matrices + +(defconstant +matrix-mode+ #x0ba0) +(defconstant +modelview+ #x1700) +(defconstant +projection+ #x1701) +(defconstant +texture+ #x1702) + +;; Points + +(defconstant +point-smooth+ #x0b10) +(defconstant +point-size+ #x0b11) +(defconstant +point-size-granularity+ #x0b13) +(defconstant +point-size-range+ #x0b12) + +;; Lines + +(defconstant +line-smooth+ #x0b20) +(defconstant +line-stipple+ #x0b24) +(defconstant +line-stipple-pattern+ #x0b25) +(defconstant +line-stipple-repeat+ #x0b26) +(defconstant +line-width+ #x0b21) +(defconstant +line-width-granularity+ #x0b23) +(defconstant +line-width-range+ #x0b22) + +;; Polygons + +(defconstant +point+ #x1b00) +(defconstant +line+ #x1b01) +(defconstant +fill+ #x1b02) +(defconstant +cw+ #x0900) +(defconstant +ccw+ #x0901) +(defconstant +front+ #x0404) +(defconstant +back+ #x0405) +(defconstant +polygon-mode+ #x0b40) +(defconstant +polygon-smooth+ #x0b41) +(defconstant +polygon-stipple+ #x0b42) +(defconstant +edge-flag+ #x0b43) +(defconstant +cull-face+ #x0b44) +(defconstant +cull-face-mode+ #x0b45) +(defconstant +front-face+ #x0b46) +(defconstant +polygon-offset-factor+ #x8038) +(defconstant +polygon-offset-units+ #x2a00) +(defconstant +polygon-offset-point+ #x2a01) +(defconstant +polygon-offset-line+ #x2a02) +(defconstant +polygon-offset-fill+ #x8037) + +;; Display Lists + +(defconstant +compile+ #x1300) +(defconstant +compile-and-execute+ #x1301) +(defconstant +list-base+ #x0b32) +(defconstant +list-index+ #x0b33) +(defconstant +list-mode+ #x0b30) + +;; Depth Buffer + +(defconstant +never+ #x0200) +(defconstant +less+ #x0201) +(defconstant +equal+ #x0202) +(defconstant +lequal+ #x0203) +(defconstant +greater+ #x0204) +(defconstant +notequal+ #x0205) +(defconstant +gequal+ #x0206) +(defconstant +always+ #x0207) +(defconstant +depth-test+ #x0b71) +(defconstant +depth-bits+ #x0d56) +(defconstant +depth-clear-value+ #x0b73) +(defconstant +depth-func+ #x0b74) +(defconstant +depth-range+ #x0b70) +(defconstant +depth-writemask+ #x0b72) +(defconstant +depth-component+ #x1902) + +;; Lighting + +(defconstant +lighting+ #x0b50) +(defconstant +light0+ #x4000) +(defconstant +light1+ #x4001) +(defconstant +light2+ #x4002) +(defconstant +light3+ #x4003) +(defconstant +light4+ #x4004) +(defconstant +light5+ #x4005) +(defconstant +light6+ #x4006) +(defconstant +light7+ #x4007) +(defconstant +spot-exponent+ #x1205) +(defconstant +spot-cutoff+ #x1206) +(defconstant +constant-attenuation+ #x1207) +(defconstant +linear-attenuation+ #x1208) +(defconstant +quadratic-attenuation+ #x1209) +(defconstant +ambient+ #x1200) +(defconstant +diffuse+ #x1201) +(defconstant +specular+ #x1202) +(defconstant +shininess+ #x1601) +(defconstant +emission+ #x1600) +(defconstant +position+ #x1203) +(defconstant +spot-direction+ #x1204) +(defconstant +ambient-and-diffuse+ #x1602) +(defconstant +color-indexes+ #x1603) +(defconstant +light-model-two-side+ #x0b52) +(defconstant +light-model-local-viewer+ #x0b51) +(defconstant +light-model-ambient+ #x0b53) +(defconstant +front-and-back+ #x0408) +(defconstant +shade-model+ #x0b54) +(defconstant +flat+ #x1d00) +(defconstant +smooth+ #x1d01) +(defconstant +color-material+ #x0b57) +(defconstant +color-material-face+ #x0b55) +(defconstant +color-material-parameter+ #x0b56) +(defconstant +normalize+ #x0ba1) + +;; Clipping planes + +(defconstant +clip-plane0+ #x3000) +(defconstant +clip-plane1+ #x3001) +(defconstant +clip-plane2+ #x3002) +(defconstant +clip-plane3+ #x3003) +(defconstant +clip-plane4+ #x3004) +(defconstant +clip-plane5+ #x3005) + +;; Accumulation buffer + +(defconstant +accum-red-bits+ #x0d58) +(defconstant +accum-green-bits+ #x0d59) +(defconstant +accum-blue-bits+ #x0d5a) +(defconstant +accum-alpha-bits+ #x0d5b) +(defconstant +accum-clear-value+ #x0b80) +(defconstant +accum+ #x0100) +(defconstant +add+ #x0104) +(defconstant +load+ #x0101) +(defconstant +mult+ #x0103) +(defconstant +return+ #x0102) + +;; Alpha Testing + +(defconstant +alpha-test+ #x0bc0) +(defconstant +alpha-test-ref+ #x0bc2) +(defconstant +alpha-test-func+ #x0bc1) + +;; Blending + +(defconstant +blend+ #x0be2) +(defconstant +blend-src+ #x0be1) +(defconstant +blend-dst+ #x0be0) +(defconstant +zero+ #x0) +(defconstant +one+ #x1) +(defconstant +src-color+ #x0300) +(defconstant +one-minus-src-color+ #x0301) +(defconstant +dst-color+ #x0306) +(defconstant +one-minus-dst-color+ #x0307) +(defconstant +src-alpha+ #x0302) +(defconstant +one-minus-src-alpha+ #x0303) +(defconstant +dst-alpha+ #x0304) +(defconstant +one-minus-dst-alpha+ #x0305) +(defconstant +src-alpha-saturate+ #x0308) +(defconstant +constant-color+ #x8001) +(defconstant +one-minus-constant-color+ #x8002) +(defconstant +constant-alpha+ #x8003) +(defconstant +one-minus-constant-alpha+ #x8004) + +;; Render mode + +(defconstant +feedback+ #x1c01) +(defconstant +render+ #x1c00) +(defconstant +select+ #x1c02) + +;; Feedback + +(defconstant +2d+ #x0600) +(defconstant +3d+ #x0601) +(defconstant +3d-color+ #x0602) +(defconstant +3d-color-texture+ #x0603) +(defconstant +4d-color-texture+ #x0604) +(defconstant +point-token+ #x0701) +(defconstant +line-token+ #x0702) +(defconstant +line-reset-token+ #x0707) +(defconstant +polygon-token+ #x0703) +(defconstant +bitmap-token+ #x0704) +(defconstant +draw-pixel-token+ #x0705) +(defconstant +copy-pixel-token+ #x0706) +(defconstant +pass-through-token+ #x0700) +(defconstant +feedback-buffer-pointer+ #x0df0) +(defconstant +feedback-buffer-size+ #x0df1) +(defconstant +feedback-buffer-type+ #x0df2) + +;; Selection + +(defconstant +selection-buffer-pointer+ #x0df3) +(defconstant +selection-buffer-size+ #x0df4) + +;; Fog + +(defconstant +fog+ #x0b60) +(defconstant +fog-mode+ #x0b65) +(defconstant +fog-density+ #x0b62) +(defconstant +fog-color+ #x0b66) +(defconstant +fog-index+ #x0b61) +(defconstant +fog-start+ #x0b63) +(defconstant +fog-end+ #x0b64) +(defconstant +linear+ #x2601) +(defconstant +exp+ #x0800) +(defconstant +exp2+ #x0801) + +;; Logic operations + +(defconstant +logic-op+ #x0bf1) +(defconstant +index-logic-op+ #x0bf1) +(defconstant +color-logic-op+ #x0bf2) +(defconstant +logic-op-mode+ #x0bf0) +(defconstant +clear+ #x1500) +(defconstant +set+ #x150f) +(defconstant +copy+ #x1503) +(defconstant +copy-inverted+ #x150c) +(defconstant +noop+ #x1505) +(defconstant +invert+ #x150a) +(defconstant +and+ #x1501) +(defconstant +nand+ #x150e) +(defconstant +or+ #x1507) +(defconstant +nor+ #x1508) +(defconstant +xor+ #x1506) +(defconstant +equiv+ #x1509) +(defconstant +and-reverse+ #x1502) +(defconstant +and-inverted+ #x1504) +(defconstant +or-reverse+ #x150b) +(defconstant +or-inverted+ #x150d) + +;; Stencil + +(defconstant +stencil-test+ #x0b90) +(defconstant +stencil-writemask+ #x0b98) +(defconstant +stencil-bits+ #x0d57) +(defconstant +stencil-func+ #x0b92) +(defconstant +stencil-value-mask+ #x0b93) +(defconstant +stencil-ref+ #x0b97) +(defconstant +stencil-fail+ #x0b94) +(defconstant +stencil-pass-depth-pass+ #x0b96) +(defconstant +stencil-pass-depth-fail+ #x0b95) +(defconstant +stencil-clear-value+ #x0b91) +(defconstant +stencil-index+ #x1901) +(defconstant +keep+ #x1e00) +(defconstant +replace+ #x1e01) +(defconstant +incr+ #x1e02) +(defconstant +decr+ #x1e03) + +;; Buffers, Pixel Drawing/Reading + +(defconstant +none+ #x0) +(defconstant +left+ #x0406) +(defconstant +right+ #x0407) +(defconstant +front-left+ #x0400) +(defconstant +front-right+ #x0401) +(defconstant +back-left+ #x0402) +(defconstant +back-right+ #x0403) +(defconstant +aux0+ #x0409) +(defconstant +aux1+ #x040a) +(defconstant +aux2+ #x040b) +(defconstant +aux3+ #x040c) +(defconstant +color-index+ #x1900) +(defconstant +red+ #x1903) +(defconstant +green+ #x1904) +(defconstant +blue+ #x1905) +(defconstant +alpha+ #x1906) +(defconstant +luminance+ #x1909) +(defconstant +luminance-alpha+ #x190a) +(defconstant +alpha-bits+ #x0d55) +(defconstant +red-bits+ #x0d52) +(defconstant +green-bits+ #x0d53) +(defconstant +blue-bits+ #x0d54) +(defconstant +index-bits+ #x0d51) +(defconstant +subpixel-bits+ #x0d50) +(defconstant +aux-buffers+ #x0c00) +(defconstant +read-buffer+ #x0c02) +(defconstant +draw-buffer+ #x0c01) +(defconstant +doublebuffer+ #x0c32) +(defconstant +stereo+ #x0c33) +(defconstant +bitmap+ #x1a00) +(defconstant +color+ #x1800) +(defconstant +depth+ #x1801) +(defconstant +stencil+ #x1802) +(defconstant +dither+ #x0bd0) +(defconstant +rgb+ #x1907) +(defconstant +rgba+ #x1908) + +;; Implementation Limits + +(defconstant +max-list-nesting+ #x0b31) +(defconstant +max-attrib-stack-depth+ #x0d35) +(defconstant +max-modelview-stack-depth+ #x0d36) +(defconstant +max-name-stack-depth+ #x0d37) +(defconstant +max-projection-stack-depth+ #x0d38) +(defconstant +max-texture-stack-depth+ #x0d39) +(defconstant +max-eval-order+ #x0d30) +(defconstant +max-lights+ #x0d31) +(defconstant +max-clip-planes+ #x0d32) +(defconstant +max-texture-size+ #x0d33) +(defconstant +max-pixel-map-table+ #x0d34) +(defconstant +max-viewport-dims+ #x0d3a) +(defconstant +max-client-attrib-stack-depth+ #x0d3b) + +;; Gets + +(defconstant +attrib-stack-depth+ #x0bb0) +(defconstant +client-attrib-stack-depth+ #x0bb1) +(defconstant +color-clear-value+ #x0c22) +(defconstant +color-writemask+ #x0c23) +(defconstant +current-index+ #x0b01) +(defconstant +current-color+ #x0b00) +(defconstant +current-normal+ #x0b02) +(defconstant +current-raster-color+ #x0b04) +(defconstant +current-raster-distance+ #x0b09) +(defconstant +current-raster-index+ #x0b05) +(defconstant +current-raster-position+ #x0b07) +(defconstant +current-raster-texture-coords+ #x0b06) +(defconstant +current-raster-position-valid+ #x0b08) +(defconstant +current-texture-coords+ #x0b03) +(defconstant +index-clear-value+ #x0c20) +(defconstant +index-mode+ #x0c30) +(defconstant +index-writemask+ #x0c21) +(defconstant +modelview-matrix+ #x0ba6) +(defconstant +modelview-stack-depth+ #x0ba3) +(defconstant +name-stack-depth+ #x0d70) +(defconstant +projection-matrix+ #x0ba7) +(defconstant +projection-stack-depth+ #x0ba4) +(defconstant +render-mode+ #x0c40) +(defconstant +rgba-mode+ #x0c31) +(defconstant +texture-matrix+ #x0ba8) +(defconstant +texture-stack-depth+ #x0ba5) +(defconstant +viewport+ #x0ba2) + +;; GL Evaluators + +(defconstant +auto-normal+ #x0d80) +(defconstant +map1-color-4+ #x0d90) +(defconstant +map1-grid-domain+ #x0dd0) +(defconstant +map1-grid-segments+ #x0dd1) +(defconstant +map1-index+ #x0d91) +(defconstant +map1-normal+ #x0d92) +(defconstant +map1-texture-coord-1+ #x0d93) +(defconstant +map1-texture-coord-2+ #x0d94) +(defconstant +map1-texture-coord-3+ #x0d95) +(defconstant +map1-texture-coord-4+ #x0d96) +(defconstant +map1-vertex-3+ #x0d97) +(defconstant +map1-vertex-4+ #x0d98) +(defconstant +map2-color-4+ #x0db0) +(defconstant +map2-grid-domain+ #x0dd2) +(defconstant +map2-grid-segments+ #x0dd3) +(defconstant +map2-index+ #x0db1) +(defconstant +map2-normal+ #x0db2) +(defconstant +map2-texture-coord-1+ #x0db3) +(defconstant +map2-texture-coord-2+ #x0db4) +(defconstant +map2-texture-coord-3+ #x0db5) +(defconstant +map2-texture-coord-4+ #x0db6) +(defconstant +map2-vertex-3+ #x0db7) +(defconstant +map2-vertex-4+ #x0db8) +(defconstant +coeff+ #x0a00) +(defconstant +domain+ #x0a02) +(defconstant +order+ #x0a01) + +;; Hints + +(defconstant +fog-hint+ #x0c54) +(defconstant +line-smooth-hint+ #x0c52) +(defconstant +perspective-correction-hint+ #x0c50) +(defconstant +point-smooth-hint+ #x0c51) +(defconstant +polygon-smooth-hint+ #x0c53) +(defconstant +dont-care+ #x1100) +(defconstant +fastest+ #x1101) +(defconstant +nicest+ #x1102) + +;; Scissor box + +(defconstant +scissor-test+ #x0c11) +(defconstant +scissor-box+ #x0c10) + +;; Pixel Mode / Transfer + +(defconstant +map-color+ #x0d10) +(defconstant +map-stencil+ #x0d11) +(defconstant +index-shift+ #x0d12) +(defconstant +index-offset+ #x0d13) +(defconstant +red-scale+ #x0d14) +(defconstant +red-bias+ #x0d15) +(defconstant +green-scale+ #x0d18) +(defconstant +green-bias+ #x0d19) +(defconstant +blue-scale+ #x0d1a) +(defconstant +blue-bias+ #x0d1b) +(defconstant +alpha-scale+ #x0d1c) +(defconstant +alpha-bias+ #x0d1d) +(defconstant +depth-scale+ #x0d1e) +(defconstant +depth-bias+ #x0d1f) +(defconstant +pixel-map-s-to-s-size+ #x0cb1) +(defconstant +pixel-map-i-to-i-size+ #x0cb0) +(defconstant +pixel-map-i-to-r-size+ #x0cb2) +(defconstant +pixel-map-i-to-g-size+ #x0cb3) +(defconstant +pixel-map-i-to-b-size+ #x0cb4) +(defconstant +pixel-map-i-to-a-size+ #x0cb5) +(defconstant +pixel-map-r-to-r-size+ #x0cb6) +(defconstant +pixel-map-g-to-g-size+ #x0cb7) +(defconstant +pixel-map-b-to-b-size+ #x0cb8) +(defconstant +pixel-map-a-to-a-size+ #x0cb9) +(defconstant +pixel-map-s-to-s+ #x0c71) +(defconstant +pixel-map-i-to-i+ #x0c70) +(defconstant +pixel-map-i-to-r+ #x0c72) +(defconstant +pixel-map-i-to-g+ #x0c73) +(defconstant +pixel-map-i-to-b+ #x0c74) +(defconstant +pixel-map-i-to-a+ #x0c75) +(defconstant +pixel-map-r-to-r+ #x0c76) +(defconstant +pixel-map-g-to-g+ #x0c77) +(defconstant +pixel-map-b-to-b+ #x0c78) +(defconstant +pixel-map-a-to-a+ #x0c79) +(defconstant +pack-alignment+ #x0d05) +(defconstant +pack-lsb-first+ #x0d01) +(defconstant +pack-row-length+ #x0d02) +(defconstant +pack-skip-pixels+ #x0d04) +(defconstant +pack-skip-rows+ #x0d03) +(defconstant +pack-swap-bytes+ #x0d00) +(defconstant +unpack-alignment+ #x0cf5) +(defconstant +unpack-lsb-first+ #x0cf1) +(defconstant +unpack-row-length+ #x0cf2) +(defconstant +unpack-skip-pixels+ #x0cf4) +(defconstant +unpack-skip-rows+ #x0cf3) +(defconstant +unpack-swap-bytes+ #x0cf0) +(defconstant +zoom-x+ #x0d16) +(defconstant +zoom-y+ #x0d17) + +;; Texture Mapping + +(defconstant +texture-env+ #x2300) +(defconstant +texture-env-mode+ #x2200) +(defconstant +texture-1d+ #x0de0) +(defconstant +texture-2d+ #x0de1) +(defconstant +texture-wrap-s+ #x2802) +(defconstant +texture-wrap-t+ #x2803) +(defconstant +texture-mag-filter+ #x2800) +(defconstant +texture-min-filter+ #x2801) +(defconstant +texture-env-color+ #x2201) +(defconstant +texture-gen-s+ #x0c60) +(defconstant +texture-gen-t+ #x0c61) +(defconstant +texture-gen-mode+ #x2500) +(defconstant +texture-border-color+ #x1004) +(defconstant +texture-width+ #x1000) +(defconstant +texture-height+ #x1001) +(defconstant +texture-border+ #x1005) +(defconstant +texture-components+ #x1003) +(defconstant +texture-red-size+ #x805c) +(defconstant +texture-green-size+ #x805d) +(defconstant +texture-blue-size+ #x805e) +(defconstant +texture-alpha-size+ #x805f) +(defconstant +texture-luminance-size+ #x8060) +(defconstant +texture-intensity-size+ #x8061) +(defconstant +nearest-mipmap-nearest+ #x2700) +(defconstant +nearest-mipmap-linear+ #x2702) +(defconstant +linear-mipmap-nearest+ #x2701) +(defconstant +linear-mipmap-linear+ #x2703) +(defconstant +object-linear+ #x2401) +(defconstant +object-plane+ #x2501) +(defconstant +eye-linear+ #x2400) +(defconstant +eye-plane+ #x2502) +(defconstant +sphere-map+ #x2402) +(defconstant +decal+ #x2101) +(defconstant +modulate+ #x2100) +(defconstant +nearest+ #x2600) +(defconstant +repeat+ #x2901) +(defconstant +clamp+ #x2900) +(defconstant +s+ #x2000) +(defconstant +t+ #x2001) +(defconstant +r+ #x2002) +(defconstant +q+ #x2003) +(defconstant +texture-gen-r+ #x0c62) +(defconstant +texture-gen-q+ #x0c63) + +;; GL 1.1 Texturing + +(defconstant +proxy-texture-1d+ #x8063) +(defconstant +proxy-texture-2d+ #x8064) +(defconstant +texture-priority+ #x8066) +(defconstant +texture-resident+ #x8067) +(defconstant +texture-binding-1d+ #x8068) +(defconstant +texture-binding-2d+ #x8069) +(defconstant +texture-internal-format+ #x1003) +(defconstant +pack-skip-images+ #x806b) +(defconstant +pack-image-height+ #x806c) +(defconstant +unpack-skip-images+ #x806d) +(defconstant +unpack-image-height+ #x806e) +(defconstant +texture-3d+ #x806f) +(defconstant +proxy-texture-3d+ #x8070) +(defconstant +texture-depth+ #x8071) +(defconstant +texture-wrap-r+ #x8072) +(defconstant +max-3d-texture-size+ #x8073) +(defconstant +texture-binding-3d+ #x806a) + +;; Internal texture formats (GL 1.1) +(defconstant +alpha4+ #x803b) +(defconstant +alpha8+ #x803c) +(defconstant +alpha12+ #x803d) +(defconstant +alpha16+ #x803e) +(defconstant +luminance4+ #x803f) +(defconstant +luminance8+ #x8040) +(defconstant +luminance12+ #x8041) +(defconstant +luminance16+ #x8042) +(defconstant +luminance4-alpha4+ #x8043) +(defconstant +luminance6-alpha2+ #x8044) +(defconstant +luminance8-alpha8+ #x8045) +(defconstant +luminance12-alpha4+ #x8046) +(defconstant +luminance12-alpha12+ #x8047) +(defconstant +luminance16-alpha16+ #x8048) +(defconstant +intensity+ #x8049) +(defconstant +intensity4+ #x804a) +(defconstant +intensity8+ #x804b) +(defconstant +intensity12+ #x804c) +(defconstant +intensity16+ #x804d) +(defconstant +r3-g3-b2+ #x2a10) +(defconstant +rgb4+ #x804f) +(defconstant +rgb5+ #x8050) +(defconstant +rgb8+ #x8051) +(defconstant +rgb10+ #x8052) +(defconstant +rgb12+ #x8053) +(defconstant +rgb16+ #x8054) +(defconstant +rgba2+ #x8055) +(defconstant +rgba4+ #x8056) +(defconstant +rgb5-a1+ #x8057) +(defconstant +rgba8+ #x8058) +(defconstant +rgb10-a2+ #x8059) +(defconstant +rgba12+ #x805a) +(defconstant +rgba16+ #x805b) + +;; Utility + +(defconstant +vendor+ #x1f00) +(defconstant +renderer+ #x1f01) +(defconstant +version+ #x1f02) +(defconstant +extensions+ #x1f03) + +;; Errors + +(defconstant +no-error+ #x0) +(defconstant +invalid-value+ #x0501) +(defconstant +invalid-enum+ #x0500) +(defconstant +invalid-operation+ #x0502) +(defconstant +stack-overflow+ #x0503) +(defconstant +stack-underflow+ #x0504) +(defconstant +out-of-memory+ #x0505) + +;; OpenGL 1.2 + +(defconstant +rescale-normal+ #x803a) +(defconstant +clamp-to-edge+ #x812f) +(defconstant +max-elements-vertices+ #x80e8) +(defconstant +max-elements-indices+ #x80e9) +(defconstant +bgr+ #x80e0) +(defconstant +bgra+ #x80e1) +(defconstant +unsigned-byte-3-3-2+ #x8032) +(defconstant +unsigned-byte-2-3-3-rev+ #x8362) +(defconstant +unsigned-short-5-6-5+ #x8363) +(defconstant +unsigned-short-5-6-5-rev+ #x8364) +(defconstant +unsigned-short-4-4-4-4+ #x8033) +(defconstant +unsigned-short-4-4-4-4-rev+ #x8365) +(defconstant +unsigned-short-5-5-5-1+ #x8034) +(defconstant +unsigned-short-1-5-5-5-rev+ #x8366) +(defconstant +unsigned-int-8-8-8-8+ #x8035) +(defconstant +unsigned-int-8-8-8-8-rev+ #x8367) +(defconstant +unsigned-int-10-10-10-2+ #x8036) +(defconstant +unsigned-int-2-10-10-10-rev+ #x8368) +(defconstant +light-model-color-control+ #x81f8) +(defconstant +single-color+ #x81f9) +(defconstant +separate-specular-color+ #x81fa) +(defconstant +texture-min-lod+ #x813a) +(defconstant +texture-max-lod+ #x813b) +(defconstant +texture-base-level+ #x813c) +(defconstant +texture-max-level+ #x813d) +(defconstant +smooth-point-size-range+ #x0b12) +(defconstant +smooth-point-size-granularity+ #x0b13) +(defconstant +smooth-line-width-range+ #x0b22) +(defconstant +smooth-line-width-granularity+ #x0b23) +(defconstant +aliased-point-size-range+ #x846d) +(defconstant +aliased-line-width-range+ #x846e) + +;; OpenGL 1.2 Imaging subset +;; GL_EXT_color_table +(defconstant +color-table+ #x80d0) +(defconstant +post-convolution-color-table+ #x80d1) +(defconstant +post-color-matrix-color-table+ #x80d2) +(defconstant +proxy-color-table+ #x80d3) +(defconstant +proxy-post-convolution-color-table+ #x80d4) +(defconstant +proxy-post-color-matrix-color-table+ #x80d5) +(defconstant +color-table-scale+ #x80d6) +(defconstant +color-table-bias+ #x80d7) +(defconstant +color-table-format+ #x80d8) +(defconstant +color-table-width+ #x80d9) +(defconstant +color-table-red-size+ #x80da) +(defconstant +color-table-green-size+ #x80db) +(defconstant +color-table-blue-size+ #x80dc) +(defconstant +color-table-alpha-size+ #x80dd) +(defconstant +color-table-luminance-size+ #x80de) +(defconstant +color-table-intensity-size+ #x80df) +;; GL_EXT_convolution and GL_HP_convolution +(defconstant +convolution-1d+ #x8010) +(defconstant +convolution-2d+ #x8011) +(defconstant +separable-2d+ #x8012) +(defconstant +convolution-border-mode+ #x8013) +(defconstant +convolution-filter-scale+ #x8014) +(defconstant +convolution-filter-bias+ #x8015) +(defconstant +reduce+ #x8016) +(defconstant +convolution-format+ #x8017) +(defconstant +convolution-width+ #x8018) +(defconstant +convolution-height+ #x8019) +(defconstant +max-convolution-width+ #x801a) +(defconstant +max-convolution-height+ #x801b) +(defconstant +post-convolution-red-scale+ #x801c) +(defconstant +post-convolution-green-scale+ #x801d) +(defconstant +post-convolution-blue-scale+ #x801e) +(defconstant +post-convolution-alpha-scale+ #x801f) +(defconstant +post-convolution-red-bias+ #x8020) +(defconstant +post-convolution-green-bias+ #x8021) +(defconstant +post-convolution-blue-bias+ #x8022) +(defconstant +post-convolution-alpha-bias+ #x8023) +(defconstant +constant-border+ #x8151) +(defconstant +replicate-border+ #x8153) +(defconstant +convolution-border-color+ #x8154) +;; GL_SGI_color_matrix +(defconstant +color-matrix+ #x80b1) +(defconstant +color-matrix-stack-depth+ #x80b2) +(defconstant +max-color-matrix-stack-depth+ #x80b3) +(defconstant +post-color-matrix-red-scale+ #x80b4) +(defconstant +post-color-matrix-green-scale+ #x80b5) +(defconstant +post-color-matrix-blue-scale+ #x80b6) +(defconstant +post-color-matrix-alpha-scale+ #x80b7) +(defconstant +post-color-matrix-red-bias+ #x80b8) +(defconstant +post-color-matrix-green-bias+ #x80b9) +(defconstant +post-color-matrix-blue-bias+ #x80ba) +(defconstant +post-color-matrix-alpha-bias+ #x80bb) +;; GL_EXT_histogram +(defconstant +histogram+ #x8024) +(defconstant +proxy-histogram+ #x8025) +(defconstant +histogram-width+ #x8026) +(defconstant +histogram-format+ #x8027) +(defconstant +histogram-red-size+ #x8028) +(defconstant +histogram-green-size+ #x8029) +(defconstant +histogram-blue-size+ #x802a) +(defconstant +histogram-alpha-size+ #x802b) +(defconstant +histogram-luminance-size+ #x802c) +(defconstant +histogram-sink+ #x802d) +(defconstant +minmax+ #x802e) +(defconstant +minmax-format+ #x802f) +(defconstant +minmax-sink+ #x8030) +(defconstant +table-too-large+ #x8031) +;; GL_EXT_blend_color, GL_EXT_blend_minmax +(defconstant +blend-equation+ #x8009) +(defconstant +min+ #x8007) +(defconstant +max+ #x8008) +(defconstant +func-add+ #x8006) +(defconstant +func-subtract+ #x800a) +(defconstant +func-reverse-subtract+ #x800b) + +;; glPush/PopAttrib bits + +(defconstant +current-bit+ #x00000001) +(defconstant +point-bit+ #x00000002) +(defconstant +line-bit+ #x00000004) +(defconstant +polygon-bit+ #x00000008) +(defconstant +polygon-stipple-bit+ #x00000010) +(defconstant +pixel-mode-bit+ #x00000020) +(defconstant +lighting-bit+ #x00000040) +(defconstant +fog-bit+ #x00000080) +(defconstant +depth-buffer-bit+ #x00000100) +(defconstant +accum-buffer-bit+ #x00000200) +(defconstant +stencil-buffer-bit+ #x00000400) +(defconstant +viewport-bit+ #x00000800) +(defconstant +transform-bit+ #x00001000) +(defconstant +enable-bit+ #x00002000) +(defconstant +color-buffer-bit+ #x00004000) +(defconstant +hint-bit+ #x00008000) +(defconstant +eval-bit+ #x00010000) +(defconstant +list-bit+ #x00020000) +(defconstant +texture-bit+ #x00040000) +(defconstant +scissor-bit+ #x00080000) +(defconstant +all-attrib-bits+ #x000fffff) +(defconstant +client-pixel-store-bit+ #x00000001) +(defconstant +client-vertex-array-bit+ #x00000002) +(defconstant +client-all-attrib-bits+ #xffffffff) + +;; ARB Multitexturing extension + +(defconstant +arb-multitexture+ 1) +(defconstant +texture0-arb+ #x84c0) +(defconstant +texture1-arb+ #x84c1) +(defconstant +texture2-arb+ #x84c2) +(defconstant +texture3-arb+ #x84c3) +(defconstant +texture4-arb+ #x84c4) +(defconstant +texture5-arb+ #x84c5) +(defconstant +texture6-arb+ #x84c6) +(defconstant +texture7-arb+ #x84c7) +(defconstant +texture8-arb+ #x84c8) +(defconstant +texture9-arb+ #x84c9) +(defconstant +texture10-arb+ #x84ca) +(defconstant +texture11-arb+ #x84cb) +(defconstant +texture12-arb+ #x84cc) +(defconstant +texture13-arb+ #x84cd) +(defconstant +texture14-arb+ #x84ce) +(defconstant +texture15-arb+ #x84cf) +(defconstant +texture16-arb+ #x84d0) +(defconstant +texture17-arb+ #x84d1) +(defconstant +texture18-arb+ #x84d2) +(defconstant +texture19-arb+ #x84d3) +(defconstant +texture20-arb+ #x84d4) +(defconstant +texture21-arb+ #x84d5) +(defconstant +texture22-arb+ #x84d6) +(defconstant +texture23-arb+ #x84d7) +(defconstant +texture24-arb+ #x84d8) +(defconstant +texture25-arb+ #x84d9) +(defconstant +texture26-arb+ #x84da) +(defconstant +texture27-arb+ #x84db) +(defconstant +texture28-arb+ #x84dc) +(defconstant +texture29-arb+ #x84dd) +(defconstant +texture30-arb+ #x84de) +(defconstant +texture31-arb+ #x84df) +(defconstant +active-texture-arb+ #x84e0) +(defconstant +client-active-texture-arb+ #x84e1) +(defconstant +max-texture-units-arb+ #x84e2) + +;;; Misc extensions + +(defconstant +ext-abgr+ 1) +(defconstant +abgr-ext+ #x8000) +(defconstant +ext-blend-color+ 1) +(defconstant +constant-color-ext+ #x8001) +(defconstant +one-minus-constant-color-ext+ #x8002) +(defconstant +constant-alpha-ext+ #x8003) +(defconstant +one-minus-constant-alpha-ext+ #x8004) +(defconstant +blend-color-ext+ #x8005) +(defconstant +ext-polygon-offset+ 1) +(defconstant +polygon-offset-ext+ #x8037) +(defconstant +polygon-offset-factor-ext+ #x8038) +(defconstant +polygon-offset-bias-ext+ #x8039) +(defconstant +ext-texture3d+ 1) +(defconstant +pack-skip-images-ext+ #x806b) +(defconstant +pack-image-height-ext+ #x806c) +(defconstant +unpack-skip-images-ext+ #x806d) +(defconstant +unpack-image-height-ext+ #x806e) +(defconstant +texture-3d-ext+ #x806f) +(defconstant +proxy-texture-3d-ext+ #x8070) +(defconstant +texture-depth-ext+ #x8071) +(defconstant +texture-wrap-r-ext+ #x8072) +(defconstant +max-3d-texture-size-ext+ #x8073) +(defconstant +texture-3d-binding-ext+ #x806a) +(defconstant +ext-texture-object+ 1) +(defconstant +texture-priority-ext+ #x8066) +(defconstant +texture-resident-ext+ #x8067) +(defconstant +texture-1d-binding-ext+ #x8068) +(defconstant +texture-2d-binding-ext+ #x8069) +(defconstant +ext-rescale-normal+ 1) +(defconstant +rescale-normal-ext+ #x803a) +(defconstant +ext-vertex-array+ 1) +(defconstant +vertex-array-ext+ #x8074) +(defconstant +normal-array-ext+ #x8075) +(defconstant +color-array-ext+ #x8076) +(defconstant +index-array-ext+ #x8077) +(defconstant +texture-coord-array-ext+ #x8078) +(defconstant +edge-flag-array-ext+ #x8079) +(defconstant +vertex-array-size-ext+ #x807a) +(defconstant +vertex-array-type-ext+ #x807b) +(defconstant +vertex-array-stride-ext+ #x807c) +(defconstant +vertex-array-count-ext+ #x807d) +(defconstant +normal-array-type-ext+ #x807e) +(defconstant +normal-array-stride-ext+ #x807f) +(defconstant +normal-array-count-ext+ #x8080) +(defconstant +color-array-size-ext+ #x8081) +(defconstant +color-array-type-ext+ #x8082) +(defconstant +color-array-stride-ext+ #x8083) +(defconstant +color-array-count-ext+ #x8084) +(defconstant +index-array-type-ext+ #x8085) +(defconstant +index-array-stride-ext+ #x8086) +(defconstant +index-array-count-ext+ #x8087) +(defconstant +texture-coord-array-size-ext+ #x8088) +(defconstant +texture-coord-array-type-ext+ #x8089) +(defconstant +texture-coord-array-stride-ext+ #x808a) +(defconstant +texture-coord-array-count-ext+ #x808b) +(defconstant +edge-flag-array-stride-ext+ #x808c) +(defconstant +edge-flag-array-count-ext+ #x808d) +(defconstant +vertex-array-pointer-ext+ #x808e) +(defconstant +normal-array-pointer-ext+ #x808f) +(defconstant +color-array-pointer-ext+ #x8090) +(defconstant +index-array-pointer-ext+ #x8091) +(defconstant +texture-coord-array-pointer-ext+ #x8092) +(defconstant +edge-flag-array-pointer-ext+ #x8093) +(defconstant +sgis-texture-edge-clamp+ 1) +(defconstant +clamp-to-edge-sgis+ #x812f) +(defconstant +ext-blend-minmax+ 1) +(defconstant +func-add-ext+ #x8006) +(defconstant +min-ext+ #x8007) +(defconstant +max-ext+ #x8008) +(defconstant +blend-equation-ext+ #x8009) +(defconstant +ext-blend-subtract+ 1) +(defconstant +func-subtract-ext+ #x800a) +(defconstant +func-reverse-subtract-ext+ #x800b) +(defconstant +ext-blend-logic-op+ 1) +(defconstant +ext-point-parameters+ 1) +(defconstant +point-size-min-ext+ #x8126) +(defconstant +point-size-max-ext+ #x8127) +(defconstant +point-fade-threshold-size-ext+ #x8128) +(defconstant +distance-attenuation-ext+ #x8129) +(defconstant +ext-paletted-texture+ 1) +(defconstant +table-too-large-ext+ #x8031) +(defconstant +color-table-format-ext+ #x80d8) +(defconstant +color-table-width-ext+ #x80d9) +(defconstant +color-table-red-size-ext+ #x80da) +(defconstant +color-table-green-size-ext+ #x80db) +(defconstant +color-table-blue-size-ext+ #x80dc) +(defconstant +color-table-alpha-size-ext+ #x80dd) +(defconstant +color-table-luminance-size-ext+ #x80de) +(defconstant +color-table-intensity-size-ext+ #x80df) +(defconstant +texture-index-size-ext+ #x80ed) +(defconstant +color-index1-ext+ #x80e2) +(defconstant +color-index2-ext+ #x80e3) +(defconstant +color-index4-ext+ #x80e4) +(defconstant +color-index8-ext+ #x80e5) +(defconstant +color-index12-ext+ #x80e6) +(defconstant +color-index16-ext+ #x80e7) +(defconstant +ext-clip-volume-hint+ 1) +(defconstant +clip-volume-clipping-hint-ext+ #x80f0) +(defconstant +ext-compiled-vertex-array+ 1) +(defconstant +array-element-lock-first-ext+ #x81a8) +(defconstant +array-element-lock-count-ext+ #x81a9) +(defconstant +hp-occlusion-test+ 1) +(defconstant +occlusion-test-hp+ #x8165) +(defconstant +occlusion-test-result-hp+ #x8166) +(defconstant +ext-shared-texture-palette+ 1) +(defconstant +shared-texture-palette-ext+ #x81fb) +(defconstant +ext-stencil-wrap+ 1) +(defconstant +incr-wrap-ext+ #x8507) +(defconstant +decr-wrap-ext+ #x8508) +(defconstant +nv-texgen-reflection+ 1) +(defconstant +normal-map-nv+ #x8511) +(defconstant +reflection-map-nv+ #x8512) +(defconstant +ext-texture-env-add+ 1) +(defconstant +mesa-window-pos+ 1) +(defconstant +mesa-resize-buffers+ 1) +) + + + +;;; Utility stuff + +(deftype bool () 'card8) +(deftype float32 () 'single-float) +(deftype float64 () 'double-float) + +(declaim (inline aset-float32 aset-float64)) + +#+sbcl +(defun aset-float32 (value array index) + (declare (type single-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((bits (sb-kernel:single-float-bits value))) + (declare (type (unsigned-byte 32) bits)) + (aset-card32 bits array index)) + value) + + +#+cmu +(defun aset-float32 (value array index) + (declare (type single-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((bits (kernel:single-float-bits value))) + (declare (type (unsigned-byte 32) bits)) + (aset-card32 bits array index)) + value) + + +#+openmcl +(defun aset-float32 (value array index) + (declare (type single-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((bits (ccl::single-float-bits value))) + (declare (type (unsigned-byte 32) bits)) + (aset-card32 bits array index)) + value) + + +#+sbcl +(defun aset-float64 (value array index) + (declare (type double-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((low (sb-kernel:double-float-low-bits value)) + (high (sb-kernel:double-float-high-bits value))) + (declare (type (unsigned-byte 32) low high)) + (aset-card32 low array index) + (aset-card32 high array (the array-index (+ index 4)))) + value) + + +#+cmu +(defun aset-float64 (value array index) + (declare (type double-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((low (kernel:double-float-low-bits value)) + (high (kernel:double-float-high-bits value))) + (declare (type (unsigned-byte 32) low high)) + (aset-card32 low array index) + (aset-card32 high array (+ index 4))) + value) + + +#+openmcl +(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) + (ccl::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 + ((int8 card8 bool) 1) + ((int16 card16) 2) + ((int32 card32 float32) 4) + ((float64) 8))) + + +(defun setter (type) + (ecase type + (int8 'aset-int8) + (int16 'aset-int16) + (int32 'aset-int32) + (bool 'aset-card8) + (card8 'aset-card8) + (card16 'aset-card16) + (card32 'aset-card32) + (float32 'aset-float32) + (float64 'aset-float64))) + + +(defun sequence-setter (type) + (ecase type + (int8 'sset-int8) + (int16 'sset-int16) + (int32 'sset-int32) + (bool 'sset-card8) + (card8 'sset-card8) + (card16 'sset-card16) + (card32 'sset-card32) + (float32 'sset-float32) + (float64 'sset-float64))) + + +(defmacro define-sequence-setter (type) + `(defun ,(intern (format nil "~A-~A" 'sset type)) (seq buffer start length) + (declare (type sequence seq) + (type buffer-bytes buffer) + (type array-index start) + (type fixnum length)) + #.(declare-buffun) + (assert (= length (length seq)) + (length seq) + "SEQUENCE length should be ~D, not ~D." length (length seq)) + (typecase seq + (list + (let ((offset 0)) + (declare (type fixnum offset)) + (dolist (n seq) + (declare (type ,type n)) + (,(setter type) n buffer (the array-index (+ start offset))) + (incf offset ,(byte-width type))))) + ((simple-array ,type) + (dotimes (i ,(byte-width type)) + (,(setter type) + (aref seq i) + buffer + (the array-index (+ start (* i ,(byte-width type))))))) + (vector + (dotimes (i ,(byte-width type)) + (,(setter type) + (svref seq i) + buffer + (the array-index (+ start (* i ,(byte-width type)))))))))) + + +(define-sequence-setter int8) +(define-sequence-setter int16) +(define-sequence-setter int32) +(define-sequence-setter bool) +(define-sequence-setter card8) +(define-sequence-setter card16) +(define-sequence-setter card32) +(define-sequence-setter float32) +(define-sequence-setter float64) + + + +(defun make-argspecs (list) + (destructuring-bind (name type) + list + (etypecase type + (symbol `(,name ,type 1 nil)) + (list + `(,name + ,(second type) + ,(third type) + ,(if (consp (third type)) + (make-symbol (format nil "~A-~A" name 'length)) + nil)))))) + + +(defun byte-width-calculation (argspecs) + (let ((constant 0) + (calculated ())) + (loop + for (name type length length-var) in argspecs + do (let ((byte-width (byte-width type))) + (typecase length + (number (incf constant (* byte-width length))) + (symbol (push `(* ,byte-width ,length) calculated)) + (cons (push `(* ,byte-width ,length-var) calculated))))) + (if (null calculated) + constant + (list* '+ constant calculated)))) + + +(defun composite-args (argspecs) + (loop + for (name type length length-var) in argspecs + when (consp length) + collect (list length-var length))) + + +(defun make-setter-forms (argspecs) + (loop + for (name type length length-var) in argspecs + collecting `(progn + ,(if (and (numberp length) + (= 1 length)) + `(,(setter type) ,name .rbuf. .index.) + `(,(sequence-setter type) ,name .rbuf. .index. + ,(if length-var length-var length))) + (setf .index. (the array-index + (+ .index. + (the fixnum (* ,(byte-width type) + ,(if length-var length-var length))))))))) + + +(defmacro define-rendering-command (name opcode &rest args) + ;; FIXME: Must heavily type-annotate. + (labels ((expand-args (list) + (loop + for (arg type) in list + if (consp arg) + append (loop + for name in arg + collecting (list name type)) + else + collect (list arg type)))) + + (let* ((args (expand-args args)) + (argspecs (mapcar 'make-argspecs args)) + (total-byte-width (byte-width-calculation argspecs)) + (composite-args (composite-args argspecs))) + + `(defun ,name ,(mapcar #'first argspecs) + (declare ,@(mapcar #'(lambda (list) + (if (symbolp (second list)) + (list* 'type (reverse list)) + `(type sequence ,(first list)))) + args)) + #.(declare-buffun) + (assert (context-p *current-context*) + (*current-context*) + "*CURRENT-CONTEXT* is not set (~S)." *current-context*) + (let* ((.ctx. *current-context*) + (.index0. (context-index .ctx.)) + (.index. (+ .index0. 4)) + (.rbuf. (context-rbuf .ctx.)) + ,@composite-args + (.length. (+ 4 (* 4 (ceiling ,total-byte-width 4))))) + + (declare (type context .ctx.) + (type array-index .index. .index0.) + (type buffer-bytes .rbuf.) + ,@(mapcar #'(lambda (list) + `(type fixnum ,(first list))) + composite-args) + (type fixnum .length.)) + + (when (< (- (length .rbuf.) 8) + (+ .index. .length.)) + (error "Rendering command sequence too long. Implement automatic buffer flushing.")) + + (aset-card16 .length. .rbuf. (the array-index .index0.)) + (aset-card16 ,opcode .rbuf. (the array-index (+ .index0. 2))) + ,@(make-setter-forms argspecs) + (setf (context-index .ctx.) (the array-index (+ .index0. .length.)))))))) + +) ;; eval-when + + +;;; Command implementation. + + +(defun get-string (name) + (assert (context-p *current-context*) + (*current-context*) + "*CURRENT-CONTEXT* is not set (~S)." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +get-string+) + ;; *** This is CONTEXT-TAG + (card32 (context-tag ctx)) + ;; *** This is ENUM. + (card32 name)) + (let* ((length (card32-get 12)) + (bytes (sequence-get :format card8 + :result-type '(simple-array card8 (*)) + :index 32 + :length length))) + (declare (type (simple-array card8 (*)) bytes) + (type fixnum length)) + ;; FIXME: How does this interact with unicode? + (map-into (make-string (1- length)) #'code-char bytes))))) + + + + +;;; Rendering commands (in alphabetical order). + + +(define-rendering-command accum 137 + ;; *** ENUM + (op card32) + (value float32)) + + +(define-rendering-command active-texture-arb 197 + ;; *** ENUM + (texture card32)) + + +(define-rendering-command alpha-func 159 + ;; *** ENUM + (func card32) + (ref float32)) + + +(define-rendering-command begin 4 + ;; *** ENUM + (mode card32)) + + +(define-rendering-command bind-texture 4117 + ;; *** ENUM + (target card32) + (texture card32)) + + +(define-rendering-command blend-color 4096 + (red float32) + (green float32) + (blue float32) + (alpha float32)) + + +(define-rendering-command blend-equotion 4097 + ;; *** ENUM + (mode card32)) + + +(define-rendering-command blend-func 160 + ;; *** ENUM + (sfactor card32) + ;; *** ENUM + (dfactor card32)) + + +(define-rendering-command call-list 1 + (list card32)) + + +(define-rendering-command clear 127 + ;; *** BITFIELD + (mask card32)) + + +(define-rendering-command clear-accum 128 + (red float32) + (green float32) + (blue float32) + (alpha float32)) + + +(define-rendering-command clear-color 130 + (red float32) + (green float32) + (blue float32) + (alpha float32)) + + +(define-rendering-command clear-depth 132 + (depth float64)) + + +(define-rendering-command clear-index 129 + (c float32)) + + +(define-rendering-command clear-stencil 131 + (s int32)) + + +(define-rendering-command clip-plane 77 + (equotion-0 float64) + (equotion-1 float64) + (equotion-2 float64) + (equotion-3 float64) + ;; *** ENUM + (plane card32)) + + +(define-rendering-command color-3b 6 + ((r g b) int8)) + +(define-rendering-command color-3d 7 + ((r g b) float64)) + +(define-rendering-command color-3f 8 + ((r g b) float32)) + +(define-rendering-command color-3i 9 + ((r g b) int32)) + +(define-rendering-command color-3s 10 + ((r g b) int16)) + +(define-rendering-command color-3ub 11 + ((r g b) card8)) + +(define-rendering-command color-3ui 12 + ((r g b) card32)) + +(define-rendering-command color-3us 13 + ((r g b) card16)) + + +(define-rendering-command color-4b 14 + ((r g b a) int8)) + +(define-rendering-command color-4d 15 + ((r g b a) float64)) + +(define-rendering-command color-4f 16 + ((r g b a) float32)) + +(define-rendering-command color-4i 17 + ((r g b a) int32)) + +(define-rendering-command color-4s 18 + ((r g b a) int16)) + +(define-rendering-command color-4ub 19 + ((r g b a) card8)) + +(define-rendering-command color-4ui 20 + ((r g b a) card32)) + +(define-rendering-command color-4us 21 + ((r g b a) card16)) + + +(define-rendering-command color-mask 134 + (red bool) + (green bool) + (blue bool) + (alpha bool)) + + +(define-rendering-command color-material 78 + ;; *** ENUM + (face card32) + ;; *** ENUM + (mode card32)) + + +(define-rendering-command color-table-parameter-fv 2054 + ;; *** ENUM + (target card32) + ;; TODO: + ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 + ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 + ;; else (length params) = 0 (command is erronous) + ;; *** ENUM + (pname card32) + (params (list float32 4))) + + +(define-rendering-command color-table-parameter-iv 2055 + ;; *** ENUM + (target card32) + ;; TODO: + ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 + ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 + ;; else (length params) = 0 (command is erronous) + ;; *** ENUM + (pname card32) + (params (list int32 4))) + + +(define-rendering-command convolution-parameter-f 4103 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (params float32)) + + +(define-rendering-command convolution-parameter-fv 4104 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (params (list float32 (ecase pname + ((#.+convolution-border-mode+ + #.+convolution-format+ + #.+convolution-width+ + #.+convolution-height+ + #.+max-convolution-width+ + #.+max-convolution-width+) + 1) + ((#.+convolution-filter-scale+ + #.+convolution-filter-bias+) + 4))))) + + +(define-rendering-command convolution-parameter-i 4105 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (params int32)) + + +(define-rendering-command convolution-parameter-iv 4106 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (params (list int32 (ecase pname + ((#.+convolution-border-mode+ + #.+convolution-format+ + #.+convolution-width+ + #.+convolution-height+ + #.+max-convolution-width+ + #.+max-convolution-width+) + 1) + ((#.+convolution-filter-scale+ + #.+convolution-filter-bias+) + 4))))) + + +(define-rendering-command copy-color-sub-table 196 + ;; *** ENUM + (target card32) + (start int32) + (x int32) + (y int32) + (width int32)) + + +(define-rendering-command copy-color-table 2056 + ;; *** ENUM + (target card32) + ;; *** ENUM + (internalformat card32) + (x int32) + (y int32) + (width int32)) + + +(define-rendering-command copy-convolution-filter-id 4107 + ;; *** ENUM + (target card32) + ;; *** ENUM + (internalformat card32) + (x int32) + (y int32) + (width int32)) + + +(define-rendering-command copy-convolution-filter-2d 4108 + ;; *** ENUM + (target card32) + ;; *** ENUM + (internalformat card32) + (x int32) + (y int32) + (width int32) + (height int32)) + + +(define-rendering-command copy-pixels 172 + (x int32) + (y int32) + (width int32) + (height int32) + ;; *** ENUM + (type card32)) + + +(define-rendering-command copy-tex-image-1d 4119 + ;; *** ENUM + (target card32) + (level int32) + ;; *** ENUM + (internalformat card32) + (x int32) + (y int32) + (width int32) + (border int32)) + + +(define-rendering-command copy-tex-image-2d 4120 + ;; *** ENUM + (target card32) + (level int32) + ;; *** ENUM + (internalformat card32) + (x int32) + (y int32) + (width int32) + (height int32) + (border int32)) + + +(define-rendering-command copy-tex-sub-image-1d 4121 + ;; *** ENUM + (target card32) + (level int32) + (xoffset int32) + (x int32) + (y int32) + (width int32)) + + +(define-rendering-command copy-tex-sub-image-2d 4122 + ;; *** ENUM + (target card32) + (level int32) + (xoffset int32) + (yoffset int32) + (x int32) + (y int32) + (width int32) + (height int32)) + + +(define-rendering-command copy-tex-sub-image-3d 4123 + ;; *** ENUM + (target card32) + (level int32) + (xoffset int32) + (yoffset int32) + (zoffset int32) + (x int32) + (y int32) + (width int32) + (height int32)) + + +(define-rendering-command cull-face 79 + ;; *** ENUM + (mode card32)) + + +(define-rendering-command depth-func 164 + ;; *** ENUM + (func card32)) + + +(define-rendering-command depth-mask 135 + (mask bool)) + + +(define-rendering-command depth-range 174 + (z-near float64) + (z-far float64)) + + +(define-rendering-command draw-buffer 126 + ;; *** ENUM + (mode card32)) + + +(define-rendering-command edge-flag-v 22 + (flag-0 bool)) + + +(define-rendering-command end 23) + + +(define-rendering-command eval-coord-1d 151 + (u-0 float64)) + +(define-rendering-command eval-coord-1f 152 + (u-0 float32)) + + +(define-rendering-command eval-coord-2d 153 + ((u-0 u-1) float64)) + +(define-rendering-command eval-coord-2f 154 + ((u-0 u-1) float32)) + + +(define-rendering-command eval-mesh-1 155 + ;; *** ENUM + (mode card32) + ((i1 i2) int32)) + + +(define-rendering-command eval-mesh-2 157 + ;; *** ENUM + (mode card32) + ((i1 i2 j1 j2) int32)) + + +(define-rendering-command eval-point-1 156 + (i int32)) + + +(define-rendering-command eval-point-2 158 + (i int32) + (j int32)) + + +(define-rendering-command fog-f 80 + ;; *** ENUM + (pname card32) + (param float32)) + + +(define-rendering-command fog-fv 81 + ;; *** ENUM + (pname card32) + (params (list float32 (ecase pname + ((#.+fog-index+ + #.+fog-density+ + #.+fog-start+ + #.+fog-end+ + #.+fog-mode+) + 1) + ((#.+fog-color+) + 4))))) + + + +(define-rendering-command fog-i 82 + ;; *** ENUM + (pname card32) + (param int32)) + + +(define-rendering-command fog-iv 83 + ;; *** ENUM + (pname card32) + (params (list int32 (ecase pname + ((#.+fog-index+ + #.+fog-density+ + #.+fog-start+ + #.+fog-end+ + #.+fog-mode+) + 1) + ((#.+fog-color+) + 4))))) + + +(define-rendering-command front-face 84 + ;; *** ENUM + (mode card32)) + + +(define-rendering-command frustum 175 + (left float64) + (right float64) + (bottom float64) + (top float64) + (z-near float64) + (z-far float64)) + + +(define-rendering-command hint 85 + ;; *** ENUM + (target card32) + ;; *** ENUM + (mode card32)) + + +(define-rendering-command histogram 4110 + ;; *** ENUM + (target card32) + (width int32) + ;; *** ENUM + (internalformat card32) + (sink bool)) + + +(define-rendering-command index-mask 136 + (mask card32)) + + +(define-rendering-command index-d 24 + (c-0 float64)) + +(define-rendering-command index-f 25 + (c-0 float32)) + +(define-rendering-command index-i 26 + (c-0 int32)) + +(define-rendering-command index-s 27 + (c-0 int16)) + +(define-rendering-command index-ub 194 + (c-0 card8)) + + +(define-rendering-command init-names 121) + + +(define-rendering-command light-model-f 90 + ;; *** ENUM + (pname card32) + (param float32)) + + +(define-rendering-command light-model-fv 91 + ;; *** ENUM + (pname card32) + (params (list float32 (ecase pname + ((#.+light-model-color-control+ + #.+light-model-local-viewer+ + #.+light-model-two-side+) + 1) + ((#.+light-model-ambient+) + 4))))) + +(define-rendering-command light-model-i 92 + ;; *** ENUM + (pname card32) + (param int32)) + + +(define-rendering-command light-model-iv 93 + ;; *** ENUM + (pname card32) + (params (list int32 (ecase pname + ((#.+light-model-color-control+ + #.+light-model-local-viewer+ + #.+light-model-two-side+) + 1) + ((#.+light-model-ambient+) + 4))))) + + +(define-rendering-command light-f 86 + ;; *** ENUM + (light card32) + ;; *** ENUM + (pname card32) + (param float32)) + + +(define-rendering-command light-fv 87 + ;; *** ENUM + (light card32) + ;; *** ENUM + (pname card32) + (params (list float32 (ecase pname + ((#.+ambient+ + #.+diffuse+ + #.+specular+ + #.+position+) + 4) + ((#.+spot-direction+) + 3) + ((#.+spot-exponent+ + #.+spot-cutoff+ + #.+constant-attenuation+ + #.+linear-attenuation+ + #.+quadratic-attenuation+) + 1))))) + + +(define-rendering-command light-i 88 + ;; *** ENUM + (light card32) + ;; *** ENUM + (pname card32) + (param int32)) + + +(define-rendering-command light-iv 89 + ;; *** ENUM + (light card32) + ;; *** ENUM + (pname card32) + (params (list int32 (ecase pname + ((#.+ambient+ + #.+diffuse+ + #.+specular+ + #.+position+) + 4) + ((#.+spot-direction+) + 3) + ((#.+spot-exponent+ + #.+spot-cutoff+ + #.+constant-attenuation+ + #.+linear-attenuation+ + #.+quadratic-attenuation+) + 1))))) + + +(define-rendering-command line-stipple 94 + (factor int32) + (pattern card16)) + + +(define-rendering-command line-width 95 + (width float32)) + + +(define-rendering-command list-base 3 + (base card32)) + + +(define-rendering-command load-identity 176) + + +(define-rendering-command load-matrix-d 178 + (m (list float64 16))) + + +(define-rendering-command load-matrix-f 177 + (m (list float32 16))) + + +(define-rendering-command load-name 122 + (name card32)) + + +(define-rendering-command logic-op 161 + ;; *** ENUM + (name card32)) + + +(define-rendering-command map-grid-1d 147 + (u1 float64) + (u2 float64) + (un int32)) + +(define-rendering-command map-grid-1f 148 + (un int32) + (u1 float32) + (u2 float32)) + + +(define-rendering-command map-grid-2d 149 + (u1 float64) + (u2 float64) + (v1 float64) + (v2 float64) + (un int32) + (vn int32)) + + +(define-rendering-command map-grid-2f 150 + (un int32) + (u1 float32) + (u2 float32) + (vn int32) + (v1 float32) + (v2 float32)) + + +(define-rendering-command material-f 96 + ;; *** ENUM + (face card32) + ;; *** ENUM + (pname card32) + (param float32)) + + +(define-rendering-command material-fv 97 + ;; *** ENUM + (face card32) + ;; *** ENUM + (pname card32) + (params (list float32 (ecase pname + ((#.+ambient+ + #.+diffuse+ + #.+specular+ + #.+emission+ + #.+ambient-and-diffuse+) + 4) + ((#.+shininess+) + 1) + ((#.+color-index+) + 3))))) + + +(define-rendering-command material-i 98 + ;; *** ENUM + (face card32) + ;; *** ENUM + (pname card32) + (param int32)) + + +(define-rendering-command material-iv 99 + ;; *** ENUM + (face card32) + ;; *** ENUM + (pname card32) + (params (list int32 (ecase pname + ((#.+ambient+ + #.+diffuse+ + #.+specular+ + #.+emission+ + #.+ambient-and-diffuse+) + 4) + ((#.+shininess+) + 1) + ((#.+color-index+) + 3))))) + + +(define-rendering-command matrix-mode 179 + ;; *** ENUM + (mode card32)) + + +(define-rendering-command minmax 4111 + ;; *** ENUM + (target card32) + ;; *** ENUM + (internalformat card32) + (sink bool)) + + +(define-rendering-command mult-matrix-d 181 + (m (list float64 16))) + + +(define-rendering-command mult-matrix-f 180 + (m (list float32 16))) + + +;;; *** Note that TARGET is placed last for FLOAT64 versions. +(define-rendering-command multi-tex-coord-1d-arb 198 + (v-0 float64) + ;; *** ENUM + (target card32)) + +(define-rendering-command multi-tex-coord-1f-arb 199 + ;; *** ENUM + (target card32) + (v-0 float32)) + +(define-rendering-command multi-tex-coord-1i-arb 200 + ;; *** ENUM + (target card32) + (v-0 int32)) + +(define-rendering-command multi-tex-coord-1s-arb 201 + ;; *** ENUM + (target card32) + (v-0 int16)) + + +(define-rendering-command multi-tex-coord-2d-arb 202 + ((v-0 v-1) float64) + ;; *** ENUM + (target card32)) + +(define-rendering-command multi-tex-coord-2f-arb 203 + ;; *** ENUM + (target card32) + ((v-0 v-1) float32)) + +(define-rendering-command multi-tex-coord-2i-arb 204 + ;; *** ENUM + (target card32) + ((v-0 v-1) int32)) + +(define-rendering-command multi-tex-coord-2s-arb 205 + ;; *** ENUM + (target card32) + ((v-0 v-1) int16)) + + +(define-rendering-command multi-tex-coord-3d-arb 206 + ((v-0 v-1 v-2) float64) + ;; *** ENUM + (target card32)) + +(define-rendering-command multi-tex-coord-3f-arb 207 + ;; *** ENUM + (target card32) + ((v-0 v-1 v-2) float32)) + +(define-rendering-command multi-tex-coord-3i-arb 208 + ;; *** ENUM + (target card32) + ((v-0 v-1 v-2) int32)) + +(define-rendering-command multi-tex-coord-3s-arb 209 + ;; *** ENUM + (target card32) + ((v-0 v-1 v-2) int16)) + + +(define-rendering-command multi-tex-coord-4d-arb 210 + ((v-0 v-1 v-2 v-3) float64) + ;; *** ENUM + (target card32)) + +(define-rendering-command multi-tex-coord-4f-arb 211 + ;; *** ENUM + (target card32) + ((v-0 v-1 v-2 v-3) float32)) + +(define-rendering-command multi-tex-coord-4i-arb 212 + ;; *** ENUM + (target card32) + ((v-0 v-1 v-2 v-3) int32)) + +(define-rendering-command multi-tex-coord-4s-arb 213 + ;; *** ENUM + (target card32) + ((v-0 v-1 v-2 v-3) int16)) + + +(define-rendering-command normal-3b 28 + ((v-0 v-1 v-2) int8)) + +(define-rendering-command normal-3d 29 + ((v-0 v-1 v-2) float64)) + +(define-rendering-command normal-3f 30 + ((v-0 v-1 v-2) float32)) + +(define-rendering-command normal-3i 31 + ((v-0 v-1 v-2) int32)) + +(define-rendering-command normal-3s 32 + ((v-0 v-1 v-2) int16)) + + +(define-rendering-command ortho 182 + (left float64) + (right float64) + (bottom float64) + (top float64) + (z-near float64) + (z-far float64)) + + +(define-rendering-command pass-through 123 + (token float32)) + + +(define-rendering-command pixel-transfer-f 166 + ;; *** ENUM + (pname card32) + (param float32)) + + +(define-rendering-command pixel-transfer-i 167 + ;; *** ENUM + (pname card32) + (param int32)) + + +(define-rendering-command pixel-zoom 165 + (xfactor float32) + (yfactor float32)) + + +(define-rendering-command point-size 100 + (size float32)) + + +(define-rendering-command polygon-mode 101 + ;; *** ENUM + (face card32) + ;; *** ENUM + (mode card32)) + + +(define-rendering-command polygon-offset 192 + (factor float32) + (units float32)) + + +(define-rendering-command pop-attrib 141) + + +(define-rendering-command pop-matrix 183) + + +(define-rendering-command pop-name 124) + + +(define-rendering-command prioritize-textures 4118 + (n int32) + (textures (list card32 n)) + (priorities (list float32 n))) + + +(define-rendering-command push-attrib 142 + ;; *** BITFIELD + (mask card32)) + + +(define-rendering-command push-matrix 184) + + +(define-rendering-command push-name 125 + (name card32)) + + +(define-rendering-command raster-pos-2d 33 + ((v-0 v-1) float64)) + +(define-rendering-command raster-pos-2f 34 + ((v-0 v-1) float32)) + +(define-rendering-command raster-pos-2i 35 + ((v-0 v-1) int32)) + +(define-rendering-command raster-pos-2s 36 + ((v-0 v-1) int16)) + + +(define-rendering-command raster-pos-3d 37 + ((v-0 v-1 v-2) float64)) + +(define-rendering-command raster-pos-3f 38 + ((v-0 v-1 v-2) float32)) + +(define-rendering-command raster-pos-3i 39 + ((v-0 v-1 v-2) int32)) + +(define-rendering-command raster-pos-3s 40 + ((v-0 v-1 v-2) int16)) + + +(define-rendering-command raster-pos-4d 41 + ((v-0 v-1 v-2 v-3) float64)) + +(define-rendering-command raster-pos-4f 42 + ((v-0 v-1 v-2 v-3) float32)) + +(define-rendering-command raster-pos-4i 43 + ((v-0 v-1 v-2 v-3) int32)) + +(define-rendering-command raster-pos-4s 44 + ((v-0 v-1 v-2 v-3) int16)) + + +(define-rendering-command read-buffer 171 + ;; *** ENUM + (mode card32)) + + +(define-rendering-command rect-d 45 + ((v1-0 v1-1 v2-0 v2-1) float64)) + +(define-rendering-command rect-f 46 + ((v1-0 v1-1 v2-0 v2-1) float32)) + +(define-rendering-command rect-i 47 + ((v1-0 v1-1 v2-0 v2-1) int32)) + +(define-rendering-command rect-s 48 + ((v1-0 v1-1 v2-0 v2-1) int16)) + + +(define-rendering-command reset-histogram 4112 + ;; *** ENUM + (target card32)) + + +(define-rendering-command reset-minmax 4113 + ;; *** ENUM + (target card32)) + + +(define-rendering-command rotate-d 185 + ((angle x y z) float64)) + + +(define-rendering-command rotate-f 186 + ((angle x y z) float32)) + + +(define-rendering-command scale-d 187 + ((x y z) float64)) + + +(define-rendering-command scale-f 188 + ((x y z) float32)) + + +(define-rendering-command scissor 103 + ((x y width height) int32)) + + +(define-rendering-command shade-model 104 + ;; *** ENUM + (mode card32)) + + +(define-rendering-command stencil-func 162 + ;; *** ENUM + (func card32) + (ref int32) + (mask card32)) + + +(define-rendering-command stencil-mask 133 + (mask card32)) + + +(define-rendering-command stencil-op 163 + ;; *** ENUM + (fail card32) + ;; *** ENUM + (zfail card32) + ;; *** ENUM + (zpass card32)) + + +(define-rendering-command tex-env-f 111 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (param float32)) + + +(define-rendering-command tex-env-fv 112 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (param (list float32 (ecase pname + (#.+texture-env-mode+ 1) + (#.+texture-env-color+ 4))))) + + +(define-rendering-command tex-env-i 113 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (param int32)) + + +(define-rendering-command tex-env-iv 114 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (param (list int32 (ecase pname + (#.+texture-env-mode+ 1) + (#.+texture-env-color+ 4))))) + + +;;; *** +;;; last there. +(define-rendering-command tex-gen-d 115 + (param float64) + ;; *** ENUM + (coord card32) + ;; *** ENUM + (pname card32)) + + +(define-rendering-command tex-gen-dv 116 + ;; *** ENUM + (coord card32) + ;; *** ENUM + (pname card32) + ;; +texture-gen-mode+ n=1 + ;; +object-plane+ n=4 + ;; +eye-plane+ n=1 + (params (list float64 (ecase pname + ((#.+texture-gen-mode+ #.+eye-plane+) 1) + (#.+object-plane+ 4))))) + + +(define-rendering-command tex-gen-f 117 + ;; *** ENUM + (coord card32) + ;; *** ENUM + (pname card32) + (param float32)) + + +(define-rendering-command tex-gen-fv 118 + ;; *** ENUM + (coord card32) + ;; *** ENUM + (pname card32) + (params (list float32 (ecase pname + ((#.+texture-gen-mode+ #.+eye-plane+) 1) + (#.+object-plane+ 4))))) + + +(define-rendering-command tex-gen-i 119 + ;; *** ENUM + (coord card32) + ;; *** ENUM + (pname card32) + (param int32)) + + +(define-rendering-command tex-gen-iv 120 + ;; *** ENUM + (coord card32) + ;; *** ENUM + (pname card32) + (params (list int32 (ecase pname + ((#.+texture-gen-mode+ #.+eye-plane+) 1) + (#.+object-plane+ 4))))) + + +(define-rendering-command tex-parameter-f 105 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (param float32)) + + +(define-rendering-command tex-parameter-fv 106 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (params (list float32 (ecase pname + ((#.+texture-border-color+) + 4) + ((#.+texture-mag-filter+ + #.+texture-min-filter+ + #.+texture-wrap-s+ + #.+texture-wrap-t+) + 1))))) + + +(define-rendering-command tex-parameter-i 107 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (param int32)) + + +(define-rendering-command tex-parameter-iv 108 + ;; *** ENUM + (target card32) + ;; *** ENUM + (pname card32) + (params (list int32 (ecase pname + ((#.+texture-border-color+) + 4) + ((#.+texture-mag-filter+ + #.+texture-min-filter+ + #.+texture-wrap-s+ + #.+texture-wrap-t+) + 1))))) + + +(define-rendering-command translate-d 189 + ((x y z) float64)) + +(define-rendering-command translate-f 190 + ((x y z) float32)) + + +(define-rendering-command vertex-2d 65 + ((x y) float64)) + +(define-rendering-command vertex-2f 66 + ((x y) float32)) + +(define-rendering-command vertex-2i 67 + ((x y) int32)) + +(define-rendering-command vertex-2s 68 + ((x y) int16)) + + +(define-rendering-command vertex-3d 69 + ((x y z) float64)) + +(define-rendering-command vertex-3f 70 + ((x y z) float32)) + +(define-rendering-command vertex-3i 71 + ((x y z) int32)) + +(define-rendering-command vertex-3s 72 + ((x y z) int16)) + + +(define-rendering-command vertex-4d 73 + ((x y z w) float64)) + +(define-rendering-command vertex-4f 74 + ((x y z w) float32)) + +(define-rendering-command vertex-4i 75 + ((x y z w) int32)) + +(define-rendering-command vertex-4s 76 + ((x y z w) int16)) + + +(define-rendering-command viewport 191 + ((x y width height) int32)) + + +;;; Potentially lerge rendering commands. + + +#-(and) +(define-large-rendering-command call-lists 2 + (n int32) + ;; *** ENUM + (type card32) + (lists (list type n))) + + + +;;; Requests for GL non-rendering commands. + +(defun new-list (list mode) + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request (display (extension-opcode display "GLX")) + (data +new-list+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx)) + (card32 list) + ;; *** ENUM + (card32 mode)))) + + +(defun gen-lists (range) + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +gen-lists+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx)) + (integer range)) + (card32-get 8)))) + + +(defun end-list () + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request (display (extension-opcode display "GLX")) + (data +end-list+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx))))) + + +(defun enable (cap) + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +enable+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx)) + ;; *** ENUM? + (card32 cap))))) + + +;;; FIXME: FLUSH and FINISH should send *all* buffered data, including +;;; buffered rendering commands. +(defun flush () + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request (display (extension-opcode display "GLX")) + (data +flush+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx))))) + + +(defun finish () + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +finish+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx)))))) diff --git a/clx/glx.lisp b/clx/glx.lisp new file mode 100644 index 000000000..9903d68c3 --- /dev/null +++ b/clx/glx.lisp @@ -0,0 +1,635 @@ +#+cmu +(ext:file-comment "$Id: glx.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") + +(defpackage :glx + (:use :common-lisp :xlib) + (:import-from :xlib + "DEFINE-ACCESSOR" + "DEF-CLX-CLASS" + "DECLARE-EVENT" + "ALLOCATE-RESOURCE-ID" + "DEALLOCATE-RESOURCE-ID" + "PRINT-DISPLAY-NAME" + "WITH-BUFFER-REQUEST" + "WITH-BUFFER-REQUEST-AND-REPLY" + "READ-CARD32" + "WRITE-CARD32" + "CARD32-GET" + "CARD8-GET" + "SEQUENCE-GET" + "SEQUENCE-PUT" + "DATA" + + ;; Types + "ARRAY-INDEX" + "BUFFER-BYTES" + + "WITH-DISPLAY" + "BUFFER-FLUSH" + "BUFFER-WRITE" + "BUFFER-FORCE-OUTPUT" + "ASET-CARD8" + "ASET-CARD16" + "ASET-CARD32" + ) + (:export ;; Constants + "+VENDOR+" + "+VERSION+" + "+EXTENSIONS+" + + ;; Conditions + "BAD-CONTEXT" + "BAD-CONTEXT-STATE" + "BAD-DRAWABLE" + "BAD-PIXMAP" + "BAD-CONTEXT-TAG" + "BAD-CURRENT-WINDOW" + "BAD-RENDER-REQUEST" + "BAD-LARGE-REQUEST" + "UNSUPPORTED-PRIVATE-REQUEST" + "BAD-FB-CONFIG" + "BAD-PBUFFER" + "BAD-CURRENT-DRAWABLE" + "BAD-WINDOW" + + ;; Requests + "QUERY-VERSION" + "QUERY-SERVER-STRING" + "CREATE-CONTEXT" + "DESTROY-CONTEXT" + "IS-DIRECT" + "QUERY-CONTEXT" + "GET-DRAWABLE-ATTRIBUTES" + "MAKE-CURRENT" + ;;"GET-VISUAL-CONFIGS" + "CHOOSE-VISUAL" + "VISUAL-ATTRIBUTE" + "VISUAL-ID" + "RENDER" + "SWAP-BUFFERS" + "WAIT-GL" + "WAIT-X" + )) + + +(in-package :glx) + + +(declaim (optimize (debug 3) (safety 3))) + + +(define-extension "GLX" + :events (:glx-pbuffer-clobber) + :errors (bad-context + bad-context-state + bad-drawable + bad-pixmap + bad-context-tag + bad-current-window + bad-render-request + bad-large-request + unsupported-private-request + bad-fb-config + bad-pbuffer + bad-current-drawable + bad-window)) + + +;;; Opcodes. + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant +render+ 1) +(defconstant +create-context+ 3) +(defconstant +destroy-context+ 4) +(defconstant +make-current+ 5) +(defconstant +is-direct+ 6) +(defconstant +query-version+ 7) +(defconstant +wait-gl+ 8) +(defconstant +wait-x+ 9) +(defconstant +copy-context+ 10) +(defconstant +swap-buffers+ 11) +(defconstant +get-visual-configs+ 14) +(defconstant +destroy-glx-pixmap+ 15) +(defconstant +query-server-string+ 19) +(defconstant +client-info+ 20) +(defconstant +get-fb-configs+ 21) +(defconstant +query-context+ 25) +(defconstant +get-drawable-attributes+ 29) +) + + +;;; Constants + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant +vendor+ 1) +(defconstant +version+ 2) +(defconstant +extensions+ 3) +) + + +;;; Types + +;;; FIXME: +;;; - Are all the 32-bit values unsigned? Do we care? +;;; - These are not used much, yet. +(progn + (deftype attribute-pair ()) + (deftype bitfield () 'mask32) + (deftype bool32 () 'card32) ; 1 for true and 0 for false + (deftype enum () 'card32) + (deftype fbconfigid () 'card32) + ;; FIXME: How to define these two? + (deftype float32 () 'single-float) + (deftype float64 () 'double-float) + ;;(deftype glx-context () 'card32) + (deftype context-tag () 'card32) + ;;(deftype glx-drawable () 'card32) + (deftype glx-pixmap () 'card32) + (deftype glx-pbuffer () 'card32) + (deftype glx-render-command () #|TODO|#) + (deftype glx-window () 'card32) + #-(and) + (deftype visual-property () + "An ordered list of 32-bit property values followed by unordered pairs of +property types and property values." + ;; FIXME: maybe CLX-LIST or even just LIST? + 'clx-sequence)) + + +;;; FIXME: DEFINE-ACCESSOR interns getter and setter in XLIB package +;;; (using XINTERN). Therefore the accessors defined below can only +;;; be accessed using double-colon, which is a bad style. Or these +;;; forms must be taken to another file so the accessors exist before +;;; we get to this file. + +#-(and) +(define-accessor glx-context-tag (32) + ((index) `(read-card32 ,index)) + ((index thing) `(write-card32 ,index ,thing))) + +#-(and) +(define-accessor glx-enum (32) + ((index) `(read-card32 ,index)) + ((index thing) `(write-card32 ,index ,thing))) + + +;;; FIXME: I'm just not sure we need a seperate accessors for what +;;; essentially are aliases for other types. Maybe use compiler +;;; macros? +;;; +;;; This trick won't do because CLX wants e.g. CONTEXT-TAG to be a +;;; known accessor. The only trick left I think is to change the +;;; XINTERN function to intern the new symbols in the same package as +;;; he symbol part of it comes from. Don't know if it would break +;;; anything, thought. (I would be quite surprised if it did -- there +;;; is only one package in CLX after all: XLIB.) +;;; +;;; I also found the origin of the error (about symbol not being a +;;; known accessor): INDEX-INCREMENT function. Looks like all we have +;;; to do is to add an XLIB::BYTE-WIDTH property to the type symbol +;;; plist. But accessors are macros, not functions, anyway. + +#-(and) +(progn + (declaim (inline context-tag-get context-tag-put enum-get enum-put)) + (defun context-tag-get (index) (card32-get index)) + (defun context-tag-put (index thing) (card32-put index thing)) + (defun enum-get (index) (card32-get index)) + (defun enum-put (index thing) (card32-put index thing)) +) + + +;;; Structures + + +(def-clx-class (context (:constructor %make-context) + (:print-function print-context) + (:copier nil)) + (id 0 :type resource-id) + (display nil :type (or null display)) + (tag 0 :type card32) + (drawable nil :type (or null drawable)) + ;; TODO: There can only be one current context (as far as I + ;; understand). If so, we'd need only one buffer (otherwise it's a + ;; big waste to have a quarter megabyte buffer for each context; or + ;; we could allocate/grow the buffer on demand). + ;; + ;; 256k buffer for Render command. Big requests are served with + ;; RenderLarge command. First 8 octets are Render request fields. + ;; + (rbuf (make-array (+ 8 (* 256 1024)) :element-type '(unsigned-byte 8)) :type buffer-bytes) + ;; Index into RBUF where the next rendering command should be inserted. + (index 8 :type array-index)) + + +(defun print-context (ctx stream depth) + (declare (type context ctx) + (ignore depth)) + (print-unreadable-object (ctx stream :type t) + (print-display-name (context-display ctx) stream) + (write-string " " stream) + (princ (context-id ctx) stream))) + + +(def-clx-class (visual (:constructor %make-visual) + (:print-function print-visual) + (:copier nil)) + (id 0 :type resource-id) + (attributes nil :type list)) + + +(defun print-visual (visual stream depth) + (declare (type visual visual) + (ignore depth)) + (print-unreadable-object (visual stream :type t) + (write-string "ID: " stream) + (princ (visual-id visual) stream) + (write-string " " stream) + (princ (visual-attributes visual) stream))) + + + +;;; Events. + +(defconstant +damaged+ #x8017) +(defconstant +saved+ #x8018) +(defconstant +window+ #x8019) +(defconstant +pbuffer+ #x801a) + + +(declare-event :glx-pbuffer-clobber + (card16 sequence) + (card16 event-type) ;; +DAMAGED+ or +SAVED+ + (card16 draw-type) ;; +WINDOW+ or +PBUFFER+ + (resource-id drawable) + ;; FIXME: (bitfield buffer-mask) + (card32 buffer-mask) + (card16 aux-buffer) + (card16 x y width height count)) + + + +;;; Errors. + +(define-condition bad-context (request-error) ()) +(define-condition bad-context-state (request-error) ()) +(define-condition bad-drawable (request-error) ()) +(define-condition bad-pixmap (request-error) ()) +(define-condition bad-context-tag (request-error) ()) +(define-condition bad-current-window (request-error) ()) +(define-condition bad-render-request (request-error) ()) +(define-condition bad-large-request (request-error) ()) +(define-condition unsupported-private-request (request-error) ()) +(define-condition bad-fb-config (request-error) ()) +(define-condition bad-pbuffer (request-error) ()) +(define-condition bad-current-drawable (request-error) ()) +(define-condition bad-window (request-error) ()) + +(define-error bad-context decode-core-error) +(define-error bad-context-state decode-core-error) +(define-error bad-drawable decode-core-error) +(define-error bad-pixmap decode-core-error) +(define-error bad-context-tag decode-core-error) +(define-error bad-current-window decode-core-error) +(define-error bad-render-request decode-core-error) +(define-error bad-large-request decode-core-error) +(define-error unsupported-private-request decode-core-error) +(define-error bad-fb-config decode-core-error) +(define-error bad-pbuffer decode-core-error) +(define-error bad-current-drawable decode-core-error) +(define-error bad-window decode-core-error) + + + +;;; Requests. + + +(defun query-version (display) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +query-version+) + (card32 1) + (card32 3)) + (values + (card32-get 8) + (card32-get 12)))) + + +(defun query-server-string (display screen name) + "NAME is one of +VENDOR+, +VERSION+ or +EXTENSIONS+" + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +query-server-string+) + (card32 (or (position screen (display-roots display) :test #'eq) 0)) + (card32 name)) + (let* ((length (card32-get 12)) + (bytes (sequence-get :format card8 + :result-type '(simple-array card8 (*)) + :index 32 + :length length))) + (declare (type (simple-array card8 (*)) bytes) + (type fixnum length)) + (map-into (make-string (1- length)) #'code-char bytes)))) + + +(defun client-info (display) + ;; TODO: This should be invoked automatically when using this + ;; library in initialization stage. + ;; + ;; TODO: No extensions supported yet. + ;; + ;; *** Maybe the LENGTH field must be filled in some special way + ;; (similar to data)? + (with-buffer-request (display (extension-opcode display "GLX")) + (data +client-info+) + (card32 4) ; length of the request + (card32 1) ; major + (card32 3) ; minor + (card32 0) ; n + )) + + +;;; XXX: This looks like an internal thing. Should name appropriately. +(defun make-context (display) + (let ((ctx (%make-context :display display))) + (setf (context-id ctx) + (allocate-resource-id display ctx 'context)) + ;; Prepare render request buffer. + ctx)) + + +(defun create-context (screen visual + &optional + (share-list 0) + (is-direct nil)) + "Do NOT use the direct mode, yet!" + (let* ((root (screen-root screen)) + (display (drawable-display root)) + (ctx (make-context display))) + (with-buffer-request (display (extension-opcode display "GLX")) + (data +create-context+) + (resource-id (context-id ctx)) + (resource-id visual) + (card32 (or (position screen (display-roots display) :test #'eq) 0)) + (resource-id share-list) + (boolean is-direct)) + ctx)) + + +;;; TODO: Maybe make this var private to GLX-MAKE-CURRENT and GLX-GET-CURRENT-CONTEXT only? +;;; +(defvar *current-context* nil) + + +(defun destroy-context (ctx) + (let ((id (context-id ctx)) + (display (context-display ctx))) + (with-buffer-request (display (extension-opcode display "GLX")) + (data +destroy-context+) + (resource-id id)) + (deallocate-resource-id display id 'context) + (setf (context-id ctx) 0) + (when (eq ctx *current-context*) + (setf *current-context* nil)))) + + +(defun is-direct (ctx) + (let ((display (context-display ctx))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +is-direct+) + (resource-id (context-id ctx))) + (card8-get 8)))) + + +(defun query-context (ctx) + ;; TODO: What are the attribute types? + (let ((display (context-display ctx))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +query-context+) + (resource-id (context-id ctx))) + (let ((num-attributes (card32-get 8))) + ;; FIXME: Is this really so? + (declare (type fixnum num-attributes)) + (loop + repeat num-attributes + for i fixnum upfrom 32 by 8 + collecting (cons (card32-get i) + (card32-get (+ i 4)))))))) + + +(defun get-drawable-attributes (drawable) + (let ((display (drawable-display drawable))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +get-drawable-attributes+) + (drawable drawable)) + (let ((num-attributes (card32-get 8))) + ;; FIXME: Is this really so? + (declare (type fixnum num-attributes)) + (loop + repeat num-attributes + for i fixnum upfrom 32 by 8 + collecting (cons (card32-get i) + (card32-get (+ i 4)))))))) + + +;;; TODO: What is the idea behind passing drawable to this function? +;;; Can a context be made current for different drawables at different +;;; times? (Man page on glXMakeCurrent says that context's viewport +;;; is set to the size of drawable when creating; it does not change +;;; afterwards.) +;;; +(defun make-current (drawable ctx) + (let ((display (drawable-display drawable)) + (old-tag (if *current-context* (context-tag *current-context*) 0))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +make-current+) + (resource-id (drawable-id drawable)) + (resource-id (context-id ctx)) + ;; *** CARD32 is really a CONTEXT-TAG + (card32 old-tag)) + (let ((new-tag (card32-get 8))) + (setf (context-tag ctx) new-tag + (context-drawable ctx) drawable + (context-display ctx) display + *current-context* ctx))))) + + +;;; FIXME: Decide how to represent and use these. +(eval-when (:load-toplevel :compile-toplevel :execute) + (macrolet ((generate-config-properties () + (let ((list '((:glx-visual visual-id) + (:glx-class card32) + (:glx-rgba bool32) + (:glx-red-size card32) + (:glx-green-size card32) + (:glx-blue-size card32) + (:glx-alpha-size card32) + (:glx-accum-red-size card32) + (:glx-accum-green-size card32) + (:glx-accum-blue-size card32) + (:glx-accum-alpha-size card32) + (:glx-double-buffer bool32) + (:glx-stereo bool32) + (:glx-buffer-size card32) + (:glx-depth-size card32) + (:glx-stencil-size card32) + (:glx-aux-buffers card32) + (:glx-level int32)))) + `(progn + ,@(loop for (symbol type) in list + collect `(setf (get ',symbol 'visual-config-property-type) ',type)) + (defparameter *visual-config-properties* + (map 'vector #'car ',list)) + (declaim (type simple-vector *visual-config-properties*)) + (deftype visual-config-property () + '(member ,@(mapcar #'car list))))))) + (generate-config-properties))) + + +(defun make-visual (attributes) + (let ((id-cons (first attributes))) + (assert (eq :glx-visual (car id-cons)) + (id-cons) + "GLX visual id must be first in attributes list!") + (%make-visual :id (cdr id-cons) + :attributes (rest attributes)))) + + +(defun visual-attribute (visual attribute) + (assert (or (numberp attribute) + (find attribute *visual-config-properties*)) + (attribute) + "~S is not a known GLX visual attribute." attribute) + (cdr (assoc attribute (visual-attributes visual)))) + + +;;; TODO: Make this return nice structured objects with field values of correct type. +;;; FIXME: Looks like every other result is corrupted. +(defun get-visual-configs (screen) + (let ((display (drawable-display (screen-root screen)))) + (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) + ((data +get-visual-configs+) + (card32 (or (position screen (display-roots display) :test #'eq) 0))) + (let* ((num-visuals (card32-get 8)) + (num-properties (card32-get 12)) + (num-ordered (length *visual-config-properties*))) + ;; FIXME: Is this really so? + (declare (type fixnum num-ordered num-visuals num-properties)) + (loop + with index fixnum = 28 + repeat num-visuals + collecting (make-visual + (nconc (when (<= num-ordered num-properties) + (map 'list #'(lambda (property) + (cons property (card32-get (incf index 4)))) + *visual-config-properties*)) + (when (< num-ordered num-properties) + (loop repeat (/ (- num-properties num-ordered) 2) + collecting (cons (card32-get (incf index 4)) + (card32-get (incf index 4)))))))))))) + + +(defun choose-visual (screen attributes) + "ATTRIBUTES is a list of desired attributes for a visual. The elements may be +either a symbol, which means that the boolean attribute with that name must be true; or +it can be a list of the form: (attribute-name value &optional (test '<=)) which means that +the attribute named attribute-name must satisfy the test when applied to the given value and +attribute's value in visual. +Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." + ;; TODO: Add type checks + ;; + ;; TODO: This function checks only supplied attributes; should check + ;; all attributes, with default for boolean type being false, and + ;; for number types zero. + ;; + ;; TODO: Make this smarter, like the docstring says, instead of + ;; parrotting the inflexible C API. + ;; + (flet ((visual-matches-p (visual attributes) + (dolist (attribute attributes t) + (etypecase attribute + (symbol (not (null (visual-attribute visual attribute)))) + (cons (<= (second attribute) (visual-attribute visual (car attribute)))))))) + (let* ((visuals (get-visual-configs screen)) + (candidates (loop + for visual in visuals + when (visual-matches-p visual attributes) + collect visual)) + (result (first candidates))) + + (dolist (candidate (rest candidates)) + ;; Visuals with glx-class 3 (pseudo-color) and 4 (true-color) + ;; are preferred over glx-class 2 (static-color) and 5 (direct-color). + (let ((class (visual-attribute candidate :glx-class))) + (when (or (= class 3) + (= class 4)) + (setf result candidate)))) + result))) + + +(defun render () + (declare (optimize (debug 3))) + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx)) + (rbuf (context-rbuf ctx)) + (index (context-index ctx))) + (declare (type buffer-bytes rbuf) + (type array-index index)) + (when (< 8 index) + (with-display (display) + ;; Flush display's buffer first so we don't get messed up with X requests. + (buffer-flush display) + ;; First, update the Render request fields. + (aset-card8 (extension-opcode display "GLX") rbuf 0) + (aset-card8 1 rbuf 1) + (aset-card16 (ceiling index 4) rbuf 2) + (aset-card32 (context-tag ctx) rbuf 4) + ;; Then send the request. + (buffer-write rbuf display 0 (context-index ctx)) + ;; Start filling from the beginning + (setf (context-index ctx) 8))) + (values))) + + +(defun swap-buffers () + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + ;; Make sure all rendering commands are sent away. + (glx:render) + (with-buffer-request (display (extension-opcode display "GLX")) + (data +swap-buffers+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx)) + (resource-id (drawable-id (context-drawable ctx)))) + (display-force-output display))) + + +;;; FIXME: These two are more complicated than sending messages. As I +;;; understand it, wait-gl should inhibit any X requests until all GL +;;; requests are sent... +(defun wait-gl () + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request (display (extension-opcode display "GLX")) + (data +wait-gl+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx))))) + + +(defun wait-x () + (assert (context-p *current-context*) + (*current-context*) + "~S is not a context." *current-context*) + (let* ((ctx *current-context*) + (display (context-display ctx))) + (with-buffer-request (display (extension-opcode display "GLX")) + (data +wait-x+) + ;; *** GLX_CONTEXT_TAG + (card32 (context-tag ctx))))) diff --git a/clx/graphics.lisp b/clx/graphics.lisp index 1acb7afeb..53f09fc74 100644 --- a/clx/graphics.lisp +++ b/clx/graphics.lisp @@ -17,9 +17,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/graphics.lisp,v 1.5 1998/12/19 15:21:17 dtc Exp $") +(ext:file-comment "$Id: graphics.lisp,v 1.6 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) @@ -34,14 +34,14 @@ (declare (type display display)) (with-display (display) (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length *requestsize*) + (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) *x-polypoint*) + (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? @@ -64,7 +64,7 @@ ;; New Request (progn (put-items (4) - (code *x-polypoint*) + (code +x-polypoint+) (data 0) ;; Relative-p false (length 4) (drawable drawable) @@ -81,7 +81,7 @@ (type gcontext gcontext) (type sequence points) ;(repeat-seq (integer x) (integer y)) (type generalized-boolean relative-p)) - (with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext) + (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext) ((data boolean) relative-p) (drawable drawable) (gcontext gcontext) @@ -100,14 +100,14 @@ (incf y2 y1)) (with-display (display) (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length *requestsize*) + (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) *x-polysegment*) + (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? @@ -129,7 +129,7 @@ ;; New Request (progn (put-items (4) - (code *x-polysegment*) + (code +x-polysegment+) (length 5) (drawable drawable) (gcontext gcontext) @@ -147,7 +147,7 @@ (type (member :complex :non-convex :convex) shape)) (if fill-p (fill-polygon drawable gcontext points relative-p shape) - (with-buffer-request ((drawable-display drawable) *x-polyline* :gc-force gcontext) + (with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext) ((data boolean) relative-p) (drawable drawable) (gcontext gcontext) @@ -161,7 +161,7 @@ (type sequence points) ;(repeat-seq (integer x) (integer y)) (type generalized-boolean relative-p) (type (member :complex :non-convex :convex) shape)) - (with-buffer-request ((drawable-display drawable) *x-fillpoly* :gc-force gcontext) + (with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((member8 :complex :non-convex :convex) shape) @@ -173,7 +173,7 @@ (type gcontext gcontext) ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) (type sequence segments)) - (with-buffer-request ((drawable-display drawable) *x-polysegment* :gc-force gcontext) + (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((sequence :format int16) segments))) @@ -186,12 +186,12 @@ (type card16 width height) (type generalized-boolean fill-p)) (let ((display (drawable-display drawable)) - (request (if fill-p *x-polyfillrectangle* *x-polyrectangle*))) + (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+))) (declare (type display display) (type card16 request)) (with-display (display) (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length *requestsize*) + (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question @@ -239,7 +239,7 @@ (type sequence rectangles) (type generalized-boolean fill-p)) (with-buffer-request ((drawable-display drawable) - (if fill-p *x-polyfillrectangle* *x-polyrectangle*) + (if fill-p +x-polyfillrectangle+ +x-polyrectangle+) :gc-force gcontext) (drawable drawable) (gcontext gcontext) @@ -254,12 +254,12 @@ (type angle angle1 angle2) (type generalized-boolean fill-p)) (let ((display (drawable-display drawable)) - (request (if fill-p *x-polyfillarc* *x-polyarc*))) + (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (declare (type display display) (type card16 request)) (with-display (display) (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length *requestsize*) + (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question @@ -310,7 +310,7 @@ (let* ((display (drawable-display drawable)) (limit (index- (buffer-size display) 12)) (length (length arcs)) - (request (if fill-p *x-polyfillarc* *x-polyarc*))) + (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) (drawable drawable) (gcontext gcontext) @@ -341,7 +341,7 @@ (let* ((display (drawable-display drawable)) (limit (index- (buffer-size display) 12)) (length (length arcs)) - (request (if fill-p *x-polyfillarc* *x-polyarc*))) + (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) (drawable drawable) (gcontext gcontext) @@ -400,7 +400,7 @@ (type int16 x y) ;; required (type card16 width height) ;; required (type (member :bitmap :xy-pixmap :z-pixmap) format)) - (with-buffer-request ((drawable-display drawable) *x-putimage* :gc-force gcontext) + (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext) ((data (member :bitmap :xy-pixmap :z-pixmap)) format) (drawable drawable) (gcontext gcontext) @@ -434,7 +434,7 @@ (type (member :xy-pixmap :z-pixmap) format)) (declare (clx-values (clx-sequence integer) depth visual-info)) (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32)) + (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) (((data (member error :xy-pixmap :z-pixmap)) format) (drawable drawable) (int16 x y) @@ -445,6 +445,6 @@ (visual (resource-id-get 8))) (values (sequence-get :result-type result-type :format card8 :length length :start start :data data - :index *replysize*) + :index +replysize+) depth (visual-info display visual)))))) diff --git a/clx/image.lisp b/clx/image.lisp index 920ee9c81..8eb47af33 100644 --- a/clx/image.lisp +++ b/clx/image.lisp @@ -17,9 +17,6 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/image.lisp,v 1.10 2003/06/05 14:56:59 emarsden Exp $") (in-package :xlib) @@ -62,10 +59,10 @@ (write-string "x" stream) (prin1 (image-depth image) stream))) -(defconstant *empty-data-x* '#.(make-sequence '(array card8 (*)) 0)) +(defconstant +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0)) -(defconstant *empty-data-z* - '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) +(defconstant +empty-data-z+ + '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) (def-clx-class (image-x (:include image) (:copier nil) (:print-function print-image)) @@ -74,11 +71,11 @@ (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) (bytes-per-line 0 :type card16) (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (bit-lsb-first-p *image-bit-lsb-first-p* :type generalized-boolean) ; Bit order - (byte-lsb-first-p *image-byte-lsb-first-p* :type generalized-boolean) ; Byte order - (data *empty-data-x* :type (array card8 (*))) ; row-major - (unit *image-unit* :type (member 8 16 32)) ; Bitmap unit - (pad *image-pad* :type (member 8 16 32)) ; Scanline pad + (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order + (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order + (data +empty-data-x+ :type (array card8 (*))) ; row-major + (unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit + (pad +image-pad+ :type (member 8 16 32)) ; Scanline pad (left-pad 0 :type card8)) ; Left pad (def-clx-class (image-xy (:include image) (:copier nil) @@ -92,7 +89,7 @@ ;; Public structure ;; Use this format for image processing (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (pixarray *empty-data-z* :type pixarray)) + (pixarray +empty-data-z+ :type pixarray)) (defun create-image (&key width height depth (data (required-arg data)) @@ -155,11 +152,11 @@ (declare (type array-index pad bits-per-line padded-bits-per-line)) (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) - (unless unit (setq unit *image-unit*)) + (unless unit (setq unit +image-unit+)) (unless pad (setq pad (dolist (pad '(32 16 8)) - (when (and (index<= pad *image-pad*) + (when (and (index<= pad +image-pad+) (zerop (index-mod (index* bytes-per-line 8) pad))) @@ -468,27 +465,26 @@ (byte 4 4) (the card4 (ldb (byte 4 4) byte2))))))))))) -(defconstant - *image-byte-reverse* - '#.(coerce - '#( - 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 - 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 - 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 - 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 - 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 - 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 - 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 - 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 - 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 - 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 - 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 - 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 - 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 - 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 - 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 - 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) - '(vector card8))) +(defconstant +image-byte-reverse+ + '#.(coerce + '#( + 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 + 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 + 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 + 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 + 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 + 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 + 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 + 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 + 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 + 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 + 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 + 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 + 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 + 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 + 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 + 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) + '(vector card8))) (defun image-swap-bits (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) @@ -500,7 +496,7 @@ #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) + (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) @@ -526,7 +522,7 @@ #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) + (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) @@ -563,7 +559,7 @@ #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) + (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) @@ -615,7 +611,7 @@ #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) + (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) @@ -704,31 +700,30 @@ ;;; lr l+R ;;; wr w+R -(defconstant - *image-swap-function* - '#.(make-array - '(12 12) :initial-contents - (let ((n 'image-noswap) - (s 'image-swap-two-bytes) - (l 'image-swap-four-bytes) - (w 'image-swap-words) - (r 'image-swap-bits) - (sr 'image-swap-bits-and-two-bytes) - (lr 'image-swap-bits-and-four-bytes) - (wr 'image-swap-bits-and-words)) - (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# - (list #| 1Mm |# n n n r sr lr n s l r r r ) - (list #| 2Mm |# n n n r sr lr n s l r r r ) - (list #| 4Mm |# n n n r sr lr n s l r r r ) - (list #| 1Ml |# r r r n s l r sr lr n n n ) - (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) - (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) - (list #| 1Lm |# n n n r sr lr n s l r r r ) - (list #| 2Lm |# s s s sr r wr s n w sr sr sr) - (list #| 4Lm |# l l l lr wr r l w n lr lr lr) - (list #| 1Ll |# r r r n s l r sr lr n n n ) - (list #| 2Ll |# r r r n s l r sr lr n n n ) - (list #| 4Ll |# r r r n s l r sr lr n n n ))))) +(defconstant +image-swap-function+ + '#.(make-array + '(12 12) :initial-contents + (let ((n 'image-noswap) + (s 'image-swap-two-bytes) + (l 'image-swap-four-bytes) + (w 'image-swap-words) + (r 'image-swap-bits) + (sr 'image-swap-bits-and-two-bytes) + (lr 'image-swap-bits-and-four-bytes) + (wr 'image-swap-bits-and-words)) + (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# + (list #| 1Mm |# n n n r sr lr n s l r r r ) + (list #| 2Mm |# n n n r sr lr n s l r r r ) + (list #| 4Mm |# n n n r sr lr n s l r r r ) + (list #| 1Ml |# r r r n s l r sr lr n n n ) + (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) + (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) + (list #| 1Lm |# n n n r sr lr n s l r r r ) + (list #| 2Lm |# s s s sr r wr s n w sr sr sr) + (list #| 4Lm |# l l l lr wr r l w n lr lr lr) + (list #| 1Ll |# r r r n s l r sr lr n n n ) + (list #| 2Ll |# r r r n s l r sr lr n n n ) + (list #| 4Ll |# r r r n s l r sr lr n n n ))))) ;;; Of course, the table above is a lie. We also need to factor in the ;;; order of the source data to cope with swapping half of a unit at the @@ -737,23 +732,22 @@ ;;; ;;; Defines whether the first half of a unit has the first half of the data -(defconstant - *image-swap-lsb-first-p* - '#.(make-array - 12 :initial-contents - (list t #| 1mm |# - t #| 2mm |# - t #| 4mm |# - t #| 1ml |# - nil #| 2ml |# - nil #| 4ml |# - t #| 1lm |# - nil #| 2lm |# - nil #| 4lm |# - t #| 1ll |# - t #| 2ll |# - t #| 4ll |# - ))) +(defconstant +image-swap-lsb-first-p+ + '#.(make-array + 12 :initial-contents + (list t #| 1mm |# + t #| 2mm |# + t #| 4mm |# + t #| 1ml |# + nil #| 2ml |# + nil #| 4ml |# + t #| 1lm |# + nil #| 2lm |# + nil #| 4lm |# + t #| 1ll |# + t #| 2ll |# + t #| 4ll |# + ))) (defun image-swap-function (bits-per-pixel @@ -771,12 +765,12 @@ (if from-bit-lsb-first-p 3 0) (if from-byte-lsb-first-p 6 0)))) (values - (aref *image-swap-function* from-index + (aref +image-swap-function+ from-index (index+ (ecase to-bitmap-unit (32 2) (16 1) (8 0)) (if to-bit-lsb-first-p 3 0) (if to-byte-lsb-first-p 6 0))) - (aref *image-swap-lsb-first-p* from-index)))) + (aref +image-swap-lsb-first-p+ from-index)))) (t (values (if (if (index= bits-per-pixel 4) @@ -1139,7 +1133,7 @@ (24 #'read-pixarray-24) (32 #'read-pixarray-32)) unit byte-lsb-first-p bit-lsb-first-p - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*))) + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))) (defun read-xy-format-image-x (buffer-bbuf index length data width height depth @@ -1226,7 +1220,7 @@ (values (array-dimensions (first data)) (array-element-type (first data))) (values (list height - (index* (index-ceiling width *image-pad*) *image-pad*)) + (index* (index-ceiling width +image-pad+) +image-pad+)) 'pixarray-1-element-type)) (do* ((arrays data) (result nil) @@ -1264,8 +1258,8 @@ (let* ((image-bits-per-line (index* width bits-per-pixel)) (image-pixels-per-line (index-ceiling - (index* (index-ceiling image-bits-per-line *image-pad*) - *image-pad*) + (index* (index-ceiling image-bits-per-line +image-pad+) + +image-pad+) bits-per-pixel))) (declare (type array-index image-bits-per-line image-pixels-per-line)) (unless data @@ -1318,7 +1312,7 @@ result-type format)) (unless plane-mask (setq plane-mask #xffffffff)) (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32)) + (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) (((data (member error :xy-pixmap :z-pixmap)) format) (drawable drawable) (int16 x y) @@ -1365,27 +1359,27 @@ (ecase format (:xy-pixmap (read-xy-format-image-x - buffer-bbuf *replysize* length data + buffer-bbuf +replysize+ length data width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p pad)) (:z-pixmap (read-z-format-image-x - buffer-bbuf *replysize* length data + buffer-bbuf +replysize+ length data width height depth padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel)))) (image-xy (read-image-xy - buffer-bbuf *replysize* length data + buffer-bbuf +replysize+ length data 0 0 width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p)) (image-z (read-image-z - buffer-bbuf *replysize* length data + buffer-bbuf +replysize+ length data 0 0 width height depth padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p))))) @@ -1678,7 +1672,7 @@ (16 #'write-pixarray-16) (24 #'write-pixarray-24) (32 #'write-pixarray-32)) - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p* + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))) (defun write-xy-format-image-x-data @@ -2007,7 +2001,7 @@ (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((left-pad (if (or (eq format :xy-pixmap) (= depth 1)) - (index-mod src-x (index-min pad *image-pad*)) + (index-mod src-x (index-min pad +image-pad+)) 0)) (left-padded-src-x (index- src-x left-pad)) (left-padded-width (index+ width left-pad)) @@ -2051,7 +2045,7 @@ (request-length (index+ request-words 6))) (declare (type array-index request-bytes) (type card16 request-words request-length)) - (with-buffer-request (display *x-putimage* :gc-force gcontext) + (with-buffer-request (display +x-putimage+ :gc-force gcontext) ((data (member :bitmap :xy-pixmap :z-pixmap)) (cond ((or (eq format :bitmap) bitmap-p) :bitmap) ((plusp left-pad) :xy-pixmap) @@ -2237,7 +2231,7 @@ (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((bits-per-line (index* bits-per-pixel width)) (padded-bits-per-line - (index* (index-ceiling bits-per-line *image-pad*) *image-pad*)) + (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) (copy (make-array (list height padded-width) :element-type (array-element-type array)))) @@ -2275,7 +2269,7 @@ (type card16 x y width height) (clx-values image-x)) (let* ((padded-bits-per-line - (index* (index-ceiling width *image-pad*) *image-pad*)) + (index* (index-ceiling width +image-pad+) +image-pad+)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (bytes-total (index* padded-bytes-per-plane (image-depth image))) @@ -2289,15 +2283,15 @@ (declare (type pixarray-1 bitmap)) (write-pixarray data index bitmap x y width height padded-bytes-per-line 1 - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*) + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) (index-incf index padded-bytes-per-plane))) (create-image :width width :height height :depth (image-depth image) :data data :format :xy-pixmap :bits-per-pixel 1 :bytes-per-line padded-bytes-per-line - :unit *image-unit* :pad *image-pad* - :byte-lsb-first-p *image-byte-lsb-first-p* - :bit-lsb-first-p *image-bit-lsb-first-p*))) + :unit +image-unit+ :pad +image-pad+ + :byte-lsb-first-p +image-byte-lsb-first-p+ + :bit-lsb-first-p +image-bit-lsb-first-p+))) (defun image-xy->image-xy (image x y width height) (declare (type image-xy image) @@ -2324,7 +2318,7 @@ (clx-values image-x)) (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) (padded-bits-per-line - (index* (index-ceiling bits-per-line *image-pad*) *image-pad*)) + (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (bytes-total (index* padded-bytes-per-line height (image-depth image))) @@ -2337,15 +2331,15 @@ (write-pixarray data 0 (image-z-pixarray image) x y width height padded-bytes-per-line (image-z-bits-per-pixel image) - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*) + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) (create-image :width width :height height :depth (image-depth image) :data data :format :z-pixmap :bits-per-pixel bits-per-pixel :bytes-per-line padded-bytes-per-line - :unit *image-unit* :pad *image-pad* - :byte-lsb-first-p *image-byte-lsb-first-p* - :bit-lsb-first-p *image-bit-lsb-first-p*))) + :unit +image-unit+ :pad +image-pad+ + :byte-lsb-first-p +image-byte-lsb-first-p+ + :bit-lsb-first-p +image-bit-lsb-first-p+))) (defun image-z->image-xy (image x y width height) (declare (type image-z image) @@ -2433,7 +2427,8 @@ (kintern (substitute #\- #\_ - (string-upcase + (#-excl string-upcase + #+excl correct-case (subseq line start end)) :test #'char=)))) (when (null name) @@ -2598,7 +2593,7 @@ (index-incf count) (unless (index= count last) (write-char #\, fstream)))) - (format fstream "};~%" fstream)))))) + (format fstream "};~%")))))) (defun bitmap-image (&optional plist &rest patterns) ;; Create an image containg pattern diff --git a/clx/input.lisp b/clx/input.lisp index 2b74b5d12..c1547b0a9 100644 --- a/clx/input.lisp +++ b/clx/input.lisp @@ -24,34 +24,35 @@ ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 12/10/87 LGO Created + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/input.lisp,v 1.10 2003/02/09 17:23:46 emarsden Exp $") +(ext:file-comment "$Id: input.lisp,v 1.11 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) ;; Event Resource (defvar *event-free-list* nil) ;; List of unused (processed) events -(eval-when (eval compile load) -(defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34) -(defvar *event-key-vector* (make-array *max-events* :initial-element nil) - "Vector of event keys - See define-event") -) -(defvar *event-macro-vector* (make-array *max-events* :initial-element nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Maximum number of events supported (the X11 alpha release only has 34) + (defconstant +max-events+ 64) + (defvar *event-key-vector* (make-array +max-events+ :initial-element nil) + "Vector of event keys - See define-event")) + +(defvar *event-macro-vector* (make-array +max-events+ :initial-element nil) "Vector of event handler functions - See declare-event") -(defvar *event-handler-vector* (make-array *max-events* :initial-element nil) +(defvar *event-handler-vector* (make-array +max-events+ :initial-element nil) "Vector of event handler functions - See declare-event") -(defvar *event-send-vector* (make-array *max-events* :initial-element nil) +(defvar *event-send-vector* (make-array +max-events+ :initial-element nil) "Vector of event sending functions - See declare-event") (defun allocate-event () (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer) - (make-reply-buffer *replysize*))) + (make-reply-buffer +replysize+))) (defun deallocate-event (reply-buffer) (declare (type reply-buffer reply-buffer)) - (setf (reply-size reply-buffer) *replysize*) + (setf (reply-size reply-buffer) +replysize+) (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) ;; Extensions are handled as follows: @@ -97,38 +98,40 @@ (type list events errors)) (let ((name-symbol (kintern name)) ;; Intern name in the keyword package (event-list (mapcar #'canonicalize-event-name events))) - `(eval-when (compile load eval) + `(eval-when (:compile-toplevel :load-toplevel :execute) (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) (delete ',name-symbol *extensions* :key #'car)))))) -(eval-when (compile eval load) -(defun canonicalize-event-name (event) - ;; Returns the event name keyword given an event name stringable - (declare (type stringable event)) - (declare (clx-values event-key)) - (kintern event)) -) ;; end eval-when - -(eval-when (compile eval load) -(defun allocate-extension-event-code (name) - ;; Allocate an event-code for an extension - ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT. - ;; The event-code is used at compile-time by macros to index the following vectors: - ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector* - (let ((event-code (get name 'event-code))) - (declare (type (or null card8) event-code)) - (unless event-code - ;; First ensure the name is for a declared extension - (unless (dolist (extension *extensions*) - (when (member name (second extension)) - (return t))) - (x-type-error name 'event-key)) - (setq event-code (position nil *event-key-vector* - :start *first-extension-event-code*)) - (setf (svref *event-key-vector* event-code) name) - (setf (get name 'event-code) event-code)) - event-code)) -) ;; end eval-when +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun canonicalize-event-name (event) + ;; Returns the event name keyword given an event name stringable + (declare (type stringable event)) + (declare (clx-values event-key)) + (kintern event))) + +(defun extension-event-key-p (key) + (dolist (extension *extensions* nil) + (when (member key (second extension)) + (return t)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun allocate-extension-event-code (name) + ;; Allocate an event-code for an extension. This is executed at + ;; COMPILE and LOAD time from DECLARE-EVENT. The event-code is + ;; used at compile-time by macros to index the following vectors: + ;; *EVENT-KEY-VECTOR* *EVENT-MACRO-VECTOR* *EVENT-HANDLER-VECTOR* + ;; *EVENT-SEND-VECTOR* + (let ((event-code (get name 'event-code))) + (declare (type (or null card8) event-code)) + (unless event-code + ;; First ensure the name is for a declared extension + (unless (extension-event-key-p name) + (x-type-error name 'event-key)) + (setq event-code (position nil *event-key-vector* + :start *first-extension-event-code*)) + (setf (svref *event-key-vector* event-code) name) + (setf (get name 'event-code) event-code)) + event-code))) (defun get-internal-event-code (display code) ;; Given an X11 event-code, return the internal event-code. @@ -263,7 +266,7 @@ (defun allocate-reply-buffer (size) (declare (type array-index size)) - (if (index<= size *replysize*) + (if (index<= size +replysize+) (allocate-event) (let ((index (integer-length (index1- size)))) (declare (type array-index index)) @@ -275,7 +278,7 @@ (declare (type reply-buffer reply-buffer)) (let ((size (reply-size reply-buffer))) (declare (type array-index size)) - (if (index<= size *replysize*) + (if (index<= size +replysize+) (deallocate-event reply-buffer) (let ((index (integer-length (index1- size)))) (declare (type array-index index)) @@ -324,18 +327,18 @@ (type array-index length)) (unwind-protect (progn - (when (index< *replysize* length) + (when (index< +replysize+ length) (let ((repbuf nil)) (declare (type (or null reply-buffer) repbuf)) (unwind-protect (progn (setq repbuf (allocate-reply-buffer length)) (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) - 0 *replysize*) + 0 +replysize+) (deallocate-event (shiftf reply-buffer repbuf nil))) (when repbuf (deallocate-reply-buffer repbuf)))) - (when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length) + (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length) (return-from read-reply-input t)) (setf (reply-data-size reply-buffer) length)) (with-event-queue-internal (display) @@ -388,7 +391,10 @@ (type generalized-boolean force-output-p) (dynamic-extent predicate-args)) (declare (type function predicate) - (dynamic-extent predicate)) + #+clx-ansi-common-lisp + (dynamic-extent predicate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg predicate)) (let ((reply-buffer nil) (token (or (current-process) (cons nil nil)))) (declare (type (or null reply-buffer) reply-buffer)) @@ -406,17 +412,20 @@ (display-input-in-progress display) nil token))) (null (buffer-listen display)))) (go force-output)) - ;; Ensure that ony one process is reading input. - (unless (or (eq (display-input-in-progress display) token) - (conditional-store (display-input-in-progress display) nil token)) - (if (eql timeout 0) - (return-from read-input :timeout) + ;; Ensure that only one process is reading input. + (unless (or (eq (display-input-in-progress display) token) + (conditional-store (display-input-in-progress display) nil token)) + (if (eql timeout 0) + (return-from read-input :timeout) (apply #'process-block "CLX Input Lock" #'(lambda (display predicate &rest predicate-args) (declare (type display display) (dynamic-extent predicate-args) (type function predicate) - (dynamic-extent predicate)) + #+clx-ansi-common-lisp + (dynamic-extent predicate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg predicate)) (or (apply predicate predicate-args) (null (display-input-in-progress display)) (not (null (display-dead display))))) @@ -432,7 +441,7 @@ (let ((eof-p (buffer-input-wait display timeout))) (when eof-p (return-from read-input eof-p)))) (without-aborts - (let ((eof-p (buffer-input display buffer-bbuf 0 *replysize* + (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+ (if force-output-p 0 timeout)))) (when eof-p (when (eq eof-p :timeout) @@ -441,14 +450,14 @@ (return-from read-input :timeout))) (setf (display-dead display) t) (return-from read-input eof-p))) - (setf (reply-data-size reply-buffer) *replysize*) + (setf (reply-data-size reply-buffer) +replysize+) (when (= (the card8 (setq type (read-card8 0))) 1) - ;; Normal replies can be longer than *replysize*, so we + ;; Normal replies can be longer than +replysize+, so we ;; have to handle them while aborts are still disallowed. (let ((value (read-reply-input display (read-card16 2) - (index+ *replysize* (index* (read-card32 4) 4)) + (index+ +replysize+ (index* (read-card32 4) 4)) (shiftf reply-buffer nil)))) (when value (return-from read-input value)) @@ -606,7 +615,7 @@ (buffer-replace buffer (display-obuf8 display) 0 - *replysize* + +replysize+ (index+ 12 (buffer-boffset display))) (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) (aref buffer 2) 0 @@ -643,7 +652,7 @@ (defmacro define-event (name code) - `(eval-when (eval compile load) + `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (svref *event-key-vector* ,code) ',name) (setf (get ',name 'event-code) ,code))) @@ -757,7 +766,10 @@ (declare (type display display) (type reply-buffer event)) (declare (type function handler) - (dynamic-extent handler)) + #+clx-ansi-common-lisp + (dynamic-extent handler) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg handler)) (reading-event (event :display display :sizes (8 16 ,@get-sizes)) (funcall handler :display display @@ -930,13 +942,13 @@ (declare-event :circulate-notify (card16 sequence) (window event-window window parent) - ((member16 :top :bottom) place)) + ((member8 :top :bottom) place)) (declare-event :circulate-request (card16 sequence) (window (parent event-window) window) (pad16 1 2) - ((member16 :top :bottom) place)) + ((member8 :top :bottom) place)) (declare-event :property-notify (card16 sequence) @@ -1168,7 +1180,10 @@ (type (or null number) timeout) (type generalized-boolean peek-p discard-p force-output-p)) (declare (type t handler) - (dynamic-extent handler)) + #+clx-ansi-common-lisp + (dynamic-extent handler) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera 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*)) @@ -1199,7 +1214,7 @@ (type (or null function) default) (clx-values sequence)) ;Default handler for initial content ;; Makes a handler sequence suitable for process-event - (make-sequence type *max-events* :initial-element default)) + (make-sequence type +max-events+ :initial-element default)) (defun event-handler (handlers event-key) (declare (type sequence handlers) @@ -1323,7 +1338,7 @@ ;; CLAUSES are of the form: ;; (event-or-events binding-list test-form . body-forms) (let ((event-key (gensym)) - (all-events (make-array *max-events* :element-type 'bit :initial-element 0))) + (all-events (make-array +max-events+ :element-type 'bit :initial-element 0))) `(reading-event (,event) (let ((,event-key (svref *event-key-vector* (event-code ,event)))) (case ,event-key @@ -1351,7 +1366,7 @@ (let ((keys (do ((i 0 (1+ i)) (key nil) (result nil)) - ((>= i *max-events*) result) + ((>= i +max-events+) result) (setq key (svref *event-key-vector* i)) (when (and key (zerop (aref all-events i))) (push key result))))) @@ -1445,7 +1460,7 @@ ;;; Error Handling ;;;----------------------------------------------------------------------------- -(eval-when (eval compile load) +(eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *xerror-vector* '#(unknown-error @@ -1521,6 +1536,17 @@ (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)) @@ -1535,7 +1561,7 @@ ;; 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/clx/keysyms.lisp b/clx/keysyms.lisp index 3049b7aab..2a62d2b2a 100644 --- a/clx/keysyms.lisp +++ b/clx/keysyms.lisp @@ -17,9 +17,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/keysyms.lisp,v 1.4 2003/04/11 12:07:30 pmai Exp $") +(ext:file-comment "$Id: keysyms.lisp,v 1.5 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) @@ -36,6 +36,16 @@ (define-keysym-set :publish (keysym 10 0) (keysym 10 255)) (define-keysym-set :apl (keysym 11 0) (keysym 11 255)) (define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) +(define-keysym-set :thai (keysym 13 0) (keysym 13 255)) +(define-keysym-set :korean (keysym 14 0) (keysym 14 255)) +(define-keysym-set :latin-5 (keysym 15 0) (keysym 15 255)) +(define-keysym-set :latin-6 (keysym 16 0) (keysym 16 255)) +(define-keysym-set :latin-7 (keysym 17 0) (keysym 17 255)) +(define-keysym-set :latin-8 (keysym 18 0) (keysym 18 255)) +(define-keysym-set :latin-9 (keysym 19 0) (keysym 19 255)) +(define-keysym-set :currency (keysym 32 0) (keysym 32 255)) +(define-keysym-set :|3270| (keysym 253 0) (keysym 253 255)) +(define-keysym-set :xkb (keysym 254 0) (keysym 254 255)) (define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) (define-keysym :character-set-switch character-set-switch-keysym) @@ -159,4 +169,268 @@ (define-keysym #\backspace (keysym 255 008)) ; :tty ) +;;; these keysym definitions are only correct if the underlying lisp's +;;; definition of characters between 160 and 255 match latin1 exactly. +;;; If the characters are in some way locale-dependent (as, I believe, +;;; in Allegro8) or are treated as opaque without any notions of +;;; graphicness or case (as in cmucl and openmcl) then defining these +;;; keysyms is either not useful or wrong. -- CSR, 2006-03-14 +#+sbcl +(progn + (do ((i 160 (+ i 1))) + ((>= i 256)) + (if (or (<= #xc0 i #xd6) + (<= #xd8 i #xde)) + (define-keysym (code-char i) i :lowercase (+ i 32)) + (define-keysym (code-char i) i)))) + +#+(or lispm excl) +(progn ;; Nonstandard characters + (define-keysym #\escape (keysym 255 027)) ; :tty + ) + +#+ti +(progn + (define-keysym #\Inverted-exclamation-mark 161) + (define-keysym #\american-cent-sign 162) + (define-keysym #\british-pound-sign 163) + (define-keysym #\Currency-sign 164) + (define-keysym #\Japanese-yen-sign 165) + (define-keysym #\Yen 165) + (define-keysym #\Broken-bar 166) + (define-keysym #\Section-symbol 167) + (define-keysym #\Section 167) + (define-keysym #\Diaresis 168) + (define-keysym #\Umlaut 168) + (define-keysym #\Copyright-sign 169) + (define-keysym #\Copyright 169) + (define-keysym #\Feminine-ordinal-indicator 170) + (define-keysym #\Angle-quotation-left 171) + (define-keysym #\Soft-hyphen 173) + (define-keysym #\Shy 173) + (define-keysym #\Registered-trademark 174) + (define-keysym #\Macron 175) + (define-keysym #\Degree-sign 176) + (define-keysym #\Ring 176) + (define-keysym #\Plus-minus-sign 177) + (define-keysym #\Superscript-2 178) + (define-keysym #\Superscript-3 179) + (define-keysym #\Acute-accent 180) + (define-keysym #\Greek-mu 181) + (define-keysym #\Paragraph-symbol 182) + (define-keysym #\Paragraph 182) + (define-keysym #\Pilcrow-sign 182) + (define-keysym #\Middle-dot 183) + (define-keysym #\Cedilla 184) + (define-keysym #\Superscript-1 185) + (define-keysym #\Masculine-ordinal-indicator 186) + (define-keysym #\Angle-quotation-right 187) + (define-keysym #\Fraction-1/4 188) + (define-keysym #\One-quarter 188) + (define-keysym #\Fraction-1/2 189) + (define-keysym #\One-half 189) + (define-keysym #\Fraction-3/4 190) + (define-keysym #\Three-quarters 190) + (define-keysym #\Inverted-question-mark 191) + (define-keysym #\Multiplication-sign 215) + (define-keysym #\Eszet 223) + (define-keysym #\Division-sign 247) +) + +#+ti +(progn ;; There are no 7-bit ascii representations for the following + ;; European characters, so use int-char to create them to ensure + ;; nothing is lost while sending files through the mail. + (define-keysym (int-char 192) 192 :lowercase 224) + (define-keysym (int-char 193) 193 :lowercase 225) + (define-keysym (int-char 194) 194 :lowercase 226) + (define-keysym (int-char 195) 195 :lowercase 227) + (define-keysym (int-char 196) 196 :lowercase 228) + (define-keysym (int-char 197) 197 :lowercase 229) + (define-keysym (int-char 198) 198 :lowercase 230) + (define-keysym (int-char 199) 199 :lowercase 231) + (define-keysym (int-char 200) 200 :lowercase 232) + (define-keysym (int-char 201) 201 :lowercase 233) + (define-keysym (int-char 202) 202 :lowercase 234) + (define-keysym (int-char 203) 203 :lowercase 235) + (define-keysym (int-char 204) 204 :lowercase 236) + (define-keysym (int-char 205) 205 :lowercase 237) + (define-keysym (int-char 206) 206 :lowercase 238) + (define-keysym (int-char 207) 207 :lowercase 239) + (define-keysym (int-char 208) 208 :lowercase 240) + (define-keysym (int-char 209) 209 :lowercase 241) + (define-keysym (int-char 210) 210 :lowercase 242) + (define-keysym (int-char 211) 211 :lowercase 243) + (define-keysym (int-char 212) 212 :lowercase 244) + (define-keysym (int-char 213) 213 :lowercase 245) + (define-keysym (int-char 214) 214 :lowercase 246) + (define-keysym (int-char 215) 215) + (define-keysym (int-char 216) 216 :lowercase 248) + (define-keysym (int-char 217) 217 :lowercase 249) + (define-keysym (int-char 218) 218 :lowercase 250) + (define-keysym (int-char 219) 219 :lowercase 251) + (define-keysym (int-char 220) 220 :lowercase 252) + (define-keysym (int-char 221) 221 :lowercase 253) + (define-keysym (int-char 222) 222 :lowercase 254) + (define-keysym (int-char 223) 223) + (define-keysym (int-char 224) 224) + (define-keysym (int-char 225) 225) + (define-keysym (int-char 226) 226) + (define-keysym (int-char 227) 227) + (define-keysym (int-char 228) 228) + (define-keysym (int-char 229) 229) + (define-keysym (int-char 230) 230) + (define-keysym (int-char 231) 231) + (define-keysym (int-char 232) 232) + (define-keysym (int-char 233) 233) + (define-keysym (int-char 234) 234) + (define-keysym (int-char 235) 235) + (define-keysym (int-char 236) 236) + (define-keysym (int-char 237) 237) + (define-keysym (int-char 238) 238) + (define-keysym (int-char 239) 239) + (define-keysym (int-char 240) 240) + (define-keysym (int-char 241) 241) + (define-keysym (int-char 242) 242) + (define-keysym (int-char 243) 243) + (define-keysym (int-char 244) 244) + (define-keysym (int-char 245) 245) + (define-keysym (int-char 246) 246) + (define-keysym (int-char 247) 247) + (define-keysym (int-char 248) 248) + (define-keysym (int-char 249) 249) + (define-keysym (int-char 250) 250) + (define-keysym (int-char 251) 251) + (define-keysym (int-char 252) 252) + (define-keysym (int-char 253) 253) + (define-keysym (int-char 254) 254) + (define-keysym (int-char 255) 255) + ) + +#+lispm ;; Nonstandard characters +(progn + (define-keysym #\center-dot (keysym 183)) ; :latin-1 + (define-keysym #\down-arrow (keysym 008 254)) ; :technical + (define-keysym #\alpha (keysym 007 225)) ; :greek + (define-keysym #\beta (keysym 007 226)) ; :greek + (define-keysym #\and-sign (keysym 008 222)) ; :technical + (define-keysym #\not-sign (keysym 172)) ; :latin-1 + (define-keysym #\epsilon (keysym 007 229)) ; :greek + (define-keysym #\pi (keysym 007 240)) ; :greek + (define-keysym #\lambda (keysym 007 235)) ; :greek + (define-keysym #\gamma (keysym 007 227)) ; :greek + (define-keysym #\delta (keysym 007 228)) ; :greek + (define-keysym #\up-arrow (keysym 008 252)) ; :technical + (define-keysym #\plus-minus (keysym 177)) ; :latin-1 + (define-keysym #\infinity (keysym 008 194)) ; :technical + (define-keysym #\partial-delta (keysym 008 239)) ; :technical + (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl + (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl + (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl + (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl + (define-keysym #\double-arrow (keysym 008 205)) ; :technical + (define-keysym #\left-arrow (keysym 008 251)) ; :technical + (define-keysym #\right-arrow (keysym 008 253)) ; :technical + (define-keysym #\not-equals (keysym 008 189)) ; :technical + (define-keysym #\less-or-equal (keysym 008 188)) ; :technical + (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical + (define-keysym #\equivalence (keysym 008 207)) ; :technical + (define-keysym #\or-sign (keysym 008 223)) ; :technical + (define-keysym #\integral (keysym 008 191)) ; :technical +;; break isn't null +;; (define-keysym #\null (keysym 255 107)) ; :function + (define-keysym #\clear-input (keysym 255 011)) ; :tty + (define-keysym #\help (keysym 255 106)) ; :function + (define-keysym #\refresh (keysym 255 097)) ; :function + (define-keysym #\abort (keysym 255 105)) ; :function + (define-keysym #\resume (keysym 255 098)) ; :function + (define-keysym #\end (keysym 255 087)) ; :cursor +;;#\universal-quantifier +;;#\existential-quantifier +;;#\circle-plus +;;#\circle-cross same as #\circle-x + ) + +#+genera +(progn +;;#\network +;;#\symbol-help + (define-keysym #\lozenge (keysym 009 224)) ; :special + (define-keysym #\suspend (keysym 255 019)) ; :tty + (define-keysym #\function (keysym 255 032)) ; :function + (define-keysym #\square (keysym 010 231)) ; :publishing + (define-keysym #\circle (keysym 010 230)) ; :publishing + (define-keysym #\triangle (keysym 010 232)) ; :publishing + (define-keysym #\scroll (keysym 255 086)) ; :cursor + (define-keysym #\select (keysym 255 096)) ; :function + (define-keysym #\complete (keysym 255 104)) ; :function + ) + +#+ti +(progn + (define-keysym #\terminal (keysym 255 032)) ; :function + (define-keysym #\system (keysym 255 096)) ; :function + (define-keysym #\center-arrow (keysym 255 80)) + (define-keysym #\left-arrow (keysym 255 081)) ; :cursor + (define-keysym #\up-arrow (keysym 255 082)) ; :cursor + (define-keysym #\right-arrow (keysym 255 083)) ; :cursor + (define-keysym #\down-arrow (keysym 255 084)) ; :cursor + (define-keysym #\end (keysym 255 087)) ; :cursor + (define-keysym #\undo (keysym 255 101)) ; :function + (define-keysym #\break (keysym 255 107)) + (define-keysym #\keypad-space (keysym 255 128)) ; :keypad + (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad + (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad + (define-keysym #\f1 (keysym 255 145)) ; :keypad + (define-keysym #\f2 (keysym 255 146)) ; :keypad + (define-keysym #\f3 (keysym 255 147)) ; :keypad + (define-keysym #\f4 (keysym 255 148)) ; :keypad + (define-keysym #\f1 (keysym 255 190)) ; :keypad + (define-keysym #\f2 (keysym 255 191)) ; :keypad + (define-keysym #\f3 (keysym 255 192)) ; :keypad + (define-keysym #\f4 (keysym 255 193)) ; :keypad + (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad + (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad + (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad + (define-keysym #\keypad-period (keysym 255 174)) ; :keypad + (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad + (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad + (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad + (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad + (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad + (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad + (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad + (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad + (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad + (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad + (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad + (define-keysym #\f1 (keysym 255 192)) ; :function + (define-keysym #\f2 (keysym 255 193)) ; :function + (define-keysym #\f3 (keysym 255 194)) ; :function + (define-keysym #\f4 (keysym 255 195)) ; :function + (define-keysym #\network (keysym 255 214)) + (define-keysym #\status (keysym 255 215)) + (define-keysym #\clear-screen (keysym 255 217)) + (define-keysym #\left (keysym 255 218)) + (define-keysym #\middle (keysym 255 219)) + (define-keysym #\right (keysym 255 220)) + (define-keysym #\resume (keysym 255 221)) + (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete + ) + +#+ti +(progn ;; Explorer specific characters + (define-keysym #\Call (keysym 131)) ; :latin-1 + (define-keysym #\Macro (keysym 133)) ; :latin-1 + (define-keysym #\Quote (keysym 142)) ; :latin-1 + (define-keysym #\Hold-output (keysym 143)) ; :latin-1 + (define-keysym #\Stop-output (keysym 144)) ; :latin-1 + (define-keysym #\Center (keysym 156)) ; :latin-1 + (define-keysym #\no-break-space (keysym 160)) ; :latin-1 + + (define-keysym #\circle-plus (keysym 13)) ; :latin-1 + (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 + (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 + (define-keysym #\circle-cross (keysym 22)) ; :latin-1 + ) diff --git a/clx/macros.lisp b/clx/macros.lisp index 717e4e0b7..0652bc105 100644 --- a/clx/macros.lisp +++ b/clx/macros.lisp @@ -15,11 +15,8 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/macros.lisp,v 1.6 1999/03/16 23:37:44 pw Exp $") -;;; CLX basicly implements a very low overhead remote procedure call +;;; CLX basically implements a very low overhead remote procedure call ;;; to the server. This file contains macros which generate the code ;;; for both the client AND the server, given a specification of the ;;; interface. This was done to eliminate errors that may occur because @@ -28,8 +25,17 @@ ;;; This is built on top of BUFFER +#+cmu +(ext:file-comment "$Id: macros.lisp,v 1.7 2007/08/21 15:49:28 fgilham Exp $") + (in-package :xlib) +(defmacro type-check (value type) + value type + (when +type-check?+ + `(unless (type? ,value ,type) + (x-type-error ,value ,type)))) + ;;; This variable is used by the required-arg macro just to satisfy compilers. (defvar *required-arg-dummy*) @@ -66,14 +72,14 @@ (error "~s isn't a known field accessor" name))) increment)) -(eval-when (eval compile load) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun getify (name) (xintern name '-get)) (defun putify (name &optional predicate-p) (xintern name '-put (if predicate-p '-predicating ""))) - ;; Use &body so zmacs indents properly +;;; Use &body so zmacs indents properly (defmacro define-accessor (name (width) &body get-put-macros) ;; The first body form defines the get macro ;; The second body form defines the put macro @@ -93,7 +99,7 @@ ,@(cdr get-macro)) (defmacro ,(putify name) ,(car put-macro) ,@(cdr put-macro)) - ,@(when *type-check?* + ,@(when +type-check?+ (let ((predicating-put (third get-put-macros))) (when predicating-put `((setf (get ',name 'predicating-put) t) @@ -225,12 +231,14 @@ (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card8 ,index (position ,thing - (the simple-vector ',(apply #'vector keywords)) + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (let ((value (gensym))) `(let ((,value (position ,thing - (the simple-vector ',(apply #'vector keywords)) + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card8 ,index ,value)))))) @@ -243,12 +251,14 @@ (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card16 ,index (position ,thing - (the simple-vector ',(apply #'vector keywords)) + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (let ((value (gensym))) `(let ((,value (position ,thing - (the simple-vector ',(apply #'vector keywords)) + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card16 ,index ,value)))))) @@ -261,13 +271,15 @@ (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card29 ,index (position ,thing - (the simple-vector ',(apply #'vector keywords)) + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (if (cdr keywords) ;; IF more than one (let ((value (gensym))) `(let ((,value (position ,thing - (the simple-vector ',(apply #'vector keywords)) + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card29 ,index ,value)))) `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) @@ -303,14 +315,14 @@ ((index) (let ((value (gensym))) `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length *boole-vector*))) ,value)) - (type-check ,value '(integer 0 (,(length *boole-vector*)))) - (svref *boole-vector* ,value)))) + (declare (type (integer 0 (,(length +boole-vector+))) ,value)) + (type-check ,value '(integer 0 (,(length +boole-vector+)))) + (svref +boole-vector+ ,value)))) ((index thing) - `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*)))) + `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+)))) ((index thing) (let ((value (gensym))) - `(let ((,value (position ,thing (the simple-vector *boole-vector*)))) + `(let ((,value (position ,thing (the simple-vector +boole-vector+)))) (and ,value (write-card29 ,index ,value)))))) (define-accessor null (32) @@ -506,7 +518,7 @@ (result)) ((endp types) `(cond ,@(nreverse result) - ,@(when *type-check?* + ,@(when +type-check?+ `((t (x-type-error ,value '(or ,@type-list))))))) (let* ((type (car types)) (type-name type) @@ -516,7 +528,7 @@ type-name (car type))) (push `(,@(cond ((get type-name 'predicating-put) nil) - ((or *type-check?* (cdr types)) `((type? ,value ',type))) + ((or +type-check?+ (cdr types)) `((type? ,value ',type))) (t '(t))) (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) result))))) @@ -531,7 +543,10 @@ (defun mask-get (index type-values body-function) (declare (type function body-function) - (dynamic-extent body-function)) + #+clx-ansi-common-lisp + (dynamic-extent body-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) @@ -562,7 +577,10 @@ (defun mask-put (index type-values body-function) (declare (type function body-function) - (dynamic-extent body-function)) + #+clx-ansi-common-lisp + (dynamic-extent body-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) @@ -596,11 +614,8 @@ ; ; Wrapper macros, for use around the above ; -(defmacro type-check (value type) - value type - (when *type-check?* - `(unless (type? ,value ,type) - (x-type-error ,value ,type)))) + +;;; type-check was here, and has been moved up (defmacro check-put (index value type &rest args &environment env) (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) @@ -623,7 +638,10 @@ (defun get-put-items (index type-args putp &optional body-function) (declare (type (or null function) body-function) - (dynamic-extent body-function)) + #+clx-ansi-common-lisp + (dynamic-extent body-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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. @@ -673,7 +691,7 @@ &body type-args) (multiple-value-bind (code index item-sizes) (get-put-items 4 type-args t) - (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*)) + (let ((length (if length `(index+ ,length +requestsize+) '+requestsize+)) (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) `(with-buffer-output (,buffer :length ,length :sizes ,sizes) (setf (buffer-last-request ,buffer) buffer-boffset) @@ -693,6 +711,7 @@ (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 @@ -732,6 +751,7 @@ (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.)) @@ -817,126 +837,126 @@ ;;; Request codes ;;; -(defconstant *x-createwindow* 1) -(defconstant *x-changewindowattributes* 2) -(defconstant *x-getwindowattributes* 3) -(defconstant *x-destroywindow* 4) -(defconstant *x-destroysubwindows* 5) -(defconstant *x-changesaveset* 6) -(defconstant *x-reparentwindow* 7) -(defconstant *x-mapwindow* 8) -(defconstant *x-mapsubwindows* 9) -(defconstant *x-unmapwindow* 10) -(defconstant *x-unmapsubwindows* 11) -(defconstant *x-configurewindow* 12) -(defconstant *x-circulatewindow* 13) -(defconstant *x-getgeometry* 14) -(defconstant *x-querytree* 15) -(defconstant *x-internatom* 16) -(defconstant *x-getatomname* 17) -(defconstant *x-changeproperty* 18) -(defconstant *x-deleteproperty* 19) -(defconstant *x-getproperty* 20) -(defconstant *x-listproperties* 21) -(defconstant *x-setselectionowner* 22) -(defconstant *x-getselectionowner* 23) -(defconstant *x-convertselection* 24) -(defconstant *x-sendevent* 25) -(defconstant *x-grabpointer* 26) -(defconstant *x-ungrabpointer* 27) -(defconstant *x-grabbutton* 28) -(defconstant *x-ungrabbutton* 29) -(defconstant *x-changeactivepointergrab* 30) -(defconstant *x-grabkeyboard* 31) -(defconstant *x-ungrabkeyboard* 32) -(defconstant *x-grabkey* 33) -(defconstant *x-ungrabkey* 34) -(defconstant *x-allowevents* 35) -(defconstant *x-grabserver* 36) -(defconstant *x-ungrabserver* 37) -(defconstant *x-querypointer* 38) -(defconstant *x-getmotionevents* 39) -(defconstant *x-translatecoords* 40) -(defconstant *x-warppointer* 41) -(defconstant *x-setinputfocus* 42) -(defconstant *x-getinputfocus* 43) -(defconstant *x-querykeymap* 44) -(defconstant *x-openfont* 45) -(defconstant *x-closefont* 46) -(defconstant *x-queryfont* 47) -(defconstant *x-querytextextents* 48) -(defconstant *x-listfonts* 49) -(defconstant *x-listfontswithinfo* 50) -(defconstant *x-setfontpath* 51) -(defconstant *x-getfontpath* 52) -(defconstant *x-createpixmap* 53) -(defconstant *x-freepixmap* 54) -(defconstant *x-creategc* 55) -(defconstant *x-changegc* 56) -(defconstant *x-copygc* 57) -(defconstant *x-setdashes* 58) -(defconstant *x-setcliprectangles* 59) -(defconstant *x-freegc* 60) -(defconstant *x-cleartobackground* 61) -(defconstant *x-copyarea* 62) -(defconstant *x-copyplane* 63) -(defconstant *x-polypoint* 64) -(defconstant *x-polyline* 65) -(defconstant *x-polysegment* 66) -(defconstant *x-polyrectangle* 67) -(defconstant *x-polyarc* 68) -(defconstant *x-fillpoly* 69) -(defconstant *x-polyfillrectangle* 70) -(defconstant *x-polyfillarc* 71) -(defconstant *x-putimage* 72) -(defconstant *x-getimage* 73) -(defconstant *x-polytext8* 74) -(defconstant *x-polytext16* 75) -(defconstant *x-imagetext8* 76) -(defconstant *x-imagetext16* 77) -(defconstant *x-createcolormap* 78) -(defconstant *x-freecolormap* 79) -(defconstant *x-copycolormapandfree* 80) -(defconstant *x-installcolormap* 81) -(defconstant *x-uninstallcolormap* 82) -(defconstant *x-listinstalledcolormaps* 83) -(defconstant *x-alloccolor* 84) -(defconstant *x-allocnamedcolor* 85) -(defconstant *x-alloccolorcells* 86) -(defconstant *x-alloccolorplanes* 87) -(defconstant *x-freecolors* 88) -(defconstant *x-storecolors* 89) -(defconstant *x-storenamedcolor* 90) -(defconstant *x-querycolors* 91) -(defconstant *x-lookupcolor* 92) -(defconstant *x-createcursor* 93) -(defconstant *x-createglyphcursor* 94) -(defconstant *x-freecursor* 95) -(defconstant *x-recolorcursor* 96) -(defconstant *x-querybestsize* 97) -(defconstant *x-queryextension* 98) -(defconstant *x-listextensions* 99) -(defconstant *x-setkeyboardmapping* 100) -(defconstant *x-getkeyboardmapping* 101) -(defconstant *x-changekeyboardcontrol* 102) -(defconstant *x-getkeyboardcontrol* 103) -(defconstant *x-bell* 104) -(defconstant *x-changepointercontrol* 105) -(defconstant *x-getpointercontrol* 106) -(defconstant *x-setscreensaver* 107) -(defconstant *x-getscreensaver* 108) -(defconstant *x-changehosts* 109) -(defconstant *x-listhosts* 110) -(defconstant *x-changeaccesscontrol* 111) -(defconstant *x-changeclosedownmode* 112) -(defconstant *x-killclient* 113) -(defconstant *x-rotateproperties* 114) -(defconstant *x-forcescreensaver* 115) -(defconstant *x-setpointermapping* 116) -(defconstant *x-getpointermapping* 117) -(defconstant *x-setmodifiermapping* 118) -(defconstant *x-getmodifiermapping* 119) -(defconstant *x-nooperation* 127) +(defconstant +x-createwindow+ 1) +(defconstant +x-changewindowattributes+ 2) +(defconstant +x-getwindowattributes+ 3) +(defconstant +x-destroywindow+ 4) +(defconstant +x-destroysubwindows+ 5) +(defconstant +x-changesaveset+ 6) +(defconstant +x-reparentwindow+ 7) +(defconstant +x-mapwindow+ 8) +(defconstant +x-mapsubwindows+ 9) +(defconstant +x-unmapwindow+ 10) +(defconstant +x-unmapsubwindows+ 11) +(defconstant +x-configurewindow+ 12) +(defconstant +x-circulatewindow+ 13) +(defconstant +x-getgeometry+ 14) +(defconstant +x-querytree+ 15) +(defconstant +x-internatom+ 16) +(defconstant +x-getatomname+ 17) +(defconstant +x-changeproperty+ 18) +(defconstant +x-deleteproperty+ 19) +(defconstant +x-getproperty+ 20) +(defconstant +x-listproperties+ 21) +(defconstant +x-setselectionowner+ 22) +(defconstant +x-getselectionowner+ 23) +(defconstant +x-convertselection+ 24) +(defconstant +x-sendevent+ 25) +(defconstant +x-grabpointer+ 26) +(defconstant +x-ungrabpointer+ 27) +(defconstant +x-grabbutton+ 28) +(defconstant +x-ungrabbutton+ 29) +(defconstant +x-changeactivepointergrab+ 30) +(defconstant +x-grabkeyboard+ 31) +(defconstant +x-ungrabkeyboard+ 32) +(defconstant +x-grabkey+ 33) +(defconstant +x-ungrabkey+ 34) +(defconstant +x-allowevents+ 35) +(defconstant +x-grabserver+ 36) +(defconstant +x-ungrabserver+ 37) +(defconstant +x-querypointer+ 38) +(defconstant +x-getmotionevents+ 39) +(defconstant +x-translatecoords+ 40) +(defconstant +x-warppointer+ 41) +(defconstant +x-setinputfocus+ 42) +(defconstant +x-getinputfocus+ 43) +(defconstant +x-querykeymap+ 44) +(defconstant +x-openfont+ 45) +(defconstant +x-closefont+ 46) +(defconstant +x-queryfont+ 47) +(defconstant +x-querytextextents+ 48) +(defconstant +x-listfonts+ 49) +(defconstant +x-listfontswithinfo+ 50) +(defconstant +x-setfontpath+ 51) +(defconstant +x-getfontpath+ 52) +(defconstant +x-createpixmap+ 53) +(defconstant +x-freepixmap+ 54) +(defconstant +x-creategc+ 55) +(defconstant +x-changegc+ 56) +(defconstant +x-copygc+ 57) +(defconstant +x-setdashes+ 58) +(defconstant +x-setcliprectangles+ 59) +(defconstant +x-freegc+ 60) +(defconstant +x-cleartobackground+ 61) +(defconstant +x-copyarea+ 62) +(defconstant +x-copyplane+ 63) +(defconstant +x-polypoint+ 64) +(defconstant +x-polyline+ 65) +(defconstant +x-polysegment+ 66) +(defconstant +x-polyrectangle+ 67) +(defconstant +x-polyarc+ 68) +(defconstant +x-fillpoly+ 69) +(defconstant +x-polyfillrectangle+ 70) +(defconstant +x-polyfillarc+ 71) +(defconstant +x-putimage+ 72) +(defconstant +x-getimage+ 73) +(defconstant +x-polytext8+ 74) +(defconstant +x-polytext16+ 75) +(defconstant +x-imagetext8+ 76) +(defconstant +x-imagetext16+ 77) +(defconstant +x-createcolormap+ 78) +(defconstant +x-freecolormap+ 79) +(defconstant +x-copycolormapandfree+ 80) +(defconstant +x-installcolormap+ 81) +(defconstant +x-uninstallcolormap+ 82) +(defconstant +x-listinstalledcolormaps+ 83) +(defconstant +x-alloccolor+ 84) +(defconstant +x-allocnamedcolor+ 85) +(defconstant +x-alloccolorcells+ 86) +(defconstant +x-alloccolorplanes+ 87) +(defconstant +x-freecolors+ 88) +(defconstant +x-storecolors+ 89) +(defconstant +x-storenamedcolor+ 90) +(defconstant +x-querycolors+ 91) +(defconstant +x-lookupcolor+ 92) +(defconstant +x-createcursor+ 93) +(defconstant +x-createglyphcursor+ 94) +(defconstant +x-freecursor+ 95) +(defconstant +x-recolorcursor+ 96) +(defconstant +x-querybestsize+ 97) +(defconstant +x-queryextension+ 98) +(defconstant +x-listextensions+ 99) +(defconstant +x-setkeyboardmapping+ 100) +(defconstant +x-getkeyboardmapping+ 101) +(defconstant +x-changekeyboardcontrol+ 102) +(defconstant +x-getkeyboardcontrol+ 103) +(defconstant +x-bell+ 104) +(defconstant +x-changepointercontrol+ 105) +(defconstant +x-getpointercontrol+ 106) +(defconstant +x-setscreensaver+ 107) +(defconstant +x-getscreensaver+ 108) +(defconstant +x-changehosts+ 109) +(defconstant +x-listhosts+ 110) +(defconstant +x-changeaccesscontrol+ 111) +(defconstant +x-changeclosedownmode+ 112) +(defconstant +x-killclient+ 113) +(defconstant +x-rotateproperties+ 114) +(defconstant +x-forcescreensaver+ 115) +(defconstant +x-setpointermapping+ 116) +(defconstant +x-getpointermapping+ 117) +(defconstant +x-setmodifiermapping+ 118) +(defconstant +x-getmodifiermapping+ 119) +(defconstant +x-nooperation+ 127) ;;; Some macros for threaded lists diff --git a/clx/manager.lisp b/clx/manager.lisp index eaec555a9..545fdf18a 100644 --- a/clx/manager.lisp +++ b/clx/manager.lisp @@ -17,9 +17,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/manager.lisp,v 1.8 2004/10/06 16:54:07 emarsden Exp $") +(ext:file-comment "$Id: manager.lisp,v 1.9 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) @@ -320,7 +320,7 @@ (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))))) + (decode-type (member-vector +win-gravity-vector+) (aref vector 17))))) ;; Obsolete fields (when (or (logbitp 0 flags) (logbitp 2 flags)) (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) @@ -375,7 +375,7 @@ (when (wm-size-hints-win-gravity hints) (setf (ldb (byte 1 9) flags) 1 (aref vector 17) (encode-type - (member-vector *win-gravity-vector*) + (member-vector +win-gravity-vector+) (wm-size-hints-win-gravity hints)))) ;; Obsolete fields (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) @@ -730,7 +730,36 @@ (get-property root property :type type :result-type result-type :start start :end end :transform transform))) -(defun (setf cut-buffer) +;; 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 (data display &key (buffer 0) (type :STRING) (format 8) (start 0) end (transform #'char->card8)) (declare (type sequence data) diff --git a/clx/package.lisp b/clx/package.lisp index 199cfc741..8c44744e0 100644 --- a/clx/package.lisp +++ b/clx/package.lisp @@ -10,17 +10,239 @@ ;;; documentation, and that the name MIT not be used in advertising or ;;; publicity pertaining to distribution of the software without specific, ;;; written prior permission. + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/package.lisp,v 1.6 2004/03/23 12:16:47 emarsden Exp $") +(ext:file-comment "$Id: package.lisp,v 1.7 2007/08/21 15:49:28 fgilham Exp $") + +;;; 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) +(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) -(defpackage :xlib - (:use :common-lisp) +#+clx-ansi-common-lisp +(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) (:export *version* access-control access-error access-hosts activate-screen-saver add-access-host add-resource add-to-save-set @@ -50,7 +272,8 @@ 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-finish-output + 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 @@ -108,7 +331,8 @@ 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 + motion-events name-error no-operation + open-default-display 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 @@ -166,3 +390,6 @@ 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)) + + + diff --git a/clx/provide.lisp b/clx/provide.lisp new file mode 100644 index 000000000..78b385c85 --- /dev/null +++ b/clx/provide.lisp @@ -0,0 +1,67 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER; -*- + +;;;; Module definition for CLX + +;;; This file is a Common Lisp Module description, but you will have to edit +;;; it to meet the needs of your site. + +;;; Ideally, this file (or a file that loads this file) should be +;;; located in the system directory that REQUIRE searches. Thus a user +;;; would say +;;; (require :clx) +;;; to load CLX. If there is no such registry, then the user must +;;; put in a site specific +;;; (require :clx <pathname-of-this-file>) +;;; + +#+cmu +(ext:file-comment "$Id: provide.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $") + +#+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) + +(defvar *clx-source-pathname* + (pathname "/src/local/clx/*.l")) + +(defvar *clx-binary-pathname* + (let ((lisp + (or #+lucid "lucid" + #+akcl "akcl" + #+kcl "kcl" + #+ibcl "ibcl" + (error "Can't provide CLX for this lisp."))) + (architecture + (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" + #+(or sun4 sparc) "sparc" + #+(and hp (or mc68000 mc68020)) "hp9000s300" + #+vax "vax" + #+prime "prime" + #+sunrise "sunrise" + #+ibm-rt-pc "ibm-rt-pc" + #+mips "mips" + #+prism "prism" + (error "Can't provide CLX for this architecture.")))) + (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) + +(defvar *compile-clx* + nil) + +(load (merge-pathnames "defsystem" *clx-source-pathname*)) + +(if *compile-clx* + (compile-clx *clx-source-pathname* *clx-binary-pathname*) + (load-clx *clx-binary-pathname*)) + +) diff --git a/clx/requests.lisp b/clx/requests.lisp index f71920a5f..d2ec05b13 100644 --- a/clx/requests.lisp +++ b/clx/requests.lisp @@ -15,9 +15,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/requests.lisp,v 1.7 2003/02/03 14:19:58 emarsden Exp $") +(ext:file-comment "$Id: requests.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) @@ -94,7 +94,7 @@ (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask))) ;Make the request - (with-buffer-request (display *x-createwindow*) + (with-buffer-request (display +x-createwindow+) (data depth) (resource-id wid) (window parent) @@ -108,8 +108,8 @@ (t (visual-info-id visual)))) (mask (card32 back-pixmap back-pixel border-pixmap border-pixel) - ((member-vector *bit-gravity-vector*) bit-gravity) - ((member-vector *win-gravity-vector*) gravity) + ((member-vector +bit-gravity-vector+) bit-gravity) + ((member-vector +win-gravity-vector+) gravity) ((member :not-useful :when-mapped :always) backing-store) (card32 backing-planes backing-pixel) ((member :off :on) override-redirect save-under) @@ -120,62 +120,62 @@ (defun destroy-window (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-destroywindow*) + (with-buffer-request ((window-display window) +x-destroywindow+) (window window))) (defun destroy-subwindows (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-destroysubwindows*) + (with-buffer-request ((window-display window) +x-destroysubwindows+) (window window))) (defun add-to-save-set (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-changesaveset*) + (with-buffer-request ((window-display window) +x-changesaveset+) (data 0) (window window))) (defun remove-from-save-set (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-changesaveset*) + (with-buffer-request ((window-display window) +x-changesaveset+) (data 1) (window window))) (defun reparent-window (window parent x y) (declare (type window window parent) (type int16 x y)) - (with-buffer-request ((window-display window) *x-reparentwindow*) + (with-buffer-request ((window-display window) +x-reparentwindow+) (window window parent) (int16 x y))) (defun map-window (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-mapwindow*) + (with-buffer-request ((window-display window) +x-mapwindow+) (window window))) (defun map-subwindows (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-mapsubwindows*) + (with-buffer-request ((window-display window) +x-mapsubwindows+) (window window))) (defun unmap-window (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-unmapwindow*) + (with-buffer-request ((window-display window) +x-unmapwindow+) (window window))) (defun unmap-subwindows (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-unmapsubwindows*) + (with-buffer-request ((window-display window) +x-unmapsubwindows+) (window window))) (defun circulate-window-up (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-circulatewindow*) + (with-buffer-request ((window-display window) +x-circulatewindow+) (data 0) (window window))) (defun circulate-window-down (window) (declare (type window window)) - (with-buffer-request ((window-display window) *x-circulatewindow*) + (with-buffer-request ((window-display window) +x-circulatewindow+) (data 1) (window window))) @@ -185,13 +185,13 @@ (declare (clx-values (clx-sequence window) parent root)) (let ((display (window-display window))) (multiple-value-bind (root parent sequence) - (with-buffer-request-and-reply (display *x-querytree* nil :sizes (8 16 32)) + (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32)) ((window window)) (values (window-get 8) (resource-id-get 12) (sequence-get :length (card16-get 16) :result-type result-type - :index *replysize*))) + :index +replysize+))) ;; Parent is NIL for root window (setq parent (and (plusp parent) (lookup-window display parent))) (dotimes (i (length sequence)) ; Convert ID's to window's @@ -213,7 +213,7 @@ (let ((string (symbol-name name))) (declare (type string string)) (multiple-value-bind (id) - (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32) + (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) ((data 0) (card16 (length string)) (pad16 nil) @@ -237,7 +237,7 @@ (let ((string (symbol-name name))) (declare (type string string)) (multiple-value-bind (id) - (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32) + (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) ((data 1) (card16 (length string)) (pad16 nil) @@ -259,10 +259,10 @@ (let ((keyword (kintern (with-buffer-request-and-reply - (display *x-getatomname* nil :sizes (16)) + (display +x-getatomname+ nil :sizes (16)) ((resource-id atom-id)) (values - (string-get (card16-get 8) *replysize*)))))) + (string-get (card16-get 8) +replysize+)))))) (declare (type keyword keyword)) (setf (atom-id keyword display) atom-id) keyword)))) @@ -293,7 +293,7 @@ (declare (type display display) (type array-index length) (type resource-id property-id type-id)) - (with-buffer-request (display *x-changeproperty*) + (with-buffer-request (display +x-changeproperty+) ((data (member :replace :prepend :append)) mode) (window window) (resource-id property-id type-id) @@ -315,7 +315,7 @@ (property-id (intern-atom display property))) (declare (type display display) (type resource-id property-id)) - (with-buffer-request (display *x-deleteproperty*) + (with-buffer-request (display +x-deleteproperty+) (window window) (resource-id property-id)))) @@ -338,7 +338,7 @@ (type resource-id property-id) (type (or null resource-id) type-id)) (multiple-value-bind (reply-format reply-type bytes-after data) - (with-buffer-request-and-reply (display *x-getproperty* nil :sizes (8 32)) + (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32)) (((data boolean) delete-p) (window window) (resource-id property-id) @@ -358,13 +358,13 @@ (0 nil) ;; (make-sequence result-type 0) ;; Property not found. (8 (sequence-get :result-type result-type :format card8 :length nitems :transform transform - :index *replysize*)) + :index +replysize+)) (16 (sequence-get :result-type result-type :format card16 :length nitems :transform transform - :index *replysize*)) + :index +replysize+)) (32 (sequence-get :result-type result-type :format card32 :length nitems :transform transform - :index *replysize*))))))) + :index +replysize+))))))) (values data (and (plusp reply-type) (atom-name display reply-type)) reply-format @@ -385,7 +385,7 @@ ;; is started to allow InternAtom requests to be made. (dotimes (i length) (setf (aref sequence i) (intern-atom display (elt properties i)))) - (with-buffer-request (display *x-rotateproperties*) + (with-buffer-request (display +x-rotateproperties+) (window window) (card16 length) (int16 (- delta)) @@ -398,11 +398,11 @@ (declare (clx-values (clx-sequence keyword))) (let ((display (window-display window))) (multiple-value-bind (seq) - (with-buffer-request-and-reply (display *x-listproperties* nil :sizes 16) + (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16) ((window window)) (values (sequence-get :result-type result-type :length (card16-get 8) - :index *replysize*))) + :index +replysize+))) ;; lookup the atoms in the sequence (if (listp seq) (do ((elt seq (cdr elt))) @@ -418,7 +418,7 @@ (let ((selection-id (intern-atom display selection))) (declare (type resource-id selection-id)) (multiple-value-bind (window) - (with-buffer-request-and-reply (display *x-getselectionowner* 12 :sizes 32) + (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32) ((resource-id selection-id)) (values (resource-id-or-nil-get 8))) @@ -431,7 +431,7 @@ (type timestamp time)) (let ((selection-id (intern-atom display selection))) (declare (type resource-id selection-id)) - (with-buffer-request (display *x-setselectionowner*) + (with-buffer-request (display +x-setselectionowner+) ((or null window) owner) (resource-id selection-id) ((or null card32) time)) @@ -453,7 +453,7 @@ (declare (type display display) (type resource-id selection-id type-id) (type (or null resource-id) property-id)) - (with-buffer-request (display *x-convertselection*) + (with-buffer-request (display +x-convertselection+) (window requestor) (resource-id selection-id type-id) ((or null resource-id) property-id) @@ -486,7 +486,7 @@ (let ((keyword (getf args arg))) (intern-atom display keyword))) ;; Make the sendevent request - (with-buffer-request (display *x-sendevent*) + (with-buffer-request (display +x-sendevent+) ((data boolean) propagate-p) (length 11) ;; 3 word request + 8 words for event = 11 ((or (member :pointer-window :input-focus) window) window) @@ -506,7 +506,7 @@ (type timestamp time)) (declare (clx-values grab-status)) (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-grabpointer* nil :sizes 8) + (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8) (((data boolean) owner-p) (window window) (card16 (encode-pointer-event-mask event-mask)) @@ -519,7 +519,7 @@ (defun ungrab-pointer (display &key time) (declare (type timestamp time)) - (with-buffer-request (display *x-ungrabpointer*) + (with-buffer-request (display +x-ungrabpointer+) ((or null card32) time))) (defun grab-button (window button event-mask @@ -532,7 +532,7 @@ (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type (or null window) confine-to) (type (or null cursor) cursor)) - (with-buffer-request ((window-display window) *x-grabbutton*) + (with-buffer-request ((window-display window) +x-grabbutton+) ((data boolean) owner-p) (window window) (card16 (encode-pointer-event-mask event-mask)) @@ -547,7 +547,7 @@ (declare (type window window) (type (or (member :any) card8) button) (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) *x-ungrabbutton*) + (with-buffer-request ((window-display window) +x-ungrabbutton+) (data (if (eq button :any) 0 button)) (window window) (card16 (encode-modifier-mask modifiers)))) @@ -557,7 +557,7 @@ (type pointer-event-mask event-mask) (type (or null cursor) cursor) (type timestamp time)) - (with-buffer-request (display *x-changeactivepointergrab*) + (with-buffer-request (display +x-changeactivepointergrab+) ((or null cursor) cursor) ((or null card32) time) (card16 (encode-pointer-event-mask event-mask)))) @@ -568,7 +568,7 @@ (type timestamp time)) (declare (clx-values grab-status)) (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-grabkeyboard* nil :sizes 8) + (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8) (((data boolean) owner-p) (window window) ((or null card32) time) @@ -579,7 +579,7 @@ (defun ungrab-keyboard (display &key time) (declare (type display display) (type timestamp time)) - (with-buffer-request (display *x-ungrabkeyboard*) + (with-buffer-request (display +x-ungrabkeyboard+) ((or null card32) time))) (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) @@ -587,7 +587,7 @@ (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type (or (member :any) card8) key) (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) *x-grabkey*) + (with-buffer-request ((window-display window) +x-grabkey+) ((data boolean) owner-p) (window window) (card16 (encode-modifier-mask modifiers)) @@ -598,7 +598,7 @@ (declare (type window window) (type (or (member :any) card8) key) (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) *x-ungrabkey*) + (with-buffer-request ((window-display window) +x-ungrabkey+) (data (if (eq key :any) 0 key)) (window window) (card16 (encode-modifier-mask modifiers)))) @@ -610,7 +610,7 @@ :async-both :sync-both) mode) (type timestamp time)) - (with-buffer-request (display *x-allowevents*) + (with-buffer-request (display +x-allowevents+) ((data (member :async-pointer :sync-pointer :replay-pointer :async-keyboard :sync-keyboard :replay-keyboard :async-both :sync-both)) @@ -619,10 +619,10 @@ (defun grab-server (display) (declare (type display display)) - (with-buffer-request (display *x-grabserver*))) + (with-buffer-request (display +x-grabserver+))) (defun ungrab-server (display) - (with-buffer-request (display *x-ungrabserver*))) + (with-buffer-request (display +x-ungrabserver+))) (defmacro with-server-grabbed ((display) &body body) ;; The body is not surrounded by a with-display. @@ -639,7 +639,7 @@ (declare (type window window)) (declare (clx-values x y same-screen-p child mask root-x root-y root)) (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-querypointer* 26 :sizes (8 16 32)) + (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32)) ((window window)) (values (int16-get 20) @@ -655,7 +655,7 @@ (declare (type window window)) (declare (clx-values x y same-screen-p)) (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-querypointer* 24 :sizes (8 16)) + (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16)) ((window window)) (values (int16-get 20) @@ -665,7 +665,7 @@ (defun global-pointer-position (display) (declare (type display display)) (declare (clx-values root-x root-y root)) - (with-buffer-request-and-reply (display *x-querypointer* 20 :sizes (16 32)) + (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32)) ((window (screen-root (first (display-roots display))))) (values (int16-get 16) @@ -678,12 +678,12 @@ (type t result-type)) ;; a type specifier (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time)))) (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-getmotionevents* nil :sizes 32) + (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32) ((window window) ((or null card32) start stop)) (values (sequence-get :result-type result-type :length (index* (card32-get 8) 3) - :index *replysize*))))) + :index +replysize+))))) (defun translate-coordinates (src src-x src-y dst) ;; Returns NIL when not on the same screen @@ -692,7 +692,7 @@ (type window dst)) (declare (clx-values dst-x dst-y child)) (let ((display (window-display src))) - (with-buffer-request-and-reply (display *x-translatecoords* 16 :sizes (8 16 32)) + (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32)) ((window src dst) (int16 src-x src-y)) (and (boolean-get 1) @@ -704,7 +704,7 @@ (defun warp-pointer (dst dst-x dst-y) (declare (type window dst) (type int16 dst-x dst-y)) - (with-buffer-request ((window-display dst) *x-warppointer*) + (with-buffer-request ((window-display dst) +x-warppointer+) (resource-id 0) ;; None (window dst) (int16 0 0) @@ -714,7 +714,7 @@ (defun warp-pointer-relative (display x-off y-off) (declare (type display display) (type int16 x-off y-off)) - (with-buffer-request (display *x-warppointer*) + (with-buffer-request (display +x-warppointer+) (resource-id 0) ;; None (resource-id 0) ;; None (int16 0 0) @@ -729,7 +729,7 @@ (type int16 dst-x dst-y src-x src-y) (type (or null card16) src-width src-height)) (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display dst) *x-warppointer*) + (with-buffer-request ((window-display dst) +x-warppointer+) (window src dst) (int16 src-x src-y) (card16 (or src-width 0) (or src-height 0)) @@ -743,7 +743,7 @@ (type int16 x-off y-off src-x src-y) (type (or null card16) src-width src-height)) (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display src) *x-warppointer*) + (with-buffer-request ((window-display src) +x-warppointer+) (window src) (resource-id 0) ;; None (int16 src-x src-y) @@ -755,7 +755,7 @@ (type (or (member :none :pointer-root) window) focus) (type (member :none :pointer-root :parent) revert-to) (type timestamp time)) - (with-buffer-request (display *x-setinputfocus*) + (with-buffer-request (display +x-setinputfocus+) ((data (member :none :pointer-root :parent)) revert-to) ((or window (member :none :pointer-root)) focus) ((or null card32) time))) @@ -763,7 +763,7 @@ (defun input-focus (display) (declare (type display display)) (declare (clx-values focus revert-to)) - (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32)) + (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) () (values (or-get 8 window (member :none :pointer-root)) @@ -773,7 +773,7 @@ (declare (type display display) (type (or null (bit-vector 256)) bit-vector)) (declare (clx-values (bit-vector 256))) - (with-buffer-request-and-reply (display *x-querykeymap* 40 :sizes 8) + (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8) () (values (bit-vector256-get 8 8 bit-vector)))) @@ -793,7 +793,7 @@ (pixmap (or pixmap (make-pixmap :display display))) (pid (allocate-resource-id display pixmap 'pixmap))) (setf (pixmap-id pixmap) pid) - (with-buffer-request (display *x-createpixmap*) + (with-buffer-request (display +x-createpixmap+) (data depth) (resource-id pid) (drawable drawable) @@ -803,7 +803,7 @@ (defun free-pixmap (pixmap) (declare (type pixmap pixmap)) (let ((display (pixmap-display pixmap))) - (with-buffer-request (display *x-freepixmap*) + (with-buffer-request (display +x-freepixmap+) (pixmap pixmap)) (deallocate-resource-id display (pixmap-id pixmap) 'pixmap))) @@ -815,7 +815,7 @@ (type (or null card16) width height) (type generalized-boolean exposures-p)) (unless (or (eql width 0) (eql height 0)) - (with-buffer-request ((window-display window) *x-cleartobackground*) + (with-buffer-request ((window-display window) +x-cleartobackground+) ((data boolean) exposures-p) (window window) (int16 x y) @@ -826,7 +826,7 @@ (type gcontext gcontext) (type int16 src-x src-y dst-x dst-y) (type card16 width height)) - (with-buffer-request ((drawable-display src) *x-copyarea* :gc-force gcontext) + (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext) (drawable src dst) (gcontext gcontext) (int16 src-x src-y dst-x dst-y) @@ -838,7 +838,7 @@ (type pixel plane) (type int16 src-x src-y dst-x dst-y) (type card16 width height)) - (with-buffer-request ((drawable-display src) *x-copyplane* :gc-force gcontext) + (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext) (drawable src dst) (gcontext gcontext) (int16 src-x src-y dst-x dst-y) @@ -856,7 +856,7 @@ (let* ((colormap (make-colormap :display display :visual-info visual-info)) (id (allocate-resource-id display colormap 'colormap))) (setf (colormap-id colormap) id) - (with-buffer-request (display *x-createcolormap*) + (with-buffer-request (display +x-createcolormap+) ((data boolean) alloc-p) (card29 id) (window window) @@ -866,7 +866,7 @@ (defun free-colormap (colormap) (declare (type colormap colormap)) (let ((display (colormap-display colormap))) - (with-buffer-request (display *x-freecolormap*) + (with-buffer-request (display +x-freecolormap+) (colormap colormap)) (deallocate-resource-id display (colormap-id colormap) 'colormap))) @@ -878,19 +878,19 @@ :visual-info (colormap-visual-info colormap))) (id (allocate-resource-id display new-colormap 'colormap))) (setf (colormap-id new-colormap) id) - (with-buffer-request (display *x-copycolormapandfree*) + (with-buffer-request (display +x-copycolormapandfree+) (resource-id id) (colormap colormap)) new-colormap)) (defun install-colormap (colormap) (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) *x-installcolormap*) + (with-buffer-request ((colormap-display colormap) +x-installcolormap+) (colormap colormap))) (defun uninstall-colormap (colormap) (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) *x-uninstallcolormap*) + (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+) (colormap colormap))) (defun installed-colormaps (window &key (result-type 'list)) @@ -900,11 +900,11 @@ (let ((display (window-display window))) (flet ((get-colormap (id) (lookup-colormap display id))) - (with-buffer-request-and-reply (display *x-listinstalledcolormaps* nil :sizes 16) + (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16) ((window window)) (values (sequence-get :result-type result-type :length (card16-get 8) - :transform #'get-colormap :index *replysize*)))))) + :transform #'get-colormap :index +replysize+)))))) (defun alloc-color (colormap color) (declare (type colormap colormap) @@ -913,7 +913,7 @@ (let ((display (colormap-display colormap))) (etypecase color (color - (with-buffer-request-and-reply (display *x-alloccolor* 20 :sizes (16 32)) + (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32)) ((colormap colormap) (rgb-val (color-red color) (color-green color) @@ -928,7 +928,7 @@ (stringable (let* ((string (string color)) (length (length string))) - (with-buffer-request-and-reply (display *x-allocnamedcolor* 24 :sizes (16 32)) + (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32)) ((colormap colormap) (card16 length) (pad16 nil) @@ -949,16 +949,16 @@ (type t result-type)) ;; CL type (declare (clx-values (clx-sequence pixel) (clx-sequence mask))) (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display *x-alloccolorcells* nil :sizes 16) + (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16) (((data boolean) contiguous-p) (colormap colormap) (card16 colors planes)) (let ((pixel-length (card16-get 8)) (mask-length (card16-get 10))) (values - (sequence-get :result-type result-type :length pixel-length :index *replysize*) + (sequence-get :result-type result-type :length pixel-length :index +replysize+) (sequence-get :result-type result-type :length mask-length - :index (index+ *replysize* (index* pixel-length 4)))))))) + :index (index+ +replysize+ (index* pixel-length 4)))))))) (defun alloc-color-planes (colormap colors &key (reds 0) (greens 0) (blues 0) @@ -969,7 +969,7 @@ (type t result-type)) ;; CL type (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)) (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display *x-alloccolorplanes* nil :sizes (16 32)) + (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32)) (((data boolean) contiguous-p) (colormap colormap) (card16 colors reds greens blues)) @@ -977,14 +977,14 @@ (green-mask (card32-get 16)) (blue-mask (card32-get 20))) (values - (sequence-get :result-type result-type :length (card16-get 8) :index *replysize*) + (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+) red-mask green-mask blue-mask))))) (defun free-colors (colormap pixels &optional (plane-mask 0)) (declare (type colormap colormap) (type sequence pixels) ;; Sequence of integers (type pixel plane-mask)) - (with-buffer-request ((colormap-display colormap) *x-freecolors*) + (with-buffer-request ((colormap-display colormap) +x-freecolors+) (colormap colormap) (card32 plane-mask) (sequence pixels))) @@ -1003,7 +1003,7 @@ (when blue-p (incf flags 4)) (etypecase spec (color - (with-buffer-request (display *x-storecolors*) + (with-buffer-request (display +x-storecolors+) (colormap colormap) (card32 pixel) (rgb-val (color-red spec) @@ -1014,7 +1014,7 @@ (stringable (let* ((string (string spec)) (length (length string))) - (with-buffer-request (display *x-storenamedcolor*) + (with-buffer-request (display +x-storenamedcolor+) ((data card8) flags) (colormap colormap) (card32 pixel) @@ -1046,11 +1046,11 @@ (type t result-type)) ;; a type specifier (declare (clx-values (clx-sequence color))) (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display *x-querycolors* nil :sizes (8 16)) + (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16)) ((colormap colormap) (sequence pixels)) (let ((sequence (make-sequence result-type (card16-get 8)))) - (advance-buffer-offset *replysize*) + (advance-buffer-offset +replysize+) (dotimes (i (length sequence) sequence) (setf (elt sequence i) (make-color :red (rgb-val-get 0) @@ -1065,7 +1065,7 @@ (let* ((display (colormap-display colormap)) (string (string name)) (length (length string))) - (with-buffer-request-and-reply (display *x-lookupcolor* 20 :sizes 16) + (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16) ((colormap colormap) (card16 length) (pad16 nil) @@ -1094,7 +1094,7 @@ (cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor))) (setf (cursor-id cursor) cid) - (with-buffer-request (display *x-createcursor*) + (with-buffer-request (display +x-createcursor+) (resource-id cid) (pixmap source) ((or null pixmap) mask) @@ -1127,7 +1127,7 @@ (mask-font-id (if mask-font (font-id mask-font) 0))) (setf (cursor-id cursor) cid) (unless mask-char (setq mask-char 0)) - (with-buffer-request (display *x-createglyphcursor*) + (with-buffer-request (display +x-createglyphcursor+) (resource-id cid source-font-id mask-font-id) (card16 source-char) (card16 mask-char) @@ -1142,14 +1142,14 @@ (defun free-cursor (cursor) (declare (type cursor cursor)) (let ((display (cursor-display cursor))) - (with-buffer-request (display *x-freecursor*) + (with-buffer-request (display +x-freecursor+) (cursor cursor)) (deallocate-resource-id display (cursor-id cursor) 'cursor))) (defun recolor-cursor (cursor foreground background) (declare (type cursor cursor) (type color foreground background)) - (with-buffer-request ((cursor-display cursor) *x-recolorcursor*) + (with-buffer-request ((cursor-display cursor) +x-recolorcursor+) (cursor cursor) (rgb-val (color-red foreground) (color-green foreground) @@ -1168,7 +1168,7 @@ (if (type? drawable 'drawable) (values (drawable-display drawable) drawable) (values drawable (screen-root (display-default-screen drawable)))) - (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16) + (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 0) (window drawable) (card16 width height)) @@ -1181,7 +1181,7 @@ (type drawable drawable)) (declare (clx-values width height)) (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16) + (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 1) (drawable drawable) (card16 width height)) @@ -1194,7 +1194,7 @@ (type drawable drawable)) (declare (clx-values width height)) (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16) + (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 2) (drawable drawable) (card16 width height)) @@ -1207,7 +1207,7 @@ (type stringable name)) (declare (clx-values major-opcode first-event first-error)) (let ((string (string name))) - (with-buffer-request-and-reply (display *x-queryextension* 12 :sizes 8) + (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8) ((card16 (length string)) (pad16 nil) (string string)) @@ -1221,11 +1221,11 @@ (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence string))) - (with-buffer-request-and-reply (display *x-listextensions* size :sizes 8) + (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8) () (values (read-sequence-string - buffer-bbuf (index- size *replysize*) (card8-get 1) result-type *replysize*)))) + buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+)))) (defun change-keyboard-control (display &key key-click-percent bell-percent bell-pitch bell-duration @@ -1240,7 +1240,7 @@ (when (eq bell-percent :default) (setq bell-percent -1)) (when (eq bell-pitch :default) (setq bell-pitch -1)) (when (eq bell-duration :default) (setq bell-duration -1)) - (with-buffer-request (display *x-changekeyboardcontrol* :sizes (32)) + (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32)) (mask (integer key-click-percent bell-percent bell-pitch bell-duration) (card32 led) @@ -1252,7 +1252,7 @@ (declare (type display display)) (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration led-mask global-auto-repeat auto-repeats)) - (with-buffer-request-and-reply (display *x-getkeyboardcontrol* 32 :sizes (8 16 32)) + (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32)) () (values (card8-get 12) @@ -1261,7 +1261,7 @@ (card16-get 16) (card32-get 8) (member8-get 1 :off :on) - (bit-vector256-get 32)))) + (bit-vector256-get 20)))) ;; The base volume should ;; be considered to be the "desired" volume in the normal case; that is, a @@ -1276,24 +1276,24 @@ ;; It is assumed that an eventual audio extension to X will provide more complete control. (declare (type display display) (type int8 percent-from-normal)) - (with-buffer-request (display *x-bell*) + (with-buffer-request (display +x-bell+) (data (int8->card8 percent-from-normal)))) (defun pointer-mapping (display &key (result-type 'list)) (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values sequence)) ;; Sequence of card - (with-buffer-request-and-reply (display *x-getpointermapping* nil :sizes 8) + (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8) () (values (sequence-get :length (card8-get 1) :result-type result-type :format card8 - :index *replysize*)))) + :index +replysize+)))) (defun set-pointer-mapping (display map) ;; Can signal device-busy. (declare (type display display) (type sequence map)) ;; Sequence of card8 - (when (with-buffer-request-and-reply (display *x-setpointermapping* 2 :sizes 8) + (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8) ((data (length map)) ((sequence :format card8) map)) (values @@ -1334,14 +1334,14 @@ (cond ((eq threshold :default) (setq threshold -1)) ((null threshold) (setq threshold -1 threshold-p 0))) - (with-buffer-request (display *x-changepointercontrol*) + (with-buffer-request (display +x-changepointercontrol+) (int16 numerator denominator threshold) (card8 acceleration-p threshold-p))))) (defun pointer-control (display) (declare (type display display)) (declare (clx-values acceleration threshold)) - (with-buffer-request-and-reply (display *x-getpointercontrol* 16 :sizes 16) + (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16) () (values (/ (card16-get 8) (card16-get 10)) ; Should we float this? @@ -1356,7 +1356,7 @@ (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off))) (when (eq timeout :default) (setq timeout -1)) (when (eq interval :default) (setq interval -1)) - (with-buffer-request (display *x-setscreensaver*) + (with-buffer-request (display +x-setscreensaver+) (int16 timeout interval) ((member8 :on :off :default) blanking exposures))) @@ -1364,7 +1364,7 @@ ;; Returns timeout and interval in seconds. (declare (type display display)) (declare (clx-values timeout interval blanking exposures)) - (with-buffer-request-and-reply (display *x-getscreensaver* 14 :sizes (8 16)) + (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16)) () (values (card16-get 8) @@ -1374,12 +1374,12 @@ (defun activate-screen-saver (display) (declare (type display display)) - (with-buffer-request (display *x-forcescreensaver*) + (with-buffer-request (display +x-forcescreensaver+) (data 1))) (defun reset-screen-saver (display) (declare (type display display)) - (with-buffer-request (display *x-forcescreensaver*) + (with-buffer-request (display +x-forcescreensaver+) (data 0))) (defun add-access-host (display host &optional (family :internet)) @@ -1410,7 +1410,7 @@ (setq host (host-address host family))) (let ((family (car host)) (address (cdr host))) - (with-buffer-request (display *x-changehosts*) + (with-buffer-request (display +x-changehosts+) ((data boolean) remove-p) (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family)) (card16 (length address)) @@ -1424,12 +1424,12 @@ (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence host) enabled-p)) - (with-buffer-request-and-reply (display *x-listhosts* nil :sizes (8 16)) + (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16)) () (let* ((enabled-p (boolean-get 1)) (nhosts (card16-get 8)) (sequence (make-sequence result-type nhosts))) - (advance-buffer-offset *replysize*) + (advance-buffer-offset +replysize+) (dotimes (i nhosts) (let ((family (card8-get 0)) (len (card16-get 2))) @@ -1447,14 +1447,14 @@ (defun access-control (display) (declare (type display display)) (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED - (with-buffer-request-and-reply (display *x-listhosts* 2 :sizes 8) + (with-buffer-request-and-reply (display +x-listhosts+ 2 :sizes 8) () (boolean-get 1))) (defun set-access-control (display enabled-p) (declare (type display display) (type generalized-boolean enabled-p)) - (with-buffer-request (display *x-changeaccesscontrol*) + (with-buffer-request (display +x-changeaccesscontrol+) ((data boolean) enabled-p)) enabled-p) @@ -1472,7 +1472,7 @@ (declare (type display display) (type (member :destroy :retain-permanent :retain-temporary) mode)) (setf (display-close-down-mode display) mode) - (with-buffer-request (display *x-changeclosedownmode* :sizes (32)) + (with-buffer-request (display +x-changeclosedownmode+ :sizes (32)) ((data (member :destroy :retain-permanent :retain-temporary)) mode)) mode) @@ -1481,14 +1481,14 @@ (defun kill-client (display resource-id) (declare (type display display) (type resource-id resource-id)) - (with-buffer-request (display *x-killclient*) + (with-buffer-request (display +x-killclient+) (resource-id resource-id))) (defun kill-temporary-clients (display) (declare (type display display)) - (with-buffer-request (display *x-killclient*) + (with-buffer-request (display +x-killclient+) (resource-id 0))) (defun no-operation (display) (declare (type display display)) - (with-buffer-request (display *x-nooperation*))) + (with-buffer-request (display +x-nooperation+))) diff --git a/clx/resource.lisp b/clx/resource.lisp index 2d965d5e8..aaff151dd 100644 --- a/clx/resource.lisp +++ b/clx/resource.lisp @@ -17,9 +17,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/resource.lisp,v 1.10 1999/03/16 23:37:48 pw Exp $") +(ext:file-comment "$Id: resource.lisp,v 1.11 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) @@ -29,6 +29,7 @@ (defstruct (resource-database (:copier nil) (:predicate nil) (:print-function print-resource-database) (:constructor make-resource-database-internal) + #+explorer (:callable-constructors nil) ) (name nil :type stringable :read-only t) (value nil) @@ -110,7 +111,7 @@ (kintern (symbol-name (the symbol stringable))))) (string (if *uppercase-resource-symbols* - (setq stringable (string-upcase + (setq stringable (#-allegro string-upcase #+allegro correct-case (the string stringable)))) (kintern (the string stringable))))) @@ -246,7 +247,7 @@ (defun get-entry-lookup (table name names classes) (declare (type list table names classes) - (type stringable name)) + (symbol name)) (dolist (entry table) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) @@ -264,7 +265,7 @@ (declare (type list tight loose names classes)) (let ((name (car names)) (class (car classes))) - (declare (type stringable name class)) + (declare (type symbol name class)) (cond ((and tight (get-entry-lookup tight name names classes))) ((and loose @@ -353,7 +354,7 @@ (defun get-tables-lookup (dbase name names classes) (declare (type list dbase names classes) - (type stringable name)) + (type symbol name)) (declare (optimize speed)) (dolist (entry dbase) (declare (type resource-database entry)) @@ -379,7 +380,7 @@ (declare (type list tight loose names classes)) (let ((name (car names)) (class (car classes))) - (declare (type stringable name class)) + (declare (type symbol name class)) (when tight (get-tables-lookup tight name names classes)) (when loose @@ -408,14 +409,20 @@ ;; 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) - (dynamic-extent function)) + #+clx-ansi-common-lisp + (dynamic-extent function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg function)) (let ((tight (resource-database-tight database)) (loose (resource-database-loose database))) (declare (type list tight loose)) diff --git a/clx/shape.lisp b/clx/shape.lisp new file mode 100644 index 000000000..7f6d5543b --- /dev/null +++ b/clx/shape.lisp @@ -0,0 +1,195 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- +;;; --------------------------------------------------------------------------- +;;; Title: X11 Shape extension +;;; Created: 1999-05-14 11:31 +;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de> +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1999 by Gilbert Baumann + +;;; +;;; Permission is granted to any individual or institution to use, +;;; copy, modify, and distribute this software, provided that this +;;; complete copyright and permission notice is maintained, intact, in +;;; all copies and supporting documentation. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +;;; + +;;; 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") + +(in-package :xlib) + +(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) + :xlib) + +(define-extension "SHAPE" + :events (:shape-notify)) + +(declare-event :shape-notify + ((data (member8 :bounding :clip)) kind) ;shape kind + (card16 sequence) + (window (window event-window)) ;affected window + (int16 x) ;extents + (int16 y) + (card16 width) + (card16 height) + ((or null card32) time) ;timestamp + (boolean shaped-p)) + +(defun encode-shape-kind (kind) + (ecase kind + (:bounding 0) + (:clip 1))) + +(defun encode-shape-operation (operation) + (ecase operation + (:set 0) + (:union 1) + (:interset 2) + (:subtract 3) + (:invert 4))) + +(defun encode-shape-rectangle-ordering (ordering) + (ecase ordering + ((:unsorted :un-sorted nil) 0) + ((:y-sorted) 1) + ((:yx-sorted) 2) + ((:yx-banded) 3))) + +(defun shape-query-version (display) + (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") + nil :sizes 16) + ((data 0)) + (values + (card16-get 8) + (card16-get 10)))) + +(defun shape-rectangles (window rectangles + &key (kind :bounding) + (x-offset 0) + (y-offset 0) + (operation :set) + (ordering :unsorted)) + (let* ((display (xlib:window-display window))) + (with-buffer-request (display (extension-opcode display "SHAPE")) + (data 1) + (card8 (encode-shape-operation operation)) + (card8 (encode-shape-kind kind)) + (card8 (encode-shape-rectangle-ordering ordering)) + (card8 0) ;unused + (window window) + (int16 x-offset) + (int16 y-offset) + ((sequence :format int16) rectangles)))) + +(defun shape-mask (window pixmap + &key (kind :bounding) + (x-offset 0) + (y-offset 0) + (operation :set)) + (let* ((display (xlib:window-display window))) + (with-buffer-request (display (extension-opcode display "SHAPE")) + (data 2) + (card8 (encode-shape-operation operation)) + (card8 (encode-shape-kind kind)) + (card16 0) ;unused + (window window) + (int16 x-offset) + (int16 y-offset) + ((or pixmap (member :none)) pixmap)))) + +(defun shape-combine (window source-window + &key (kind :bounding) + (source-kind :bounding) + (x-offset 0) + (y-offset 0) + (operation :set)) + (let* ((display (xlib:window-display window))) + (with-buffer-request (display (extension-opcode display "SHAPE")) + (data 3) + (card8 (encode-shape-operation operation)) + (card8 (encode-shape-kind kind)) + (card8 (encode-shape-kind source-kind)) + (card8 0) ;unused + (window window) + (int16 x-offset) + (int16 y-offset) + (window source-window)))) + +(defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0)) + (let* ((display (xlib:window-display window))) + (with-buffer-request (display (extension-opcode display "SHAPE")) + (data 4) + (card8 (encode-shape-kind kind)) + (card8 0) (card8 0) (card8 0) ;unused + (window window) + (int16 x-offset) + (int16 y-offset)))) + +(defun shape-query-extents (window) + (let* ((display (xlib:window-display window))) + (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") + nil :sizes (8 16 32)) + ((data 5) + (window window)) + (values + (boolean-get 8) ;bounding shaped + (boolean-get 9) ;clip shaped + (int16-get 12) ;bounding shape extents x + (int16-get 14) ;bounding shape extents y + (card16-get 16) ;bounding shape extents width + (card16-get 18) ;bounding shape extents height + (int16-get 20) ;clip shape extents x + (int16-get 22) ;clip shape extents y + (card16-get 24) ;clip shape extents width + (card16-get 26))))) ;clip shape extents height + +(defun shape-select-input (window selected-p) + (let* ((display (window-display window))) + (with-buffer-request (display (extension-opcode display "SHAPE")) + (data 6) + (window window) + (boolean selected-p)) )) + +(defun shape-input-selected-p (window) + (let* ((display (window-display window))) + (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") + nil :sizes (8)) + ((data 7) ;also wrong in documentation + (window window)) + (boolean-get 1)))) + +(defun shape-get-rectangles (window &optional (kind :bounding) + (result-type 'list)) + (let* ((display (window-display window))) + (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") + nil :sizes (8 16 32)) + ((data 8) ;this was wrong in the specification + (window window) + (card8 (ecase kind + (:bounding 0) + (:clip 1)))) + (values + (sequence-get :length (print (* 4 (card32-get 8))) + :result-type result-type + :format int16 + :index +replysize+) + (ecase (card8-get 1) + (0 :unsorted) + (1 :y-sorted) + (2 :yx-sorted) + (3 :yx-banded) ))))) diff --git a/clx/sockcl.lisp b/clx/sockcl.lisp new file mode 100644 index 000000000..bd499fc25 --- /dev/null +++ b/clx/sockcl.lisp @@ -0,0 +1,166 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;;;; Server Connection for kcl and ibcl + +;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology +;;; +;;; 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. +;;; +;;; Massachussetts Institute of Technology provides this software "as is" +;;; without express or implied warranty. +;;; + +;;; Adapted from code by Roman Budzianowski - Project Athena/MIT + +;;; make-two-way-stream is probably not a reasonable thing to do. +;;; A close on a two way stream probably does not close the substreams. +;;; I presume an :io will not work (maybe because it uses 1 buffer?). +;;; There should be some fast io (writes and reads...). + +;;; 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.3 2007/08/21 15:49:28 fgilham Exp $") + +(in-package :xlib) + +;;; The cmpinclude.h file does not have this type definition from +;;; <kcldistribution>/h/object.h. We include it here so the +;;; compile-file will work without figuring out where the distribution +;;; directory is located. +;;; +(CLINES " +enum smmode { /* stream mode */ + smm_input, /* input */ + smm_output, /* output */ + smm_io, /* input-output */ + smm_probe, /* probe */ + smm_synonym, /* synonym */ + smm_broadcast, /* broadcast */ + smm_concatenated, /* concatenated */ + smm_two_way, /* two way */ + smm_echo, /* echo */ + smm_string_input, /* string input */ + smm_string_output, /* string output */ + smm_user_defined /* for user defined */ +}; +") + +#-akcl +(CLINES " +struct stream { + short t, m; + FILE *sm_fp; /* file pointer */ + object sm_object0; /* some object */ + object sm_object1; /* some object */ + int sm_int0; /* some int */ + int sm_int1; /* some int */ + short sm_mode; /* stream mode */ + /* of enum smmode */ +}; +") + + +;;;; Connect to the server. + +;;; A lisp string is not a reasonable type for C, so copy the characters +;;; out and then call connect_to_server routine defined in socket.o + +(CLINES " +int +konnect_to_server(host,display) + object host; /* host name */ + int display; /* display number */ +{ + int fd; /* file descriptor */ + int i; + char hname[BUFSIZ]; + FILE *fout, *fin; + + if (host->st.st_fillp > BUFSIZ - 1) + too_long_file_name(host); + for (i = 0; i < host->st.st_fillp; i++) + hname[i] = host->st.st_self[i]; + hname[i] = '\\0'; /* doubled backslash for lisp */ + + fd = connect_to_server(hname,display); + + return(fd); +} +") + +(defentry konnect-to-server (object int) (int "konnect_to_server")) + + +;;;; Make a one-way stream from a file descriptor. + +(CLINES " +object +konnect_stream(host,fd,flag,elem) + object host; /* not really used */ + int fd; /* file descriptor */ + int flag; /* 0 input, 1 output */ + object elem; /* 'string-char */ +{ + struct stream *stream; + char *mode; /* file open mode */ + FILE *fp; /* file pointer */ + enum smmode smm; /* lisp mode (a short) */ + vs_mark; + + switch(flag){ + case 0: + smm = smm_input; + mode = \"r\"; + break; + case 1: + smm = smm_output; + mode = \"w\"; + break; + default: + FEerror(\"konnect_stream : wrong mode\"); + } + + fp = fdopen(fd,mode); + + if (fp == NULL) { + stream = Cnil; + vs_push(stream); + } else { + stream = alloc_object(t_stream); + stream->sm_mode = (short)smm; + stream->sm_fp = fp; + stream->sm_object0 = elem; + stream->sm_object1 = host; + stream->sm_int0 = stream->sm.sm_int1 = 0; + vs_push(stream); + setbuf(fp, alloc_contblock(BUFSIZ)); + } + vs_reset; + return(stream); +} +") + +(defentry konnect-stream (object int int object) (object "konnect_stream")) + + +;;;; Open an X stream + +(defun open-socket-stream (host display) + (when (not (and (typep host 'string) ; sanity check the arguments + (typep display 'fixnum))) + (error "Host ~s or display ~s are bad." host display)) + + (let ((fd (konnect-to-server host display))) ; get a file discriptor + (if (< fd 0) + NIL + (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input + (stream-out (konnect-stream host fd 1 'string-char))) ; output + (if (or (null stream-in) (null stream-out)) + (error "Could not make i/o streams for fd ~d." fd)) + (make-two-way-stream stream-in stream-out)) + ))) diff --git a/clx/socket.c b/clx/socket.c new file mode 100644 index 000000000..3e172c61b --- /dev/null +++ b/clx/socket.c @@ -0,0 +1,155 @@ +/* Copyright Massachusetts Institute of Technology 1988 */ +/* + * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived + * systems. VMS and System V should plan to have their own version. + * + * This code was cribbed from lib/X/XConnDis.c. + * Compile using + * % cc -c socket.c -DUNIXCONN + * + * $Id: socket.c,v 1.4 2007/08/21 15:49:28 fgilham Exp $ + */ + +#include <stdio.h> +#include <X11/Xos.h> +#include <X11/Xproto.h> +#include <errno.h> +#include <netinet/in.h> +#include <sys/ioctl.h> +#include <netdb.h> +#include <sys/socket.h> +#ifndef hpux +#include <netinet/tcp.h> +#endif + +extern int errno; /* Certain (broken) OS's don't have this */ + /* decl in errno.h */ + +#ifdef UNIXCONN +#include <sys/un.h> +#ifndef X_UNIX_PATH +#ifdef hpux +#define X_UNIX_PATH "/usr/spool/sockets/X11/" +#define OLD_UNIX_PATH "/tmp/.X11-unix/X" +#else /* hpux */ +#define X_UNIX_PATH "/tmp/.X11-unix/X" +#endif /* hpux */ +#endif /* X_UNIX_PATH */ +#endif /* UNIXCONN */ + +#ifndef hpux +void bcopy(); +#endif /* hpux */ + +/* + * Attempts to connect to server, given host and display. Returns file + * descriptor (network socket) or 0 if connection fails. + */ + +int connect_to_server (host, display) + char *host; + int display; +{ + struct sockaddr_in inaddr; /* INET socket address. */ + struct sockaddr *addr; /* address to connect to */ + struct hostent *host_ptr; + int addrlen; /* length of address */ +#ifdef UNIXCONN + struct sockaddr_un unaddr; /* UNIX socket address. */ +#endif + extern char *getenv(); + extern struct hostent *gethostbyname(); + int fd; /* Network socket */ + { +#ifdef UNIXCONN + if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { + /* Connect locally using Unix domain. */ + unaddr.sun_family = AF_UNIX; + (void) strcpy(unaddr.sun_path, X_UNIX_PATH); + (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); + addr = (struct sockaddr *) &unaddr; + addrlen = strlen(unaddr.sun_path) + 2; + /* + * Open the network connection. + */ + if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { +#ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ + if (errno == ENOENT) { /* No such file or directory */ + (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); + addrlen = strlen(unaddr.sun_path) + 2; + if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) + return(-1); /* errno set by most recent system call. */ + } else +#endif /* hpux */ + return(-1); /* errno set by system call. */ + } + } else +#endif /* UNIXCONN */ + { + /* Get the statistics on the specified host. */ + if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) + { + if ((host_ptr = gethostbyname(host)) == NULL) + { + /* No such host! */ + errno = EINVAL; + return(-1); + } + /* Check the address type for an internet host. */ + if (host_ptr->h_addrtype != AF_INET) + { + /* Not an Internet host! */ + errno = EPROTOTYPE; + return(-1); + } + /* Set up the socket data. */ + inaddr.sin_family = host_ptr->h_addrtype; +#ifdef hpux + (void) memcpy((char *)&inaddr.sin_addr, + (char *)host_ptr->h_addr, + sizeof(inaddr.sin_addr)); +#else /* hpux */ + (void) bcopy((char *)host_ptr->h_addr, + (char *)&inaddr.sin_addr, + sizeof(inaddr.sin_addr)); +#endif /* hpux */ + } + else + { + inaddr.sin_family = AF_INET; + } + addr = (struct sockaddr *) &inaddr; + addrlen = sizeof (struct sockaddr_in); + inaddr.sin_port = display + X_TCP_PORT; + inaddr.sin_port = htons(inaddr.sin_port); + /* + * Open the network connection. + */ + if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ + return(-1); /* errno set by system call. */} + /* make sure to turn off TCP coalescence */ +#ifdef TCP_NODELAY + { + int mi = 1; + setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); + } +#endif + } + + /* + * Changed 9/89 to retry connection if system call was interrupted. This + * is necessary for multiprocessing implementations that use timers, + * since the timer results in a SIGALRM. -- jdi + */ + while (connect(fd, addr, addrlen) == -1) { + if (errno != EINTR) { + (void) close (fd); + return(-1); /* errno set by system call. */ + } + } + } + /* + * Return the id if the connection succeeded. + */ + return(fd); +} diff --git a/clx/test/README b/clx/test/README new file mode 100644 index 000000000..afcf1dd8f --- /dev/null +++ b/clx/test/README @@ -0,0 +1,9 @@ +$Id: README,v 1.1 2007/08/21 15:49:30 fgilham Rel $ + +Neither of these tests works correctly. + +image.lisp: Draws images on your screen. Doesn't do what it says it will do, but that's +probably because of various assumptions it makes that aren't true. + +trapezoid.lisp: Doesn't compile and wouldn't work if it did because of lack of the extension +that implements the "poly-fill-trapezoids" functions. diff --git a/clx/text.lisp b/clx/text.lisp index 77cc77ca0..6c3aa79bb 100644 --- a/clx/text.lisp +++ b/clx/text.lisp @@ -17,9 +17,9 @@ ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; + #+cmu -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/text.lisp,v 1.7 2003/07/20 15:55:23 emarsden Exp $") +(ext:file-comment "$Id: text.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $") (in-package :xlib) @@ -34,6 +34,8 @@ ;; returned. (deftype translation-function () + #+explorer t + #-explorer '(function (sequence array-index array-index (or null font) vector array-index) (values array-index (or null int16 font) (or null int32)))) @@ -70,30 +72,33 @@ (type vector dst) (inline graphic-char-p)) (declare (clx-values integer (or null integer font) (or null integer))) - font ;;not used - (if (stringp src) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (char)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (if (graphic-char-p (setq char (char src i))) - (setf (aref dst j) (char->card8 char)) - (return i))) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (elt)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (setq elt (elt src i)) - (cond ((and (characterp elt) (graphic-char-p elt)) - (setf (aref dst j) (char->card8 elt))) - ((integerp elt) - (setf (aref dst j) elt)) - (t - (return i)))))) + + (let ((min-char-index (xlib:font-min-char font)) + (max-char-index (xlib:font-max-char font))) + (if (stringp src) + (do ((i src-start (index+ i 1)) + (j dst-start (index+ j 1)) + (char)) + ((index>= i src-end) + i) + (declare (type array-index i j)) + (setf char (char->card8 (char src i))) + (if (or (< char min-char-index) (> char max-char-index)) + (return i) + (setf (aref dst j) char))) + (do ((i src-start (index+ i 1)) + (j dst-start (index+ j 1)) + (elt)) + ((index>= i src-end) + i) + (declare (type array-index i j)) + (setq elt (elt src i)) + (when (characterp elt) (setq elt (char->card8 elt))) + (if (or (not (integerp elt)) + (< elt min-char-index) + (> elt max-char-index)) + (return i) + (setf (aref dst j) elt)))))) ;; There is a question below of whether translate should always be required, or ;; if not, what the default should be or where it should come from. For @@ -111,7 +116,10 @@ (declare (type sequence sequence) (type (or font gcontext) font)) (declare (type (or null translation-function) translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values width ascent descent left right font-ascent font-descent direction (or null array-index))) @@ -138,8 +146,8 @@ (do* ((wbuf (display-tbuf16 display)) (src-end (or end (length sequence))) (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start *buffer-text16-size*)) - (index-min src-end (index+ src-start *buffer-text16-size*))) + (end (index-min src-end (index+ src-start +buffer-text16-size+)) + (index-min src-end (index+ src-start +buffer-text16-size+))) (buf-end 0) (new-font) (font-ascent 0) @@ -215,7 +223,10 @@ (type array-index start) (type (or null array-index) end)) (declare (type (or null translation-function) translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values integer (or null integer))) (when (type? font 'gcontext) (force-gcontext-changes font) @@ -231,8 +242,8 @@ (do* ((wbuf (display-tbuf16 display)) (src-end (or end (length sequence))) (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start *buffer-text16-size*)) - (index-min src-end (index+ src-start *buffer-text16-size*))) + (end (index-min src-end (index+ src-start +buffer-text16-size+)) + (index-min src-end (index+ src-start +buffer-text16-size+))) (buf-end 0) (new-font) (stop-p nil)) @@ -258,9 +269,9 @@ (setq font new-font)))) (values width next-start))) -(defun text-extents-server (font string start end) +(defun text-extents-server (font sequence start end) (declare (type font font) - (type sequence string) + (type sequence sequence) (type array-index start end)) (declare (clx-values width ascent descent left right font-ascent font-descent direction)) (let ((display (font-display font)) @@ -269,12 +280,12 @@ (declare (type display display) (type array-index length) (type resource-id font-id)) - (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes (8 16 32)) + (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32)) (((data boolean) (oddp length)) (length (index+ (index-ceiling length 2) 2)) (resource-id font-id) ((sequence :format char2b :start start :end end :appending t) - string)) + sequence)) (values (integer-get 16) (int16-get 12) @@ -285,9 +296,9 @@ (int16-get 10) (member8-get 1 :left-to-right :right-to-left))))) -(defun text-width-server (font string start end) +(defun text-width-server (font sequence start end) (declare (type (or font gcontext) font) - (type sequence string) + (type sequence sequence) (type array-index start end)) (declare (clx-values integer)) (let ((display (font-display font)) @@ -296,12 +307,12 @@ (declare (type display display) (type array-index length) (type resource-id font-id)) - (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32) + (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32) (((data boolean) (oddp length)) (length (index+ (index-ceiling length 2) 2)) (resource-id font-id) ((sequence :format char2b :start start :end end :appending t) - string)) + sequence)) (values (integer-get 16))))) (defun text-extents-local (font sequence start end width-only-p) @@ -456,11 +467,14 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) - (opcode *x-polytext8*)) + (opcode +x-polytext8+)) (declare (type display display)) (let ((vector (allocate-gcontext-state))) (declare (type gcontext-state vector)) @@ -480,7 +494,7 @@ (when translate-width (setq width translate-width)))) (when result (when (eql size 16) - (setq opcode *x-polytext16*) + (setq opcode +x-polytext16+) (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) (with-buffer-request (display opcode :gc-force gcontext) (drawable drawable) @@ -504,7 +518,10 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values (or null array-index) (or null int32))) (unless end (setq end (length sequence))) (ecase size @@ -525,7 +542,10 @@ (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) @@ -537,7 +557,7 @@ (declare (type array-index src-start src-end length) (type (or null array-index) next-start) (type display display)) - (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length) + (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length) (drawable drawable) (gcontext gcontext) (int16 x y) @@ -625,7 +645,10 @@ (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) @@ -639,7 +662,7 @@ (type (or null array-index) next-start) (type display display) (type buffer-text16 buffer)) - (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length) + (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length) (drawable drawable) (gcontext gcontext) (int16 x y) @@ -725,11 +748,14 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) - (opcode *x-imagetext8*)) + (opcode +x-imagetext8+)) (declare (type display display)) (let ((vector (allocate-gcontext-state))) (declare (type gcontext-state vector)) @@ -749,7 +775,7 @@ (when translate-width (setq width translate-width)))) (when result (when (eql size 16) - (setq opcode *x-imagetext16*) + (setq opcode +x-imagetext16+) (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) (with-buffer-request (display opcode :gc-force gcontext) (drawable drawable) @@ -778,7 +804,10 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values (or null array-index) (or null int32))) (setf end (index-min (index+ start 255) (or end (length sequence)))) (ecase size @@ -803,7 +832,10 @@ (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) @@ -819,7 +851,7 @@ (when font-change (setf (gcontext-font gcontext) font)) (block change-font - (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length) + (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length) (drawable drawable) (gcontext gcontext) (int16 x y) @@ -866,7 +898,10 @@ (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) - (dynamic-extent translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) @@ -885,7 +920,7 @@ (setf (gcontext-font gcontext) font)) (block change-font - (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length) + (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length) (drawable drawable) (gcontext gcontext) (int16 x y) @@ -955,7 +990,7 @@ (replace data mod3 :start1 (index* 5 keycodes-per-modifier)) (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) - (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8) + (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8) ((data keycodes-per-modifier) ((sequence :format card8) data)) (values (member8-get 1 :success :busy :failed))))) @@ -965,10 +1000,10 @@ (declare (type display display)) (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)) (let ((lists nil)) - (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8) + (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8) () (do* ((keycodes-per-modifier (card8-get 1)) - (advance-by *replysize* keycodes-per-modifier) + (advance-by +replysize+ keycodes-per-modifier) (keys nil nil) (i 0 (index+ i 1))) ((index= i 8)) @@ -998,7 +1033,7 @@ (size (index* length keysyms-per-keycode)) (request-length (index+ size 2))) (declare (type array-index keycode-end keysyms-per-keycode length request-length)) - (with-buffer-request (display *x-setkeyboardmapping* + (with-buffer-request (display +x-setkeyboardmapping+ :length (index-ash request-length 2) :sizes (32)) (data length) @@ -1033,11 +1068,11 @@ (unless first-keycode (setq first-keycode (display-min-keycode display))) (unless start (setq start first-keycode)) (unless end (setq end (1+ (display-max-keycode display)))) - (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32)) + (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32)) ((card8 first-keycode (index- end start))) (do* ((keysyms-per-keycode (card8-get 1)) (bytes-per-keycode (* keysyms-per-keycode 4)) - (advance-by *replysize* bytes-per-keycode) + (advance-by +replysize+ bytes-per-keycode) (keycode-count (floor (card32-get 4) keysyms-per-keycode) (index- keycode-count 1)) (result (if (and (arrayp data) diff --git a/clx/translate.lisp b/clx/translate.lisp index e20ee51de..01506f5be 100644 --- a/clx/translate.lisp +++ b/clx/translate.lisp @@ -16,6 +16,9 @@ ;;; express or implied warranty. ;;; +#+cmu +(ext:file-comment "$Id: translate.lisp,v 1.5 2007/08/21 15:49:28 fgilham Exp $") + (in-package :xlib) (defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym) @@ -48,26 +51,30 @@ (when (<= first keysym last) (return (first set)))))) -(eval-when (compile eval load) ;; Required for Vaxlisp ... -(defmacro keysym (keysym &rest bytes) - ;; Build a keysym. - ;; If KEYSYM is an integer, it is used as the most significant bits of - ;; the keysym, and BYTES are used to specify low order bytes. The last - ;; parameter is always byte4 of the keysym. If KEYSYM is not an - ;; integer, the keysym associated with KEYSYM is returned. - ;; - ;; This is a macro and not a function macro to promote compile-time - ;; lookup. All arguments are evaluated. - (declare (type t keysym) - (type list bytes) - (clx-values keysym)) - (typecase keysym - ((integer 0 *) - (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) - (otherwise - (or (car (character->keysyms keysym)) - (error "~s Isn't the name of a keysym" keysym))))) -) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro keysym (keysym &rest bytes) + ;; Build a keysym. + ;; + ;; If KEYSYM is an integer, it is used as the most significant + ;; bits of the keysym, and BYTES are used to specify low order + ;; bytes. The last parameter is always byte4 of the keysym. If + ;; KEYSYM is not an integer, the keysym associated with KEYSYM is + ;; returned. + ;; + ;; This is a macro and not a function macro to promote + ;; compile-time lookup. All arguments are evaluated. + ;; + ;; FIXME: The above means that this shouldn't really be a macro at + ;; all, but a compiler macro. Probably, anyway. + (declare (type t keysym) + (type list bytes) + (clx-values keysym)) + (typecase keysym + ((integer 0 *) + (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) + (otherwise + (or (car (character->keysyms keysym)) + (error "~s Isn't the name of a keysym" keysym)))))) (defvar *keysym->character-map* (make-hash-table :test (keysym->character-map-test) :size 400)) @@ -157,7 +164,7 @@ (mask-check (mask) (unless (or (numberp mask) (dolist (element mask t) - (unless (or (find element *state-mask-vector*) + (unless (or (find element +state-mask-vector+) (gethash element *keysym->character-map*)) (return nil)))) (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym))))))) @@ -245,23 +252,22 @@ *keysym->character-map*) result)) -(eval-when (compile eval load) ;; Required for Symbolics... -(defconstant character-set-switch-keysym (keysym 255 126)) -(defconstant left-shift-keysym (keysym 255 225)) -(defconstant right-shift-keysym (keysym 255 226)) -(defconstant left-control-keysym (keysym 255 227)) -(defconstant right-control-keysym (keysym 255 228)) -(defconstant caps-lock-keysym (keysym 255 229)) -(defconstant shift-lock-keysym (keysym 255 230)) -(defconstant left-meta-keysym (keysym 255 231)) -(defconstant right-meta-keysym (keysym 255 232)) -(defconstant left-alt-keysym (keysym 255 233)) -(defconstant right-alt-keysym (keysym 255 234)) -(defconstant left-super-keysym (keysym 255 235)) -(defconstant right-super-keysym (keysym 255 236)) -(defconstant left-hyper-keysym (keysym 255 237)) -(defconstant right-hyper-keysym (keysym 255 238)) -) ;; end eval-when +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant character-set-switch-keysym (keysym 255 126)) + (defconstant left-shift-keysym (keysym 255 225)) + (defconstant right-shift-keysym (keysym 255 226)) + (defconstant left-control-keysym (keysym 255 227)) + (defconstant right-control-keysym (keysym 255 228)) + (defconstant caps-lock-keysym (keysym 255 229)) + (defconstant shift-lock-keysym (keysym 255 230)) + (defconstant left-meta-keysym (keysym 255 231)) + (defconstant right-meta-keysym (keysym 255 232)) + (defconstant left-alt-keysym (keysym 255 233)) + (defconstant right-alt-keysym (keysym 255 234)) + (defconstant left-super-keysym (keysym 255 235)) + (defconstant right-super-keysym (keysym 255 236)) + (defconstant left-hyper-keysym (keysym 255 237)) + (defconstant right-hyper-keysym (keysym 255 238))) ;;----------------------------------------------------------------------------- @@ -333,7 +339,7 @@ modifiers (dolist (modifier modifiers mask) (declare (type symbol modifier)) - (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq))) + (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq))) (setq mask (logior mask (if bit @@ -362,7 +368,7 @@ ;; Returns a keysym-index for use with keycode->character (declare (clx-values card8)) (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword *state-mask-vector*) ,state))) + `(logbitp ,(position keyword +state-mask-vector+) ,state))) (let* ((mapping (display-keyboard-mapping display)) (keysyms-per-keycode (array-dimension mapping 1)) (symbolp (and (> keysyms-per-keycode 2) @@ -388,7 +394,7 @@ ;;; as neither if the character is alphabetic. (declare (clx-values generalized-boolean)) (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword *state-mask-vector*) ,state))) + `(logbitp ,(position keyword +state-mask-vector+) ,state))) (let* ((controlp (or (keystate-p state :control) (dolist (modifier control-modifiers) (when (state-keysymp display state modifier) diff --git a/clx/xrender.lisp b/clx/xrender.lisp new file mode 100644 index 000000000..e3bb1894b --- /dev/null +++ b/clx/xrender.lisp @@ -0,0 +1,1131 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- +;;; --------------------------------------------------------------------------- +;;; 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.1 2007/08/21 15:49:28 fgilham Exp $") +;;; --------------------------------------------------------------------------- +;;; +;;; (c) copyright 2002, 2003 by Gilbert Baumann +;;; (c) copyright 2002 by Christian Sunesson +;;; +;;; Permission is granted to any individual or institution to use, +;;; copy, modify, and distribute this software, provided that this +;;; complete copyright and permission notice is maintained, intact, in +;;; all copies and supporting documentation. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +;;; + +;;; NOTE: we need to watch maximum request sizes and somehow work +;;; around them. Sometimes e.g. in AddGlyphs this is not possible, +;;; which is a design failure. + +;;; TODO + +;; - some request are still to be implemented at all. +;; + Can they not wait? Xrender seems to be in flux as the specification +;; isn't even conforming to the actual protocol. However backwards +;; wierd that sounds. --noss + +;; - we need to invent something for the color values of e.g. +;; fill-rectangles; I would prefer some generic functions, so that +;; we later can map CLIM design directly to colors. + +;; - we want some convenience function to turn graphics contexts into +;; render pictures. --GB 2002-08-21 + +;; - also: uniform-alpha-picture display alpha-value +;; uniform-color-picture display red green blue +;; --GB 2002-08-21 + +;; - maybe we should aim for a higher level interface to +;; color-trapzoids and color-triangles and offer a low level [raw] +;; interface also for high performance apps? + +;; - Write tests. + +;;;; API issues + +;; - On one hand we want convenience functions like RENDER-TRIANGLE or +;; WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to +;; write a full rasterization library you obviously want high +;; performance entry points as RENDER-TRIANGLES-1. + +;; - We want to extend XLIB:COLOR into something with alpha channel. +;; How to name it? + +;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body +;; +;; Example: +;; (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0) +;; (RENDER-TRIANGLE dest color ...)) + +;; - Pose the filter and the transform slots of a picture. + +;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT? + +;; - COPY-PICTURE? + +;; - WITH-PICTURE-OPTIONS ? +;; +;; (WITH-PICTURE-OPTIONS (pic :repeat :on) ...) + +;; - WITH-PICTURE ? +;; +;; (WITH-PICTURE (picture drawable ...) ...) + +;; + +(in-package :xlib) + +;; Beginning to collect the external interface for documentation. +(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 + )) + +(pushnew :clx-ext-render *features*) + +(define-extension "RENDER") + +;;;; Request constants + +;; Note: Although version numbers are given render.h where the request +;; numbers are defined, render-query-version returns 0.0 all displays +;; i tested. --GB 2004-07-21 + +(defconstant +X-RenderQueryVersion+ 0) ;done +(defconstant +X-RenderQueryPictFormats+ 1) +(defconstant +X-RenderQueryPictIndexValues+ 2) ;0.7 +(defconstant +X-RenderQueryDithers+ 3) +(defconstant +X-RenderCreatePicture+ 4) ;done +(defconstant +X-RenderChangePicture+ 5) ;done +(defconstant +X-RenderSetPictureClipRectangles+ 6) ;done +(defconstant +X-RenderFreePicture+ 7) ;done +(defconstant +X-RenderComposite+ 8) ;we need better arglist +(defconstant +X-RenderScale+ 9) +(defconstant +X-RenderTrapezoids+ 10) ;low-level done +(defconstant +X-RenderTriangles+ 11) ;low-level done +(defconstant +X-RenderTriStrip+ 12) +(defconstant +X-RenderTriFan+ 13) +(defconstant +X-RenderColorTrapezoids+ 14) ;nyi in X server, not mentioned in renderproto.h +(defconstant +X-RenderColorTriangles+ 15) ;nyi in X server, not mentioned in renderproto.h +(defconstant +X-RenderTransform+ 16) ;commented out in render.h +(defconstant +X-RenderCreateGlyphSet+ 17) ;done +(defconstant +X-RenderReferenceGlyphSet+ 18) ;done +(defconstant +X-RenderFreeGlyphSet+ 19) ;done +(defconstant +X-RenderAddGlyphs+ 20) ;done, untested +(defconstant +X-RenderAddGlyphsFromPicture+ 21) ;done, untested +(defconstant +X-RenderFreeGlyphs+ 22) ;done, untested +(defconstant +X-RenderCompositeGlyphs8+ 23) ;done +(defconstant +X-RenderCompositeGlyphs16+ 24) ;done +(defconstant +X-RenderCompositeGlyphs32+ 25) ;done + +;; >= 0.1 + +(defconstant +X-RenderFillRectangles+ 26) ;single rectangle version done + +;; >= 0.5 + +(defconstant +X-RenderCreateCursor+ 27) + +;; >= 0.6 + +(defconstant +X-RenderSetPictureTransform+ 28) ;I don't understand what this one should do. +(defconstant +X-RenderQueryFilters+ 29) ;seems to be there on server side + ; some guts of its implementation there. +(defconstant +X-RenderSetPictureFilter+ 30) +(defconstant +X-RenderCreateAnimCursor+ 31) ;What has render to do with cursors? + +;;;; + +;; Sanity measures: + +;; We do away with the distinction between pict-format and +;; picture-format-info. That is we cache picture-format-infos. + +(defstruct render-info + major-version + minor-version + picture-formats) + +(defun display-render-info (display) + (getf (xlib:display-plist display) 'render-info)) + +(defun (setf display-render-info) (new-value display) + (setf (getf (xlib:display-plist display) 'render-info) + new-value)) + +(defun ensure-render-initialized (display) + "Ensures that the RENDER extension is initialized. Should be called +by every function that attempts to generate RENDER requests." + ;; xxx locking? + (unless (display-render-info display) + (let ((q (make-render-info))) + (multiple-value-bind (maj min) (render-query-version display) + (setf (render-info-major-version q) maj + (render-info-minor-version q) min) + (setf (render-info-picture-formats q) + (make-hash-table :test #'eql)) + (dolist (pf (render-query-picture-formats display)) + (setf (gethash (picture-format-id pf) (render-info-picture-formats q)) + pf)) + (setf (display-render-info display) q))))) + +(defun find-matching-picture-formats + (display + &key depth-min depth-max depth + red-min red-max red + green-min green-max green + blue-min blue-max blue + alpha-min alpha-max alpha + type + colormap) + ;; + (ensure-render-initialized display) + (let ((res nil)) + (maphash (lambda (k f) + (declare (ignore k)) + (when (and + (or (null type) (eql (picture-format-type f) type)) + (or (null colormap) (eql (picture-format-colormap f) colormap)) + ;; min + (or (null depth-min) (>= (picture-format-depth f) depth-min)) + (or (null red-min) (>= (byte-size (picture-format-red-byte f)) red-min)) + (or (null green-min) (>= (byte-size (picture-format-green-byte f)) green-min)) + (or (null blue-min) (>= (byte-size (picture-format-blue-byte f)) blue-min)) + (or (null alpha-min) (>= (byte-size (picture-format-alpha-byte f)) alpha-min)) + ;; max + (or (null depth-max) (<= (picture-format-depth f) depth-max)) + (or (null red-max) (<= (byte-size (picture-format-red-byte f)) red-max)) + (or (null green-max) (<= (byte-size (picture-format-green-byte f)) green-max)) + (or (null blue-max) (<= (byte-size (picture-format-blue-byte f)) blue-max)) + (or (null alpha-max) (<= (byte-size (picture-format-alpha-byte f)) alpha-max)) + ;; match + (or (null depth) (= (picture-format-depth f) depth)) + (or (null red) (= (byte-size (picture-format-red-byte f)) red)) + (or (null green) (= (byte-size (picture-format-green-byte f)) green)) + (or (null blue) (= (byte-size (picture-format-blue-byte f)) blue)) + (or (null alpha) (= (byte-size (picture-format-alpha-byte f)) alpha))) + (pushnew f res))) + (render-info-picture-formats + (display-render-info display))) + res)) + +(defun find-window-picture-format (window) + "Find the picture format that matches the given window." + (let* ((cm (window-colormap window)) + (vi (colormap-visual-info cm)) + (display (window-display window))) + (ensure-render-initialized display) + (case (visual-info-class vi) + ((:true-color) + (maphash (lambda (k f) + (declare (ignore k)) + (when (and (eql (picture-format-type f) :direct) + (eql (picture-format-depth f) (drawable-depth window)) + (eql (dpb -1 (picture-format-red-byte f) 0) + (visual-info-red-mask vi)) + (eql (dpb -1 (picture-format-green-byte f) 0) + (visual-info-green-mask vi)) + (eql (dpb -1 (picture-format-blue-byte f) 0) + (visual-info-blue-mask vi)) + (eql (byte-size (picture-format-alpha-byte f)) 0)) + (return-from find-window-picture-format f))) + (render-info-picture-formats + (display-render-info display)))) + (t + )))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-accessor picture (32) + ((index) index :blip) + ((index thing) `(resource-id-put ,index (picture-id ,thing)))) + (define-accessor glyph-set (32) + ((index) index :blip) + ((index thing) `(resource-id-put ,index (glyph-set-id ,thing))))) + +;;; 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) + ;; build an abbreviated representation of the format + (let ((bytes (sort (list (cons "r" (picture-format-red-byte object)) + (cons "g" (picture-format-green-byte object)) + (cons "b" (picture-format-blue-byte object)) + (cons "a" (picture-format-alpha-byte object))) + #'> + :key #'(lambda (x) (byte-position (cdr x)))))) + (dolist (k bytes) + (unless (zerop (byte-size (cdr k))) + (format bag " ~A~D" (car k) (byte-size (cdr k))))))))) + (print-unreadable-object (object stream :type t :identity nil) + (format stream "~D ~S ~S ~S~A" + (picture-format-id object) + (picture-format-colormap object) + (picture-format-depth object) + (picture-format-type object) abbrev)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-accessor picture-format (32) + ((index) `(gethash (read-card32 ,index) + (render-info-picture-formats (display-render-info .display.)))) + ((index thing) `(write-card32 ,index (picture-format-id ,thing)))) + (define-accessor render-op (8) + ((index) `(member8-get ,index + :clear :src :dst :over :over-reverse :in :in-reverse + :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum)) + ((index thing) `(member8-put ,index ,thing + :clear :src :dst :over :over-reverse :in :in-reverse + :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum))) + (deftype render-op () + '(member :clear :src :dst :over :over-reverse :in :in-reverse + :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum))) + +;; Now these pictures objects are like graphics contexts. I was about +;; to introduce a synchronous mode, realizing that the RENDER protocol +;; provides no provision to actually query a picture object's values. +;; *sigh* + +(def-clx-class (picture (:copier nil)) + (id 0 :type resource-id) + (display nil :type (or null display)) + (plist nil :type list) ; Extension hook + (format) + (%changed-p) + (%server-values) + (%values) + (%drawable)) + +(defun picture-drawable (picture) + (picture-%drawable picture)) + +;; xx make id, display, format readonly + +(defun %render-change-picture-clip-rectangles (picture rectangles) + "Dont call me, use (SETF PICTURE-CLIP-MASK) instead." + (declare (optimize (speed 0))) + (let ((display (picture-display picture))) + (ensure-render-initialized display) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderSetPictureClipRectangles+) + (picture picture) + (int16 (picture-clip-x-origin picture)) + (int16 (picture-clip-y-origin picture)) + ((sequence :format int16) rectangles)))) + +(macrolet ((foo (&rest specs) + `(progn + ,@(loop for (type slot default) in specs + for index from 0 + collect + `(progn + (defun ,(xintern 'picture- slot) (picture) + (aref (picture-%values picture) ,index)) + (defun (setf ,(xintern 'picture- slot)) (new-value picture) + (setf (picture-%changed-p picture) t) + (setf (aref (picture-%values picture) ,index) new-value)))) + + (defun synchronise-picture-state (picture) + (when (picture-%changed-p picture) + (let ((display (picture-display picture))) + (ensure-render-initialized display) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderChangePicture+) + (picture picture) + (mask + ,@(loop for (type slot default) in specs + for index from 0 + collect + `(,type (and + ,(cond ((eql slot 'clip-mask) + `(not (typep (aref (picture-%values picture) ,index) + 'sequence))) + (t + 't)) + (not (eq (aref (picture-%values picture) ,index) + (aref (picture-%server-values picture) ,index))) + (setf (aref (picture-%server-values picture) ,index) + (aref (picture-%values picture) ,index)))))))) + ,(let ((index (position 'clip-mask specs :key #'second))) + `(unless (eql (aref (picture-%values picture) ,index) + (aref (picture-%server-values picture) + ,index)) + (%render-change-picture-clip-rectangles + picture (aref (picture-%values picture) ,index)) + (setf (aref (picture-%values picture) ,index) + (aref (picture-%server-values picture) + ,index)))) + (setf (picture-%changed-p picture) nil))) + + (defun render-create-picture + (drawable + &key format + (picture (make-picture :display (drawable-display drawable))) + ,@(loop for (type slot default-value) in specs + collect (cond ((eql slot 'clip-mask) + `(clip-mask :none)) + (t + slot))) + ) + ;; xxx also offer to give a colormap instead of a picture-format + ;; values! + (let ((display (drawable-display drawable))) + (ensure-render-initialized display) + (unless format + ;; xxx check for drawable being a window + (setf format (find-window-picture-format drawable))) + (let ((pid (allocate-resource-id display picture 'picture))) + (setf (picture-id picture) pid) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderCreatePicture+) + (resource-id pid) + (drawable drawable) + (picture-format format) + (mask + ,@(loop for (type slot default) in specs + collect + (cond ((eql slot 'clip-mask) + (list type `(and + (not (typep clip-mask 'sequence)) + clip-mask))) + (t + (list type slot))))))) + (when (typep clip-mask 'sequence) + (%render-change-picture-clip-rectangles picture clip-mask)) + (setf (picture-format picture) format) + (setf (picture-%server-values picture) + (vector ,@(loop for (type slot default) in specs + collect + `(or ,slot ,default)))) + (setf (picture-%values picture) (copy-seq (picture-%server-values picture))) + (setf (picture-%drawable picture) drawable) + picture)) + + (defconstant +picture-state-length+ + ,(length specs)) ))) + + (foo ((member :off :on) repeat :off) + ((or (member :none) picture) alpha-map :none) + (int16 alpha-x-origin 0) + (int16 alpha-y-origin 0) + (int16 clip-x-origin 0) + (int16 clip-y-origin 0) + ;; ### Now that is not correct is it?: + ((or (member :none) pixmap) clip-mask :none) + ((member :off :on) graphics-exposures :on) + ((member :clip-by-children :include-inferiors) subwindow-mode :clip-by-children) + ((member :sharp :smooth) poly-edge :smooth) + ((member :precise :imprecise) poly-mode :precise) + ((or (member :none) #||xatom||#) dither :none) + ((member :off :on) component-alpha :off))) + +(defun render-free-picture (picture) + (let ((display (picture-display picture))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderFreePicture+) + (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)))) + +(defun render-query-version (display) + (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) + ((data +X-RenderQueryVersion+) + (card32 0) + (card32 1)) + (values + (card32-get 8) + (card32-get 12) ))) + +(defun render-query-picture-formats (display) + (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) + ((data +X-RenderQueryPictFormats+)) + (let ((n-picture-formats (card32-get 8)) + (n-screens (card32-get 12)) + (n-depths (card32-get 16)) + (n-visuals (card32-get 20)) + (n-subpixel (card32-get 24))) + (declare (ignore n-screens n-depths n-visuals n-subpixel)) + (loop for i below n-picture-formats + collect + (let ((off (+ (* 8 4) + (* i 28)))) ;size of picture-format-info + (make-picture-format + :display display + :id (card32-get (+ off 0)) + :type (member8-get (+ off 4) :indexed :direct) + :depth (card8-get (+ off 5)) + :red-byte (byte (integer-length (card16-get (+ off 10))) + (card16-get (+ off 8))) + :green-byte (byte (integer-length (card16-get (+ off 14))) + (card16-get (+ off 12))) + :blue-byte (byte (integer-length (card16-get (+ off 18))) + (card16-get (+ off 16))) + :alpha-byte (byte (integer-length (card16-get (+ off 22))) + (card16-get (+ off 20))) + :colormap (let ((cmid (card32-get (+ off 24)))) + (unless (zerop cmid) + (lookup-colormap display cmid))))))))) + +(defun render-fill-rectangle (picture op color x1 y1 w h) + (let ((display (picture-display picture))) + (ensure-render-initialized display) + (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 + (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) + ;; 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. + (macrolet ((guts () + '(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) )))) + (typecase coord-sequence + ((simple-array (unsigned-byte 32) (*)) + (locally + (declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence)) + (guts))) + (t + (guts))))) + +#|| +(defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1)) + ...) +||# + +(defun render-set-picture-transform (picture a b c d e f p q r) + (let ((display (picture-display picture))) + (ensure-render-initialized display) + (synchronise-picture-state picture) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderSetPictureTransform+) + #| + (card8 0) ;; render-op op) ;op + (card8 0) ;pad + (card16 0) ;pad + |# + (resource-id (picture-id picture)) + + (card32 a) + (card32 b) + (card32 c) + + (card32 d) + (card32 e) + (card32 f) + + (card32 p) + (card32 q) + (card32 r)))) + +(defun render-query-filters (drawable) + (let ((display (drawable-display drawable))) + (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) + ((data +X-RenderQueryFilters+) + (drawable drawable)) + (let* ((len (card32-get 4)) + (n-aliases (card32-get 8)) + (n-filters (card32-get 12)) + (off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4))))) + (print (list :aliases + (loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2)))))) + (print (list :foo len n-aliases n-filters + (loop for i below len + collect (card8-get (+ off 0 (* 4 i))) + collect (card8-get (+ off 1 (* 4 i))) + collect (card8-get (+ off 2 (* 4 i))) + collect (card8-get (+ off 3 (* 4 i)))))) + (print + (labels ((grab-string (j) + (let ((n (card8-get j))) + (incf j) + (values + (map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j))) + j)))) + (loop repeat n-filters collect + (multiple-value-bind (s j) (grab-string off) + (setf off j) + (intern (string-upcase s) :keyword))))) + #+NIL + (loop for i below n-picture-formats + collect + (let ((off (+ (* 8 4) + (* i 28)))) ;size of picture-format-info + (make-picture-format + :display display + :id (card32-get (+ off 0)) + :type (member8-get (+ off 4) :indexed :direct) + :depth (card8-get (+ off 5)) + :red-byte (byte (integer-length (card16-get (+ off 10))) + (card16-get (+ off 8))) + :green-byte (byte (integer-length (card16-get (+ off 14))) + (card16-get (+ off 12))) + :blue-byte (byte (integer-length (card16-get (+ off 18))) + (card16-get (+ off 16))) + :alpha-byte (byte (integer-length (card16-get (+ off 22))) + (card16-get (+ off 20))) + :colormap (let ((cmid (card32-get (+ off 24)))) + (unless (zerop cmid) + (lookup-colormap display cmid)))))))))) + +(defun render-set-filter (picture filter) + (let ((display (picture-display picture))) + (ensure-render-initialized display) + (synchronise-picture-state picture) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderSetPictureFilter+) + (resource-id (picture-id picture)) + (card16 (length filter)) + (card16 0) ;pad + ((sequence :format card8) (map 'vector #'char-code filter))))) + + + +#|| +(defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over)) + (render-triangles-1 destination op source ...) + ) +||# + +(defun render-trapezoids-1 (picture op source src-x src-y 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 ... + ;; + (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)) + (picture-format format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32) coord-sequence) ))) + +(defun render-composite (op + source mask dest + src-x src-y mask-x mask-y dst-x dst-y + width height) + (let ((display (picture-display source))) + (synchronise-picture-state source) + (when mask (synchronise-picture-state mask)) + (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 + (resource-id (picture-id source)) + (resource-id (if mask (picture-id mask) 0)) + (resource-id (picture-id dest)) + (int16 src-x) + (int16 src-y) + (int16 mask-x) + (int16 mask-y) + (int16 dst-x) + (int16 dst-y) + (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))) + (gsid (setf (glyph-set-id glyph-set) + (allocate-resource-id display glyph-set 'glyph-set)))) + (declare (ignore gsid)) + (setf (glyph-set-format glyph-set) format) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderCreateGlyphSet+) + (glyph-set glyph-set) + (picture-format format)) + glyph-set))) + +(defun render-reference-glyph-set (existing-glyph-set &key glyph-set) + (let ((display (glyph-set-display existing-glyph-set))) + (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) + (gsid (setf (glyph-set-id glyph-set) + (allocate-resource-id display glyph-set 'glyph-set)))) + (declare (ignore gsid)) + (setf (glyph-set-format glyph-set) + (glyph-set-format existing-glyph-set)) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderReferenceGlyphSet+) + (glyph-set glyph-set) + (glyph-set existing-glyph-set)) + glyph-set))) + +(defun render-composite-glyphs-8 (dest glyph-set source dest-x dest-y sequence + &key (op :over) + (alu op) ;for the fun of it + (src-x 0) + (src-y 0) + (mask-format :none) + (start 0) + (end (length sequence))) + (let ((display (picture-display dest))) + (ensure-render-initialized display) + (synchronise-picture-state dest) + (synchronise-picture-state source) + (when (stringp sequence) + ;; lazy me, but then you should not confuse glyphs with + ;; characters anyway. + (setf sequence (map 'vector #'char-code sequence))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderCompositeGlyphs8+) + (render-op alu) + (card8 0) (card16 0) ;padding + (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 + (int16 dest-x) (int16 dest-y) ;dx, dy + ((sequence :format card8) sequence)))) + +(defmacro %render-composite-glyphs + (opcode type transform display dest glyph-set source dest-x dest-y sequence + alu src-x src-y mask-format start end) + (let ((size (ecase type (card8 1) (card16 2) (card32 4))) + ;; FIXME: the last chunk for CARD8 can be 254. + (chunksize (ecase type (card8 252) (card16 254) (card32 254)))) + `(multiple-value-bind (nchunks leftover) + (floor (- end start) ,chunksize) + (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size))) + (if (> leftover 0) + (+ 8 (* 4 (ceiling (* leftover ,size) 4))) + 0))) + (request-length (+ 7 (/ payloadsize 4)))) + (declare (integer request-length)) + (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length)) + (data ,opcode) + (length request-length) + (render-op ,alu) + (card8 0) (card16 0) ;padding + (picture ,source) + (picture ,dest) + ((or (member :none) picture-format) ,mask-format) + (glyph-set ,glyph-set) + (int16 ,src-x) (int16 ,src-y) + (progn + (let ((boffset (+ buffer-boffset 28)) + (start ,start) + (end ,end) + (dest-x ,dest-x) + (dest-y ,dest-y)) + (dotimes (i nchunks) + (set-buffer-offset boffset) + (put-items (0) + (card8 ,chunksize) + (card8 0) + (card16 0) + (int16 dest-x) + (int16 dest-y) + ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence)) + (setq dest-x 0 dest-y 0) + (incf boffset (+ 8 (* ,chunksize ,size))) + (incf start ,chunksize)) + (when (> leftover 0) + (set-buffer-offset boffset) + (put-items (0) + (card8 leftover) + (card8 0) + (card16 0) + (int16 dest-x) + (int16 dest-y) + ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence)) + ;; padding? + (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4))))) + (setf (buffer-boffset ,display) boffset)))))))) + +(defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence + &key (op :over) + (alu op) ;for the fun of it + (src-x 0) + (src-y 0) + (mask-format :none) + (start 0) + (end (length sequence))) + ;; xxx do we want to go with some translate function as draw-glyphs? + (declare (type array-index start end)) + (let ((display (picture-display dest))) + (ensure-render-initialized display) + (synchronise-picture-state dest) + (synchronise-picture-state source) + ;; hmm find out the element size + (typecase sequence + ((array (unsigned-byte 8) (*)) + (%render-composite-glyphs +X-RenderCompositeGlyphs8+ card8 nil + display dest glyph-set source dest-x dest-y sequence alu src-x + src-y mask-format start end)) + ((array (unsigned-byte 16) (*)) + (%render-composite-glyphs +X-RenderCompositeGlyphs16+ card16 nil + display dest glyph-set source dest-x dest-y sequence alu src-x + src-y mask-format start end)) + ((array (unsigned-byte 32) (*)) + (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 nil + display dest glyph-set source dest-x dest-y sequence alu src-x + src-y mask-format start end)) + (string + (%render-composite-glyphs #.(cond ((<= char-code-limit (expt 2 8)) '+X-RenderCompositeGlyphs8+) + ((<= char-code-limit (expt 2 16)) '+X-RenderCompositeGlyphs16+) + ((<= char-code-limit (expt 2 32)) '+X-RenderCompositeGlyphs32+) + (t + (error "Wow!"))) + #.(cond ((<= char-code-limit (expt 2 8)) 'card8) + ((<= char-code-limit (expt 2 16)) 'card16) + ((<= char-code-limit (expt 2 32)) 'card32) + (t + (error "Wow!"))) + #'char-code + display dest glyph-set source dest-x dest-y sequence alu src-x + src-y mask-format start end)) + (t + ;; should we bother testing the array element type? + (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 + #'(lambda (elt) + (if (characterp elt) + (char-code elt) + elt)) + display dest glyph-set source dest-x dest-y sequence alu src-x + src-y mask-format start end))) )) + +;; --- idea: Allow data to be an image to avoid unecessary consing? - noss +(defun render-add-glyph (glyph-set id &key x-origin y-origin x-advance y-advance data) + (let ((display (glyph-set-display glyph-set))) + (ensure-render-initialized display) + (let* ((w (array-dimension data 1)) + (h (array-dimension data 0)) + (bitmap-format (display-bitmap-format display)) + (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)))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderAddGlyphs+) + (length (ceiling request-length 4)) + (glyph-set glyph-set) + (card32 1) ;number glyphs + (card32 id) ;id + (card16 w) + (card16 h) + (int16 x-origin) + (int16 y-origin) + (int16 x-advance) + (int16 y-advance) + (progn + (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 + unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) + +(defun render-add-glyph-from-picture (glyph-set picture + &key x-origin y-origin x-advance y-advance + x y width height) + ;; untested, the duplication of x-origin seems bogus. + ;; Still untested, but these modifications seem to be more likely, (x,y) would be the offset into the picture. + ;; and orgin advance would be properties of the defined glyph. + (let ((display (glyph-set-display glyph-set))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderAddGlyphsFromPicture+) + (glyph-set glyph-set) + (picture picture) + (card16 width) + (card16 height) + (card16 x-origin) + (card16 y-origin) + (card16 x-advance) + (card16 y-advance) + (card16 x) + (card16 y)))) + +;; untested +(defun render-free-glyphs (glyph-set glyphs) + "This request removes glyphs from glyph-set. Each glyph must exist in glyph-set (else a Match error results)." + (let ((display (glyph-set-display glyph-set))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderFreeGlyphs+) + (glyph-set glyph-set) + ((sequence :format card32) glyphs)))) + + +#|| +;;; -------------------------------------------------------------------------------- + +;; testing code: + +(defun x (op) + (let ((dpy (open-display ""))) + (render-query-version dpy) + (unwind-protect + (let* ((win (screen-root (first (display-roots dpy)))) + (display dpy) + (pf (find-window-picture-format win)) + (pm (xlib:create-pixmap + :depth (xlib:drawable-depth win) + :drawable win :width 1 :height 1)) + (pm.p (render-create-picture pm + :format pf + :repeat :on)) + (win.p (render-create-picture win :format pf)) + (gs (render-create-glyph-set (first + (find-matching-picture-formats + dpy + :alpha 8 + :red-max 0 + :green-max 0 + :blue-max 0))))) + (xlib:clear-area win) + (render-fill-rectangle pm.p :src (list #xFFFF 0 0 0) 0 0 100 100) + (render-add-glyph gs 18 + :data (make-array (list 3 3) + :initial-contents '((255 000 000) + (000 255 000) + (000 000 255)) + :element-type '(unsigned-byte 8)) + :x-advance 4 + :y-advance 0 + :x-origin 0 + :y-origin 0) + (let ((w 50) + (h 50)) + (let ((data (make-array (list h w) :element-type '(unsigned-byte 8) :initial-element 0))) + (dotimes (i w) + (dotimes (j h) + (setf (aref data i j) (* 3 i)))) + (render-add-glyph gs 17 + :data data + :x-advance (+ w 2) + :y-advance 0 + :x-origin 0 + :y-origin 0))) + + (render-composite-glyphs-8 win.p gs pm.p + 200 330 + (vector 17 18 18 17 17 17 17 17 17 17) + :alu op + ) + ;; + (display-finish-output dpy) + (close-display dpy))))) + +(defun z (op) + (let ((dpy (open-display ""))) + (unwind-protect + (let* ((win (screen-root (first (display-roots dpy)))) + (pic (render-create-picture win)) + (fmt (first (find-matching-picture-formats + dpy + :red-min 8 + :green-min 8 + :blue-min 8 + :alpha-min 8))) + (px (xlib:create-pixmap :width 256 :height 256 :depth (picture-format-depth fmt) + :drawable win)) + (px.pic (render-create-picture px :format fmt)) + (px.gc (xlib:create-gcontext :drawable px))) + (xlib:clear-area win) + ;; + (render-fill-rectangle px.pic :src + (list #x8000 #x0000 #x8000 #xFFFF) + 0 0 256 256) + ;; render-combine simply does not work + (render-combine :src pic pic px.pic + 350 350 350 350 0 0 256 256) + ;; + (render-fill-rectangle px.pic :over + (list #x8000 #x8000 #x8000 #x8000) + 0 0 100 100) + (render-combine :src + px.pic px.pic pic + 0 0 0 0 350 350 + 256 256) + (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800) + (display-finish-output dpy)) + (close-display dpy)))) + +;;; ---------------------------------------------------------------------------------------------------- + +(defun y (op) + (let ((dpy (open-display ""))) + (render-query-version dpy) + (unwind-protect + (let* ((win (screen-root (first (display-roots dpy)))) + (pic + (render-create-picture win)) + (px (xlib:create-pixmap :drawable win + :width 256 + :height 256 + :depth 32)) + (px.gc (xlib:create-gcontext :drawable px))) + (dotimes (x 256) + (dotimes (y 256) + (setf (xlib:gcontext-foreground px.gc) + (dpb x (byte 8 24) + (dpb y (byte 8 16) + (dpb y (byte 8 8) + y)))) + (xlib:draw-point px px.gc x y) + )) + (xlib:clear-area win) + (let ((q(render-create-picture px + :format + (first (find-matching-picture-formats + dpy + :depth 32 + :alpha 8 :red 8 :green 8 :blue 8)) + :component-alpha :on + :repeat :off + ))) + (render-combine op + q + q + pic + 0 0 + 0 0 + 100 100 + 400 400)) + (let () + ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200) + (display-finish-output dpy))) + (close-display dpy)))) + +(defun zz () + (let* ((dpy (xlib:open-display "")) + (win (screen-root (first (display-roots dpy)))) + (pic (render-create-picture win))) + (xlib:clear-area win) + (setf (picture-clip-mask pic) (list 100 100 200 2000)) + (render-fill-rectangle pic :over (list #xFFFF 0 0 #x400) 0 0 2000 2000) + (display-finish-output dpy) + (close-display dpy))) +||# + + +;;;; Cursors + +(defun render-create-cursor (picture &optional (x 0) (y 0)) + (let ((display (picture-display picture))) + (ensure-render-initialized display) + (synchronise-picture-state picture) + (let* ((cursor (make-cursor :display display)) + (cid (allocate-resource-id display cursor 'cursor))) + (setf (cursor-id cursor) cid) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderCreateCursor+) + (resource-id cid) + (resource-id (picture-id picture)) + (card16 x) + (card16 y)) + cursor))) diff --git a/clx/xvidmode.lisp b/clx/xvidmode.lisp new file mode 100644 index 000000000..9f13d0f98 --- /dev/null +++ b/clx/xvidmode.lisp @@ -0,0 +1,733 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- +;;; --------------------------------------------------------------------------- +;;; Title: XFree86 video mode extension +;;; Created: 2003 03 28 15:28 +;;; Author: Iban Hatchondo <hatchond@labri.fr> +;;; --------------------------------------------------------------------------- +;;; (c) copyright 2003 by Iban Hatchondo + +;;; +;;; Permission is granted to any individual or institution to use, +;;; copy, modify, and distribute this software, provided that this +;;; complete copyright and permission notice is maintained, intact, in +;;; all copies and supporting documentation. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +;;; + +;;; THIS IS NOT AN X CONSORTIUM STANDARD OR AN X PROJECT TEAM SPECIFICATION + +;;; DESCRIPTION +;;; +;;; These functions provide an interface to the server extension +;;; XFree86-VidModeExtension which allows the video modes to be +;;; queried, adjusted dynamically and the mode switching to be +;;; controlled. + +;;; [ personal notes ] +;;; +;;; The documentation on this extension is very poor, probably, +;;; because it is not an X standard nor an X project team spec. +;;; Because of that, it need to be tested on some XFree 3.3.6, +;;; and XFree 4.3.x to ensure that all request are correctly +;;; constructed as well as to indentify any obsolete/wrong +;;; functions I made. + +#+cmu +(ext:file-comment "$Id: xvidmode.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $") + +(in-package :xlib) + +(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) + :xlib) + +;; current version numbers +;; +;; major 0 == uses parameter-to-wire functions in XFree86 libXxf86vm. +;; major 1 == uses parameter-to-wire functions hard-coded in xvidtune client. +;; major 2 == uses new protocol version in XFree86 4.0. +(defconstant +xf86vidmode-major-version+ 2) +(defconstant +xf86vidmode-minor-version+ 2) + +;; requests number. +(defconstant +query-version+ 0) +(defconstant +get-mode-line+ 1) +(defconstant +mod-mode-line+ 2) +(defconstant +switch-mode+ 3) +(defconstant +get-monitor+ 4) +(defconstant +lock-mode-switch+ 5) +(defconstant +get-all-mode-lines+ 6) +(defconstant +add-mode-line+ 7) +(defconstant +delete-mode-line+ 8) +(defconstant +validate-mode-line+ 9) +(defconstant +switch-to-mode+ 10) +(defconstant +get-viewport+ 11) +(defconstant +set-viewport+ 12) + +;; new for version 2.x of this extension. +(defconstant +get-dot-clocks+ 13) +(defconstant +set-client-version+ 14) +(defconstant +set-gamma+ 15) +(defconstant +get-gamma+ 16) +(defconstant +get-gamma-ramp+ 17) +(defconstant +set-gamma-ramp+ 18) +(defconstant +get-gamma-ramp-size+ 19) +(defconstant +get-permisions+ 20) + +(define-extension "XFree86-VidModeExtension" + :events (:xfree86-vidmode-notify) + :errors (xf86-vidmode-bad-clock + xf86-vidmode-bad-htimings + xf86-vidmode-bad-vtimings + xf86-vidmode-mode-unsuitable + xf86-vidmode-extension-disabled + xf86-vidmode-client-not-local + xf86-vidmode-zoom-locked)) + +(define-condition xf86-vidmode-bad-clock (request-error) ()) +(define-condition xf86-vidmode-bad-htimings (request-error) ()) +(define-condition xf86-vidmode-bad-vtimings (request-error) ()) +(define-condition xf86-vidmode-mode-unsuitable (request-error) ()) +(define-condition xf86-vidmode-extension-disabled (request-error) ()) +(define-condition xf86-vidmode-client-not-local (request-error) ()) +(define-condition xf86-vidmode-zoom-locked (request-error) ()) + +(define-error xf86-vidmode-bad-clock decode-core-error) +(define-error xf86-vidmode-bad-htimings decode-core-error) +(define-error xf86-vidmode-bad-vtimings decode-core-error) +(define-error xf86-vidmode-mode-unsuitable decode-core-error) +(define-error xf86-vidmode-extension-disabled decode-core-error) +(define-error xf86-vidmode-client-not-local decode-core-error) +(define-error xf86-vidmode-zoom-locked decode-core-error) + +(declare-event :XFree86-VidMode-notify + (card16 sequence) + (window (window event-window)) ; the root window of event screen + (int16 state) ; what happend + (int16 kind) ; what happend + (boolean forced-p) ; extents of a new region + ((or null card32) time)) ; event timestamp + +(defstruct mode-info + (dotclock 0 :type card32) + (hdisplay 0 :type card16) + (hsyncstart 0 :type card16) + (hsyncend 0 :type card16) + (htotal 0 :type card16) + (hskew 0 :type card32) + (vdisplay 0 :type card16) + (vsyncstart 0 :type card16) + (vsyncend 0 :type card16) + (vtotal 0 :type card16) + (flags 0 :type card32) + (privsize 0 :type card32) + (private nil :type sequence)) + +(defmacro vidmode-opcode (display) + `(extension-opcode ,display "XFree86-VidModeExtension")) + +(declaim (inline screen-position)) +(defun screen-position (screen display) + (declare (type display display) + (type screen screen)) + (declare (clx-values position)) + (let ((position (position screen (xlib:display-roots display)))) + (if (not (numberp position)) + (error "screen ~A not found in display ~A" screen display) + position))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; ;;;; +;;;; public XFree86-VidMode Extension routines ;;;; +;;;; ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun xfree86-vidmode-query-version (display) + "Determine the version of the extension built into the server. +return two values major-version and minor-version in that order." + (declare (type display display)) + (with-buffer-request-and-reply + (display (vidmode-opcode display) nil :sizes 16) + ((data +query-version+)) + (let ((major (card16-get 8)) + (minor (card16-get 10))) + (declare (type card16 major minor)) + (when (>= major 2) + (XFree86-VidMode-set-client-version display)) + (values major minor)))) + +(defun xfree86-vidmode-set-client-version (display) + (declare (type display display)) + (with-buffer-request (display (vidmode-opcode display)) + (data +set-client-version+) + (card16 +xf86vidmode-major-version+) + (card16 +xf86vidmode-minor-version+))) + +(defun xfree86-vidmode-get-permissions (dpy screen) + (declare (type display dpy) + (type screen screen)) + (with-buffer-request-and-reply + (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + ((data +get-permisions+) + (card16 (screen-position screen dpy)) + (card16 0)) + (values + (card32-get 8)))) + +(defun xfree86-vidmode-mod-mode-line (display screen mode-line) + "Change the settings of the current video mode provided the +requested settings are valid (e.g. they don't exceed the +capabilities of the monitor)." + (declare (type display display) + (type screen screen)) + (let* ((major (xfree86-vidmode-query-version display)) + (v (mode-info->v-card16 mode-line major))) + (declare (type card16 major) + (type simple-vector v)) + (with-buffer-request (display (vidmode-opcode display)) + (data +mod-mode-line+) + (card32 (screen-position screen display)) + ((sequence :format card16 :start 2) v)))) + +(defun xfree86-vidmode-get-mode-line (display screen) + "Query the settings for the currently selected video mode. +return a mode-info structure fields with the server answer. +If there are any server private values (currently only +applicable to the S3 server) the function will store it +into the returned structure." + (declare (clx-values mode-info) + (type display display) + (type screen screen)) + (let ((major (xfree86-vidmode-query-version display)) + (offset 8)) + (declare (type fixnum offset) + (type card16 major)) + (with-buffer-request-and-reply + (display (vidmode-opcode display) nil :sizes (8 16 32)) + ((data +get-mode-line+) + (card16 (screen-position screen display)) + (card16 0)) + (let ((mode-info + (make-mode-info + :dotclock (card32-get offset) + :hdisplay (card16-get (incf offset 4)) + :hsyncstart (card16-get (incf offset 2)) + :hsyncend (card16-get (incf offset 2)) + :htotal (card16-get (incf offset 2)) + :hskew (if (< major 2) 0 (card16-get (incf offset 2))) + :vdisplay (card16-get (incf offset 2)) + :vsyncstart (card16-get (incf offset 2)) + :vsyncend (card16-get (incf offset 2)) + :vtotal (card16-get (incf offset 2)) + :flags (card32-get (incf offset (if (< major 2) 2 4))))) + (size (card32-get (incf offset (if (< major 2) 4 16))))) + (declare (type card32 size)) + (incf offset 4) + (setf (mode-info-privsize mode-info) size + (mode-info-private mode-info) + (sequence-get :format card32 :index offset + :length size :result-type 'list)) + mode-info)))) + +(defun xfree86-vidmode-get-all-mode-lines (dpy screen) + "Returns a list containing all video modes (as mode-info structure). +The first element of the list corresponds to the current video mode." + (declare (type display dpy) + (type screen screen)) + (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) + (declare (type card16 major minor)) + (with-buffer-request-and-reply + (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + ((data +get-all-mode-lines+) + (card16 (screen-position screen dpy))) + (values + ;; Note: There was a bug in the protocol implementation in versions + ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). + ;; Check the server's version, and accept the old format if appropriate. + (loop with bug-p = (and (= major 0) (< minor 8)) + with offset of-type fixnum = 32 + for i of-type card32 from 0 below (or (card32-get 8) 0) + collect + (let ((mode-info + (make-mode-info + :dotclock (card32-get offset) + :hdisplay (card16-get (incf offset 4)) + :hsyncstart (card16-get (incf offset 2)) + :hsyncend (card16-get (incf offset 2)) + :htotal (card16-get (incf offset 2)) + :hskew (if (< major 2) 0 (card32-get (incf offset 2))) + :vdisplay (card16-get (incf offset 4)) + :vsyncstart (card16-get (incf offset 2)) + :vsyncend (card16-get (incf offset 2)) + :vtotal (card16-get (incf offset 2)) + :flags (card32-get (incf offset (if (< major 2) 2 6))))) + (size (card32-get (incf offset (if (< major 2) 4 16))))) + (declare (type card32 size)) + (incf offset 4) + (when bug-p + (setf size 0)) + (setf (mode-info-privsize mode-info) size + (mode-info-private mode-info) + (sequence-get :format card32 :index offset + :length size :result-type 'list)) + (incf offset (* 4 size)) + mode-info)))))) + +(defun xfree86-vidmode-add-mode-line (dpy scr new &key (after (make-mode-info))) + (declare (type display dpy) + (type screen scr)) + (let* ((private (mode-info-private new)) + (privsize (mode-info-privsize new)) + (major (xfree86-vidmode-query-version dpy)) + (i (if (< major 2) 14 22)) + (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0))) + (declare (type card32 privsize) + (type fixnum i) + (type card16 major) + (type simple-vector v)) + (mode-info->v-card16 new major :encode-private nil :data v) + (mode-info->v-card16 after major :encode-private nil :data v :index i) + (setf i (- (* 2 i) 2)) + ;; strore private info (sequence card32) according clx bytes order. + (loop for card of-type card32 in private + do (multiple-value-bind (w1 w2) (__card32->card16__ card) + (setf (svref v (incf i)) w1 + (svref v (incf i)) w2))) + + (with-buffer-request (dpy (vidmode-opcode dpy)) + (data +add-mode-line+) + (card32 (screen-position scr dpy)) + ((sequence :format card16) v)))) + +(defun xfree86-vidmode-delete-mode-line (dpy scr mode-info) + "Delete mode argument. The specified mode must match an existing mode. +To be considered a match, all of the fields of the given mode-info +structure must match, except the privsize and private fields. +If the mode to be deleted is the current mode, a mode switch to the next +mode will occur first. The last remaining mode can not be deleted." + (declare (type display dpy) + (type screen scr)) + (let* ((major (xfree86-vidmode-query-version dpy)) + (v (mode-info->v-card16 mode-info major))) + (declare (type card16 major) + (type simple-vector v)) + (with-buffer-request (dpy (vidmode-opcode dpy)) + (data +delete-mode-line+) + (card32 (screen-position scr dpy)) + ((sequence :format card16) v)))) + +(defconstant +mode-status+ + '#(:MODE_BAD ; unspecified reason + :MODE_ERROR ; error condition + :MODE_OK ; Mode OK + :MODE_HSYNC ; hsync out of range + :MODE_VSYNC ; vsync out of range + :MODE_H_ILLEGAL ; mode has illegal horizontal timings + :MODE_V_ILLEGAL ; mode has illegal horizontal timings + :MODE_BAD_WIDTH ; requires an unsupported linepitch + :MODE_NO_MODE ; no mode with a maching name + :MODE_NO_INTERLACE ; interlaced mode not supported + :MODE_NO_DBLESCAN ; doublescan mode not supported + :MODE_NO_VSCAN ; multiscan mode not supported + :MODE_MEM ; insufficient video memory + :MODE_VIRTUAL_X ; mode width too large for specified virtual size + :MODE_VIRTUAL_Y ; mode height too large for specified virtual size + :MODE_MEM_VIRT ; insufficient video memory given virtual size + :MODE_NOCLOCK ; no fixed clock available + :MODE_CLOCK_HIGH ; clock required is too high + :MODE_CLOCK_LOW ; clock required is too low + :MODE_CLOCK_RANGE ; clock/mode isn't in a ClockRange + :MODE_BAD_HVALUE ; horizontal timing was out of range + :MODE_BAD_VVALUE ; vertical timing was out of range + :MODE_BAD_VSCAN ; VScan value out of range + :MODE_HSYNC_NARROW ; horizontal sync too narrow + :MODE_HSYNC_WIDE ; horizontal sync too wide + :MODE_HBLANK_NARROW ; horizontal blanking too narrow + :MODE_HBLANK_WIDE ; horizontal blanking too wide + :MODE_VSYNC_NARROW ; vertical sync too narrow + :MODE_VSYNC_WIDE ; vertical sync too wide + :MODE_VBLANK_NARROW ; vertical blanking too narrow + :MODE_VBLANK_WIDE ; vertical blanking too wide + :MODE_PANEL ; exceeds panel dimensions + :MODE_INTERLACE_WIDTH ; width too large for interlaced mode + :MODE_ONE_WIDTH ; only one width is supported + :MODE_ONE_HEIGHT ; only one height is supported + :MODE_ONE_SIZE ; only one resolution is supported + )) + +(defun decode-status-mode (status) + (declare (type int32 status)) + (svref +mode-status+ (+ status 2))) + +(defun xfree86-vidmode-validate-mode-line (dpy scr mode-info) + "Checked the validity of a mode-info argument. If the specified mode can be +used by the server (i.e. meets all the constraints placed upon a mode by the +combination of the server, card, and monitor) the function returns :mode_ok +otherwise it returns a keyword indicating the reason why the mode is +invalid." + (declare (type display dpy) + (type screen scr)) + (let* ((major (xfree86-vidmode-query-version dpy)) + (v (mode-info->v-card16 mode-info major))) + (declare (type card16 major) + (type simple-vector v)) + (with-buffer-request-and-reply + (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + ((data +validate-mode-line+) + (card32 (screen-position scr dpy)) + ((sequence :format card16) v)) + (let ((status (integer-get 8))) + (declare (type int32 status)) + (when status (decode-status-mode status)))))) + +(defun xfree86-vidmode-get-gamma (display screen) + (declare (type display display) + (type screen screen)) + (with-buffer-request-and-reply + (display (vidmode-opcode display) nil :sizes (8 16 32)) + ((data +get-gamma+) + (card16 (screen-position screen display)) + (card16 0) + (card32 0) (card32 0) + (card32 0) (card32 0) + (card32 0) (card32 0)) + (values + (/ (the card32 (or (card32-get 8) 0)) 10000.0) + (/ (the card32 (or (card32-get 12) 0)) 10000.0) + (/ (the card32 (or (card32-get 16) 0)) 10000.0)))) + +(defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0)) + (declare (type display dpy) + (type screen scr) + (type (single-float 0.100 10.000) red green blue)) + (with-buffer-request (dpy (vidmode-opcode dpy)) + (data +set-gamma+) + (card16 (screen-position scr dpy)) + (card16 0) + (card32 (truncate (* red 10000))) + (card32 (truncate (* green 10000))) + (card32 (truncate (* blue 10000))) + (card32 0) + (card32 0) + (card32 0))) + +(defun xfree86-vidmode-get-gamma-ramp (dpy scr size) + (declare (type display dpy) + (type screen scr) + (type card16 size)) + (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + ((data +get-gamma-ramp+) + (card16 (screen-position scr dpy)) + (card16 size)) + (let ((rep-size (* (the card16 (or (card16-get 8) 0)) 2))) + (declare (type fixnum rep-size)) + (unless (zerop rep-size) + (let* ((off1 (+ 32 rep-size (* 2 (mod rep-size 2)))) + (off2 (+ off1 rep-size (* 2 (mod rep-size 2))))) + (declare (type fixnum off1 off2)) + (values + (sequence-get :format card16 :length (card16-get 8) + :index 32 :result-type 'list) + (sequence-get :format card16 :length (card16-get 8) + :index off1 :result-type 'list) + (sequence-get :format card16 :length (card16-get 8) + :index off2 :result-type 'list))))))) + +(defun xfree86-vidmode-set-gamma-ramp (dpy scr size &key red green blue) + (declare (type (or null simple-vector) red green blue) + (type card16 size) + (type display dpy) + (type screen scr)) + (with-buffer-request (dpy (vidmode-opcode dpy)) + (data +set-gamma-ramp+) + (card16 (screen-position scr dpy)) + (card16 size) + ((sequence :format card16) + (if (zerop (mod size 2)) + (concatenate 'vector red green blue) + (concatenate 'vector red '#(0) green '#(0) blue '#(0)))))) + +(defun xfree86-vidmode-get-gamma-ramp-size (dpy screen) + (declare (type display dpy) + (type screen screen)) + (with-buffer-request-and-reply + (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + ((data +get-gamma-ramp-size+) + (card16 (screen-position screen dpy)) + (card16 0)) + (card16-get 8))) + +(defun xfree86-vidmode-lock-mode-switch (display screen lock-p) + "Allow or disallow mode switching whether the request to switch +modes comes from a call to the mode switching functions or from one +of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)." + (declare (type display display) + (type screen screen) + (type boolean lock-p)) + (with-buffer-request (display (vidmode-opcode display)) + (data +lock-mode-switch+) + (card16 (screen-position screen display)) + (card16 (if lock-p 1 0)))) + +(defun xfree86-vidmode-switch-to-mode (display screen mode-info) + "Switch directly to the specified mode. The specified mode must match +an existing mode. Matching is as specified in the description of the +xf86-vidmode-delete-mode-line function." + (declare (type display display) + (type screen screen)) + (multiple-value-bind (major minor) (xfree86-vidmode-query-version display) + (declare (type card16 major minor)) + ;; Note: There was a bug in the protocol implementation in versions + ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). + ;; Check the server's version, and accept the old format if appropriate. + (let ((bug-p (and (= major 0) (< minor 8))) + (privsize (mode-info-privsize mode-info))) + (declare (type boolean bug-p)) + (and bug-p (setf (mode-info-privsize mode-info) 0)) + (let ((v (mode-info->v-card16 mode-info major :encode-private bug-p))) + (declare (type simple-vector v)) + (and bug-p (setf (mode-info-privsize mode-info) privsize)) + (with-buffer-request (display (vidmode-opcode display)) + (data +switch-to-mode+) + (card32 (screen-position screen display)) + ((sequence :format card16) v)))))) + +(defun xfree86-vidmode-switch-mode (display screen zoom) + "Change the video mode to next (or previous) video mode, depending +of zoom sign. If positive, switch to next mode, else switch to prev mode." + (declare (type display display) + (type screen screen) + (type card16 zoom)) + (with-buffer-request (display (vidmode-opcode display)) + (data +switch-mode+) + (card16 (screen-position screen display)) + (card16 zoom))) + +(defun xfree86-vidmode-select-next-mode (display screen) + "Change the video mode to next video mode" + (declare (type display display) + (type screen screen)) + (with-buffer-request (display (vidmode-opcode display)) + (data +switch-mode+) + (card16 (screen-position screen display)) + (card16 1))) + +(defun xfree86-vidmode-select-prev-mode (display screen) + "Change the video mode to previous video mode" + (declare (type display display) + (type screen screen)) + (with-buffer-request (display (vidmode-opcode display)) + (data +switch-mode+) + (card16 (screen-position screen display)) + (card16 #xFFFF))) + +(defun xfree86-vidmode-get-monitor (dpy screen) + "Information known to the server about the monitor is returned. +Multiple value return: + hsync (list of hi, low, ...) + vsync (list of hi, low, ...) + vendor name + model name + +The hi and low values will be equal if a discreate value was given +in the XF86Config file." + (declare (type display dpy) + (type screen screen)) + (with-buffer-request-and-reply + (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + ((data +get-monitor+) + (card16 (screen-position screen dpy)) + (card16 0)) + (let* ((vendor-name-length (card8-get 8)) + (model-name-length (card8-get 9)) + (pad (- 4 (mod vendor-name-length 4))) + (nhsync (card8-get 10)) + (nvsync (card8-get 11)) + (vindex (+ 32 (* 4 (+ nhsync nvsync)))) + (mindex (+ vindex vendor-name-length pad)) + (hsync (sequence-get :length nhsync :index 32 :result-type 'list)) + (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4)) + :result-type 'list))) + (declare (type card8 nhsync nvsync vendor-name-length model-name-length) + (type fixnum pad vindex mindex)) + (values + (loop for i of-type card32 in hsync + collect (/ (ldb (byte 16 0) i) 100.) + collect (/ (ldb (byte 32 16) i) 100.)) + (loop for i of-type card32 in vsync + collect (/ (ldb (byte 16 0) i) 100.) + collect (/ (ldb (byte 32 16) i) 100.)) + (string-get vendor-name-length vindex) + (string-get model-name-length mindex))))) + +(defun xfree86-vidmode-get-viewport (dpy screen) + "Query the location of the upper left corner of the viewport into +the virtual screen. The upper left coordinates will be returned as +a multiple value." + (declare (type display dpy) + (type screen screen)) + (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) + (declare (type card16 major minor)) + ;; Note: There was a bug in the protocol implementation in versions + ;; 0.x with x < 8 (no reply was sent, so the client would hang) + ;; Check the server's version, and don't wait for a reply with older + ;; versions. + (when (and (= major 0) (< minor 8)) + (format cl:*error-output* + "running an old version ~a ~a~%" + major minor) + (return-from xfree86-vidmode-get-viewport nil)) + (with-buffer-request-and-reply + (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + ((data +get-viewport+) + (card16 (screen-position screen dpy)) + (card16 0)) + (values + (card32-get 8) + (card32-get 12))))) + +(defun xfree86-vidmode-set-viewport (dpy screen &key (x 0) (y 0)) + "Set upper left corner of the viewport into the virtual screen to the +x and y keyword parameters value (zero will be theire default value)." + (declare (type display dpy) + (type screen screen) + (type card32 x y)) + (with-buffer-request (dpy (vidmode-opcode dpy)) + (data +set-viewport+) + (card16 (screen-position screen dpy)) + (card16 0) + (card32 x) + (card32 y))) + +(defun xfree86-vidmode-get-dotclocks (dpy screen) + "Returns as a multiple value return the server dotclock informations: + flags + maxclocks + clock list" + (declare (type display dpy) + (type screen screen)) + (with-buffer-request-and-reply + (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + ((data +get-dot-clocks+) + (card16 (screen-position screen dpy)) + (card16 0)) + (values + (card32-get 8) ; flags + (card32-get 16) ; max clocks + (sequence-get :length (card32-get 12) :format card32 + :index 32 :result-type 'list)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; ;;;; +;;;; private utility routines ;;;; +;;;; ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun mode-info->v-card16 + (mode-info major &key (encode-private t) (index 0) data) + (declare (type integer index) + (type card16 major) + (type boolean encode-private) + (type (or null simple-vector) data)) + (let ((dotclock (mode-info-dotclock mode-info)) + (hdisplay (mode-info-hdisplay mode-info)) + (hsyncstart (mode-info-hsyncstart mode-info)) + (hsyncend (mode-info-hsyncend mode-info)) + (htotal (mode-info-htotal mode-info)) + (hskew (mode-info-hskew mode-info)) + (vdisplay (mode-info-vdisplay mode-info)) + (vsyncstart (mode-info-vsyncstart mode-info)) + (vsyncend (mode-info-vsyncend mode-info)) + (vtotal (mode-info-vtotal mode-info)) + (flags (mode-info-flags mode-info)) + (privsize (mode-info-privsize mode-info)) + (private (mode-info-private mode-info))) + (declare (type card16 hdisplay hsyncstart hsyncend htotal hskew) + (type card16 vdisplay vsyncstart vsyncend vtotal) + (type card32 dotclock flags privsize) + (type (or null sequence) private)) + (let* ((size (+ (if (< major 2) 14 22) (* privsize 2))) + (v (or data (make-array size :initial-element 0)))) + (declare (type fixnum size) + (type simple-vector v)) + ;; store dotclock (card32) according clx bytes order. + (multiple-value-bind (w1 w2) (__card32->card16__ dotclock) + (setf (svref v index) w1 + (svref v (incf index)) w2)) + (setf (svref v (incf index)) hdisplay + (svref v (incf index)) hsyncstart + (svref v (incf index)) hsyncend + (svref v (incf index)) htotal) + (unless (< major 2) + (setf (svref v (incf index)) hskew)) + (setf (svref v (incf index)) vdisplay + (svref v (incf index)) vsyncstart + (svref v (incf index)) vsyncend + (svref v (incf index)) vtotal) + (unless (< major 2) + (incf index)) + ;; strore flags (card32) according clx bytes order. + (multiple-value-bind (w1 w2) (__card32->card16__ flags) + (setf (svref v (incf index)) w1 + (svref v (incf index)) w2)) + ;; strore privsize (card32) according clx bytes order. + (multiple-value-bind (w1 w2) (__card32->card16__ privsize) + (setf (svref v (incf index)) w1 + (svref v (incf index)) w2)) + ;; reserverd byte32 1 2 3 + (unless (< major 2) (incf index 6)) + ;; strore private info (sequence card32) according clx bytes order. + (when encode-private + (loop for i of-type int32 in private + do (multiple-value-bind (w1 w2) (__card32->card16__ i) + (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)))) -- GitLab