Skip to content
Snippets Groups Projects
Commit 89a67b64 authored by fgilham's avatar fgilham
Browse files

Telent CLX import

parent f5c564ec
No related branches found
No related tags found
No related merge requests found
Showing with 1526 additions and 690 deletions
$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.
clx/NEWS 0 → 100644
-*- 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.
$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>
$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
$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.
...@@ -17,9 +17,6 @@ ...@@ -17,9 +17,6 @@
;;; Texas Instruments Incorporated provides this software "as is" without ;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty. ;;; 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: ;;; The special variable *window-attributes* is an alist containg:
;;; (drawable attributes attribute-changes geometry geometry-changes) ;;; (drawable attributes attribute-changes geometry geometry-changes)
...@@ -43,12 +40,15 @@ ...@@ -43,12 +40,15 @@
;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including ;;; 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. ;;; 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) (in-package :xlib)
(eval-when (compile load eval) ;needed by Franz Lisp (eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant *attribute-size* 44) (defconstant +attribute-size+ 44)
(defconstant *geometry-size* 24) (defconstant +geometry-size+ 24)
(defconstant *context-size* (max *attribute-size* *geometry-size* (* 16 4)))) (defconstant +context-size+ (max +attribute-size+ +geometry-size+ (* 16 4))))
(defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE (defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE
...@@ -57,7 +57,7 @@ ...@@ -57,7 +57,7 @@
(defun allocate-context () (defun allocate-context ()
(or (threaded-atomic-pop *context-free-list* reply-next reply-buffer) (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) (defun deallocate-context (context)
(declare (type reply-buffer context)) (declare (type reply-buffer context))
...@@ -69,12 +69,12 @@ ...@@ -69,12 +69,12 @@
(defmacro state-geometry-changes (state) `(fifth ,state)) (defmacro state-geometry-changes (state) `(fifth ,state))
(defmacro drawable-equal-function () (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 ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
''drawable-equal)) ''drawable-equal))
(defmacro window-equal-function () (defmacro window-equal-function ()
(if (member 'window *clx-cached-types*) (if (member 'window +clx-cached-types+)
''eq ''eq
''drawable-equal)) ''drawable-equal))
...@@ -158,7 +158,7 @@ ...@@ -158,7 +158,7 @@
(setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
(setf (aref changes (1+ number)) value)) ;; save value (setf (aref changes (1+ number)) value)) ;; save value
; Send change to the server ; Send change to the server
(with-buffer-request ((window-display window) *x-changewindowattributes*) (with-buffer-request ((window-display window) +x-changewindowattributes+)
(window window) (window window)
(card32 (ash 1 number) value))))) (card32 (ash 1 number) value)))))
;; ;;
...@@ -185,7 +185,7 @@ ...@@ -185,7 +185,7 @@
(setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
(setf (aref changes (1+ number)) value)) ;; save value (setf (aref changes (1+ number)) value)) ;; save value
; Send change to the server ; Send change to the server
(with-buffer-request ((drawable-display drawable) *x-configurewindow*) (with-buffer-request ((drawable-display drawable) +x-configurewindow+)
(drawable drawable) (drawable drawable)
(card16 (ash 1 number)) (card16 (ash 1 number))
(card29 value))))) (card29 value)))))
...@@ -207,7 +207,7 @@ ...@@ -207,7 +207,7 @@
(deallocate-gcontext-state (state-attribute-changes state-entry)) (deallocate-gcontext-state (state-attribute-changes state-entry))
(setf (state-attribute-changes state-entry) nil)) (setf (state-attribute-changes state-entry) nil))
;; Get window attributes ;; 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)) ((window window))
(let ((repbuf (or (state-attributes state-entry) (allocate-context)))) (let ((repbuf (or (state-attributes state-entry) (allocate-context))))
(declare (type reply-buffer repbuf)) (declare (type reply-buffer repbuf))
...@@ -237,7 +237,7 @@ ...@@ -237,7 +237,7 @@
(deallocate-gcontext-state (state-geometry-changes state-entry)) (deallocate-gcontext-state (state-geometry-changes state-entry))
(setf (state-geometry-changes state-entry) nil)) (setf (state-geometry-changes state-entry) nil))
;; Get drawable attributes ;; 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)) ((drawable drawable))
(let ((repbuf (or (state-geometry state-entry) (allocate-context)))) (let ((repbuf (or (state-geometry state-entry) (allocate-context))))
(declare (type reply-buffer repbuf)) (declare (type reply-buffer repbuf))
...@@ -255,7 +255,7 @@ ...@@ -255,7 +255,7 @@
(mask (aref changes 0))) (mask (aref changes 0)))
(declare (type display display) (declare (type display display)
(type mask32 mask)) (type mask32 mask))
(with-buffer-request (display *x-changewindowattributes*) (with-buffer-request (display +x-changewindowattributes+)
(window window) (window window)
(card32 mask) (card32 mask)
(progn ;; Insert a word in the request for each one bit in the mask (progn ;; Insert a word in the request for each one bit in the mask
...@@ -282,7 +282,7 @@ ...@@ -282,7 +282,7 @@
(mask (aref changes 0))) (mask (aref changes 0)))
(declare (type display display) (declare (type display display)
(type mask16 mask)) (type mask16 mask))
(with-buffer-request (display *x-configurewindow*) (with-buffer-request (display +x-configurewindow+)
(window window) (window window)
(card16 mask) (card16 mask)
(progn ;; Insert a word in the request for each one bit in the mask (progn ;; Insert a word in the request for each one bit in the mask
...@@ -352,6 +352,8 @@ ...@@ -352,6 +352,8 @@
(t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) (t (x-type-error background '(or (member :none :parent-relative) integer pixmap))))
background) background)
#+Genera (eval-when (compile) (compiler:function-defined 'window-background))
(defsetf window-background set-window-background) (defsetf window-background set-window-background)
(defun set-window-border (window border) (defun set-window-border (window border)
...@@ -365,6 +367,8 @@ ...@@ -365,6 +367,8 @@
(t (x-type-error border '(or (member :copy) integer pixmap)))) (t (x-type-error border '(or (member :copy) integer pixmap))))
border) border)
#+Genera (eval-when (compile) (compiler:function-defined 'window-border))
(defsetf window-border set-window-border) (defsetf window-border set-window-border)
(defun window-bit-gravity (window) (defun window-bit-gravity (window)
...@@ -372,11 +376,11 @@ ...@@ -372,11 +376,11 @@
(declare (type window window)) (declare (type window window))
(declare (clx-values bit-gravity)) (declare (clx-values bit-gravity))
(with-attributes (window :sizes 8) (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) (defun set-window-bit-gravity (window gravity)
(change-window-attribute (change-window-attribute
window 4 (encode-type (member-vector *bit-gravity-vector*) gravity)) window 4 (encode-type (member-vector +bit-gravity-vector+) gravity))
gravity) gravity)
(defsetf window-bit-gravity set-window-bit-gravity) (defsetf window-bit-gravity set-window-bit-gravity)
...@@ -386,11 +390,11 @@ ...@@ -386,11 +390,11 @@
(declare (type window window)) (declare (type window window))
(declare (clx-values win-gravity)) (declare (clx-values win-gravity))
(with-attributes (window :sizes 8) (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) (defun set-window-gravity (window gravity)
(change-window-attribute (change-window-attribute
window 5 (encode-type (member-vector *win-gravity-vector*) gravity)) window 5 (encode-type (member-vector +win-gravity-vector+) gravity))
gravity) gravity)
(defsetf window-gravity set-window-gravity) (defsetf window-gravity set-window-gravity)
...@@ -630,6 +634,8 @@ ...@@ -630,6 +634,8 @@
(change-drawable-geometry window 5 (encode-type window sibling)))) (change-drawable-geometry window 5 (encode-type window sibling))))
mode) mode)
#+Genera (eval-when (compile) (compiler:function-defined 'window-priority))
(defsetf window-priority (window &optional sibling) (mode) (defsetf window-priority (window &optional sibling) (mode)
;; A bit strange, but retains setf form. ;; A bit strange, but retains setf form.
`(set-window-priority ,mode ,window ,sibling)) `(set-window-priority ,mode ,window ,sibling))
;;; -*- 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)))))
This diff is collapsed.
...@@ -18,9 +18,9 @@ ...@@ -18,9 +18,9 @@
;;; Texas Instruments Incorporated provides this software "as is" without ;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty. ;;; express or implied warranty.
;;; ;;;
#+cmu #+cmu
(ext:file-comment (ext:file-comment "$Id: bufmac.lisp,v 1.5 2007/08/21 15:49:27 fgilham Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/bufmac.lisp,v 1.4 1998/12/19 15:21:15 dtc Exp $")
(in-package :xlib) (in-package :xlib)
......
;;; -*- 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:")))
;;;(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:"))
...@@ -15,9 +15,6 @@ ...@@ -15,9 +15,6 @@
;;; Texas Instruments Incorporated provides this software "as is" without ;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty. ;;; 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: ;; Primary Interface Author:
;; Robert W. Scheifler ;; Robert W. Scheifler
...@@ -79,6 +76,9 @@ ...@@ -79,6 +76,9 @@
;;; objects, and the additional functionality to match the C Xlib is still in ;;; 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. ;;; 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. ;; Note: all of the following is in the package XLIB.
(in-package :xlib) (in-package :xlib)
...@@ -86,12 +86,10 @@ ...@@ -86,12 +86,10 @@
(pushnew :clx *features*) (pushnew :clx *features*)
(pushnew :xlib *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-r4 *features*)
(pushnew :clx-mit-r5 *features*) (pushnew :clx-mit-r5 *features*)
(provide :clx)
(defparameter *protocol-major-version* 11.) (defparameter *protocol-major-version* 11.)
(defparameter *protocol-minor-version* 0) (defparameter *protocol-minor-version* 0)
...@@ -164,6 +162,20 @@ ...@@ -164,6 +162,20 @@
(deftype card4 () '(unsigned-byte 4)) (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 ; Note that we are explicitly using a different rgb representation than what
; is actually transmitted in the protocol. ; is actually transmitted in the protocol.
...@@ -334,12 +346,14 @@ ...@@ -334,12 +346,14 @@
(atom-id-map (make-hash-table :test (resource-id-map-test) (atom-id-map (make-hash-table :test (resource-id-map-test)
:size *atom-cache-size*) :size *atom-cache-size*)
:type hash-table) :type hash-table)
(extended-max-request-length 0 :type card32)
) )
(defun print-display-name (display stream) (defun print-display-name (display stream)
(declare (type (or null display) display)) (declare (type (or null display) display))
(cond (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) (write-string ":" stream)
(princ (display-display display) stream)) (princ (display-display display) stream))
(t (t
...@@ -371,7 +385,7 @@ ...@@ -371,7 +385,7 @@
(print-unreadable-object (drawable stream :type t) (print-unreadable-object (drawable stream :type t)
(print-display-name (drawable-display drawable) stream) (print-display-name (drawable-display drawable) stream)
(write-string " " 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) (def-clx-class (window (:include drawable) (:copier nil)
(:print-function print-drawable)) (:print-function print-drawable))
...@@ -441,27 +455,27 @@ ...@@ -441,27 +455,27 @@
(deftype xatom () '(or string symbol)) (deftype xatom () '(or string symbol))
(defconstant *predefined-atoms* (defconstant +predefined-atoms+
'#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP
:CARDINAL :COLORMAP :CURSOR :CARDINAL :COLORMAP :CURSOR
:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
:CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7
:DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE
:RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP
:RGB_BLUE_MAP :RGB_DEFAULT_MAP :RGB_BLUE_MAP :RGB_DEFAULT_MAP
:RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING
:VISUALID :WINDOW :WM_COMMAND :WM_HINTS :VISUALID :WINDOW :WM_COMMAND :WM_HINTS
:WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE
:WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS
:WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE
:END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y
:SUBSCRIPT_X :SUBSCRIPT_Y :SUBSCRIPT_X :SUBSCRIPT_Y
:UNDERLINE_POSITION :UNDERLINE_THICKNESS :UNDERLINE_POSITION :UNDERLINE_THICKNESS
:STRIKEOUT_ASCENT :STRIKEOUT_DESCENT :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT
:ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT
:POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE
:FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT
:WM_CLASS :WM_TRANSIENT_FOR)) :WM_CLASS :WM_TRANSIENT_FOR))
(deftype stringable () '(or string symbol)) (deftype stringable () '(or string symbol))
...@@ -471,19 +485,31 @@ ...@@ -471,19 +485,31 @@
(deftype timestamp () '(or null card32)) (deftype timestamp () '(or null card32))
(defconstant *bit-gravity-vector* (defconstant +bit-gravity-vector+
'#(:forget :north-west :north :north-east :west '#(:forget :north-west :north :north-east :west
:center :east :south-west :south :center :east :south-west :south
:south-east :static)) :south-east :static))
(deftype bit-gravity () (deftype bit-gravity ()
'(member :forget :north-west :north :north-east :west '(member :forget :north-west :north :north-east :west
:center :east :south-west :south :south-east :static)) :center :east :south-west :south :south-east :static))
(defconstant *win-gravity-vector* (defconstant +win-gravity-vector+
'#(:unmap :north-west :north :north-east :west '#(:unmap :north-west :north :north-east :west
:center :east :south-west :south :south-east :center :east :south-west :south :south-east
:static)) :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 () (deftype win-gravity ()
'(member :unmap :north-west :north :north-east :west '(member :unmap :north-west :north :north-east :west
...@@ -527,7 +553,7 @@ ...@@ -527,7 +553,7 @@
(server-state (allocate-gcontext-state) :type gcontext-state) (server-state (allocate-gcontext-state) :type gcontext-state)
(local-state (allocate-gcontext-state) :type gcontext-state) (local-state (allocate-gcontext-state) :type gcontext-state)
(plist nil :type list) ; Extension hook (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) (defun print-gcontext (gcontext stream depth)
...@@ -538,13 +564,13 @@ ...@@ -538,13 +564,13 @@
(write-string " " stream) (write-string " " stream)
(prin1 (gcontext-id gcontext) stream))) (prin1 (gcontext-id gcontext) stream)))
(defconstant *event-mask-vector* (defconstant +event-mask-vector+
'#(:key-press :key-release :button-press :button-release '#(:key-press :key-release :button-press :button-release
:enter-window :leave-window :pointer-motion :pointer-motion-hint :enter-window :leave-window :pointer-motion :pointer-motion-hint
:button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion :keymap-state :exposure :visibility-change :button-5-motion :button-motion :keymap-state :exposure :visibility-change
:structure-notify :resize-redirect :substructure-notify :substructure-redirect :structure-notify :resize-redirect :substructure-notify :substructure-redirect
:focus-change :property-change :colormap-change :owner-grab-button)) :focus-change :property-change :colormap-change :owner-grab-button))
(deftype event-mask-class () (deftype event-mask-class ()
'(member :key-press :key-release :owner-grab-button :button-press :button-release '(member :key-press :key-release :owner-grab-button :button-press :button-release
...@@ -557,11 +583,14 @@ ...@@ -557,11 +583,14 @@
(deftype event-mask () (deftype event-mask ()
'(or mask32 (clx-list event-mask-class))) '(or mask32 (clx-list event-mask-class)))
(defconstant *pointer-event-mask-vector* (defconstant +pointer-event-mask-vector+
'#(%error %error :button-press :button-release ;; the first two elements used to be '%error '%error (i.e. symbols,
:enter-window :leave-window :pointer-motion :pointer-motion-hint ;; and not keywords) but the vector is supposed to contain
:button-1-motion :button-2-motion :button-3-motion :button-4-motion ;; keywords, so I renamed them -dan 2004.11.13
:button-5-motion :button-motion :keymap-state)) '#(:%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 () (deftype pointer-event-mask-class ()
'(member :button-press :button-release '(member :button-press :button-release
...@@ -572,10 +601,10 @@ ...@@ -572,10 +601,10 @@
(deftype pointer-event-mask () (deftype pointer-event-mask ()
'(or mask32 (clx-list pointer-event-mask-class))) '(or mask32 (clx-list pointer-event-mask-class)))
(defconstant *device-event-mask-vector* (defconstant +device-event-mask-vector+
'#(:key-press :key-release :button-press :button-release :pointer-motion '#(:key-press :key-release :button-press :button-release :pointer-motion
:button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion)) :button-5-motion :button-motion))
(deftype device-event-mask-class () (deftype device-event-mask-class ()
'(member :key-press :key-release :button-press :button-release :pointer-motion '(member :key-press :key-release :button-press :button-release :pointer-motion
...@@ -585,9 +614,9 @@ ...@@ -585,9 +614,9 @@
(deftype device-event-mask () (deftype device-event-mask ()
'(or mask32 (clx-list device-event-mask-class))) '(or mask32 (clx-list device-event-mask-class)))
(defconstant *state-mask-vector* (defconstant +state-mask-vector+
'#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
:button-1 :button-2 :button-3 :button-4 :button-5)) :button-1 :button-2 :button-3 :button-4 :button-5))
(deftype modifier-key () (deftype modifier-key ()
'(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
...@@ -598,12 +627,12 @@ ...@@ -598,12 +627,12 @@
(deftype state-mask-key () (deftype state-mask-key ()
'(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
(defconstant *gcontext-components* (defconstant +gcontext-components+
'(:function :plane-mask :foreground :background '(:function :plane-mask :foreground :background
:line-width :line-style :cap-style :join-style :fill-style :line-width :line-style :cap-style :join-style :fill-style
:fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
:exposures :clip-x :clip-y :clip-mask :dash-offset :dashes :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
:arc-mode)) :arc-mode))
(deftype gcontext-key () (deftype gcontext-key ()
'(member :function :plane-mask :foreground :background '(member :function :plane-mask :foreground :background
...@@ -613,14 +642,16 @@ ...@@ -613,14 +642,16 @@
:arc-mode)) :arc-mode))
(deftype event-key () (deftype event-key ()
'(member :key-press :key-release :button-press :button-release :motion-notify '(or (member :key-press :key-release :button-press :button-release
:enter-notify :leave-notify :focus-in :focus-out :keymap-notify :motion-notify :enter-notify :leave-notify :focus-in :focus-out
:exposure :graphics-exposure :no-exposure :visibility-notify :keymap-notify :exposure :graphics-exposure :no-exposure
:create-notify :destroy-notify :unmap-notify :map-notify :map-request :visibility-notify :create-notify :destroy-notify :unmap-notify
:reparent-notify :configure-notify :gravity-notify :resize-request :map-notify :map-request :reparent-notify :configure-notify
:configure-request :circulate-notify :circulate-request :property-notify :gravity-notify :resize-request :configure-request :circulate-notify
:selection-clear :selection-request :selection-notify :circulate-request :property-notify :selection-clear
:colormap-notify :client-message :mapping-notify)) :selection-request :selection-notify :colormap-notify :client-message
:mapping-notify)
(satisfies extension-event-key-p)))
(deftype error-key () (deftype error-key ()
'(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
...@@ -629,11 +660,11 @@ ...@@ -629,11 +660,11 @@
(deftype draw-direction () (deftype draw-direction ()
'(member :left-to-right :right-to-left)) '(member :left-to-right :right-to-left))
(defconstant *boole-vector* (defconstant +boole-vector+
'#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
#.boole-andc1 #.boole-2 #.boole-xor #.boole-ior #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
#.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
#.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
(deftype boole-constant () (deftype boole-constant ()
`(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
...@@ -802,7 +833,7 @@ ...@@ -802,7 +833,7 @@
(let ((predicate (xintern type '-equal)) (let ((predicate (xintern type '-equal))
(id (xintern type '-id)) (id (xintern type '-id))
(dpy (xintern type '-display))) (dpy (xintern type '-display)))
(if (member type *clx-cached-types*) (if (member type +clx-cached-types+)
`(within-definition (,type make-mumble-equal) `(within-definition (,type make-mumble-equal)
(declaim (inline ,predicate)) (declaim (inline ,predicate))
(defun ,predicate (a b) (eq a b))) (defun ,predicate (a b) (eq a b)))
...@@ -824,10 +855,10 @@ ...@@ -824,10 +855,10 @@
;;; Converts from keyword-lists to integer and back ;;; Converts from keyword-lists to integer and back
;;; ;;;
(defun encode-mask (key-vector key-list key-type) (defun encode-mask (key-vector key-list key-type)
;; KEY-VECTOR is a vector containg bit-position keywords. The position of the ;; KEY-VECTOR is a vector containg bit-position keywords. The
;; keyword in the vector indicates its bit position in the resulting mask ;; position of the keyword in the vector indicates its bit position
;; KEY-LIST is either a mask or a list of KEY-TYPE ;; in the resulting mask. KEY-LIST is either a mask or a list of
;; Returns NIL when KEY-LIST is not a list or mask. ;; KEY-TYPE Returns NIL when KEY-LIST is not a list or mask.
(declare (type (simple-array keyword (*)) key-vector) (declare (type (simple-array keyword (*)) key-vector)
(type (or mask32 list) key-list)) (type (or mask32 list) key-list))
(declare (clx-values (or mask32 null))) (declare (clx-values (or mask32 null)))
...@@ -858,7 +889,7 @@ ...@@ -858,7 +889,7 @@
(defun encode-event-mask (event-mask) (defun encode-event-mask (event-mask)
(declare (type event-mask event-mask)) (declare (type event-mask event-mask))
(declare (clx-values mask32)) (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))) (x-type-error event-mask 'event-mask)))
(defun make-event-mask (&rest keys) (defun make-event-mask (&rest keys)
...@@ -866,18 +897,18 @@ ...@@ -866,18 +897,18 @@
;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
(declare (type (clx-list event-mask-class) keys)) (declare (type (clx-list event-mask-class) keys))
(declare (clx-values mask32)) (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) (defun make-event-keys (event-mask)
;; This is only defined for core events. ;; This is only defined for core events.
(declare (type mask32 event-mask)) (declare (type mask32 event-mask))
(declare (clx-values (clx-list event-mask-class))) (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) (defun encode-device-event-mask (device-event-mask)
(declare (type device-event-mask device-event-mask)) (declare (type device-event-mask device-event-mask))
(declare (clx-values mask32)) (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) 'device-event-mask-class)
(x-type-error device-event-mask 'device-event-mask))) (x-type-error device-event-mask 'device-event-mask)))
...@@ -885,29 +916,29 @@ ...@@ -885,29 +916,29 @@
(declare (type modifier-mask modifier-mask)) (declare (type modifier-mask modifier-mask))
(declare (clx-values mask16)) (declare (clx-values mask16))
(or (and (eq modifier-mask :any) #x8000) (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))) (x-type-error modifier-mask 'modifier-mask)))
(defun encode-state-mask (state-mask) (defun encode-state-mask (state-mask)
(declare (type (or mask16 (clx-list state-mask-key)) state-mask)) (declare (type (or mask16 (clx-list state-mask-key)) state-mask))
(declare (clx-values mask16)) (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))))) (x-type-error state-mask '(or mask16 (clx-list state-mask-key)))))
(defun make-state-mask (&rest keys) (defun make-state-mask (&rest keys)
;; Useful for constructing modifier-mask, state-mask. ;; Useful for constructing modifier-mask, state-mask.
(declare (type (clx-list state-mask-key) keys)) (declare (type (clx-list state-mask-key) keys))
(declare (clx-values mask16)) (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) (defun make-state-keys (state-mask)
(declare (type mask16 state-mask)) (declare (type mask16 state-mask))
(declare (clx-values (clx-list state-mask-key))) (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) (defun encode-pointer-event-mask (pointer-event-mask)
(declare (type pointer-event-mask pointer-event-mask)) (declare (type pointer-event-mask pointer-event-mask))
(declare (clx-values mask32)) (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) 'pointer-event-mask-class)
(x-type-error pointer-event-mask 'pointer-event-mask))) (x-type-error pointer-event-mask 'pointer-event-mask)))
;;; -*- 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))
...@@ -20,6 +20,9 @@ ...@@ -20,6 +20,9 @@
;;; Created 04/09/87 14:30:41 by LaMott G. OREN ;;; 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) (in-package :xlib)
(export '(display-listen (export '(display-listen
......
...@@ -20,6 +20,9 @@ ...@@ -20,6 +20,9 @@
;;; Created 07/15/87 by LaMott G. OREN ;;; 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) (in-package :xlib)
(defparameter *request-parameters* (make-array (length *request-names*))) (defparameter *request-parameters* (make-array (length *request-names*)))
...@@ -76,7 +79,7 @@ ...@@ -76,7 +79,7 @@
(string8 (string8
(format t " Bytes:~%~v@t" margin) (format t " Bytes:~%~v@t" margin)
(dotimes (k (- length (- j start))) (dotimes (k (- length (- j start)))
(format t "~a" (int-char (card8-get j))) (format t "~a" (code-char (card8-get j)))
(incf j))) (incf j)))
(otherwise (otherwise
(format t " Bytes:~%~v@t" margin) (format t " Bytes:~%~v@t" margin)
......
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*- ;;; -*- 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 (defstruct event
key ; Event key key ; Event key
......
...@@ -18,20 +18,23 @@ ...@@ -18,20 +18,23 @@
;;; express or implied warranty. ;;; 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) (in-package :xlib)
(defun list-missing-keysyms () (defun list-missing-keysyms ()
;; Lists explorer characters which have no keysyms ;; Lists explorer characters which have no keysyms
(dotimes (i 256) (dotimes (i 256)
(unless (character->keysyms (int-char i)) (unless (character->keysyms (code-char i))
(format t "~%(define-keysym ~@c ~d)" (int-char i) i)))) (format t "~%(define-keysym ~@c ~d)" (code-char i) i))))
(defun list-multiple-keysyms () (defun list-multiple-keysyms ()
;; Lists characters with more than one keysym ;; Lists characters with more than one keysym
(dotimes (i 256) (dotimes (i 256)
(when (cdr (character->keysyms (int-char i))) (when (cdr (character->keysyms (code-char i)))
(format t "~%Character ~@c [~d] has keysyms" (int-char i) i) (format t "~%Character ~@c [~d] has keysyms" (code-char i) i)
(dolist (keysym (character->keysyms (int-char i))) (dolist (keysym (character->keysyms (code-char i)))
(format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym))))))
(defun check-lowercase-keysyms () (defun check-lowercase-keysyms ()
...@@ -52,7 +55,7 @@ ...@@ -52,7 +55,7 @@
char char
(and lowercase (ldb (byte 8 8) lowercase)) (and lowercase (ldb (byte 8 8) lowercase))
(and lowercase (ldb (byte 8 0) 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 8) (char-int should-be))
(ldb (byte 8 0) (char-int should-be)) (ldb (byte 8 0) (char-int should-be))
should-be))) should-be)))
......
...@@ -32,6 +32,9 @@ ...@@ -32,6 +32,9 @@
;;; Created 09/14/87 by LaMott G. OREN ;;; 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) (in-package :xlib)
(eval-when (load eval) (eval-when (load eval)
......
...@@ -20,6 +20,9 @@ ...@@ -20,6 +20,9 @@
;;; Created 04/09/87 14:30:41 by LaMott G. OREN ;;; 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) (in-package :xlib)
(export '(display-root (export '(display-root
...@@ -145,12 +148,13 @@ ...@@ -145,12 +148,13 @@
;; Returns a list of windows in the order that they are printed. ;; Returns a list of windows in the order that they are printed.
(declare (arglist window) (declare (arglist window)
(type window window) (type window window)
(values (list window))) (clx-values (list window)))
(let ((props (mapcar #'(lambda (prop) (let ((props (mapcar #'(lambda (prop)
(multiple-value-bind (data type format) (multiple-value-bind (data type format)
(get-property window prop) (get-property window prop)
(case type (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 prop format type data)))
(list-properties window))) (list-properties window)))
(result (list window))) (result (list window)))
......
...@@ -18,19 +18,275 @@ ...@@ -18,19 +18,275 @@
;;; ;;;
;;; Franz Incorporated provides this software "as is" without express or ;;; Franz Incorporated provides this software "as is" without express or
;;; implied warranty. ;;; 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 ;;; #+ features used in this file
;;; clx-ansi-common-lisp
;;; lispm
;;; genera
;;; minima
;;; lucid
;;; lcl3.0
;;; apollo
;;; kcl
;;; ibcl
;;; excl
;;; CMU ;;; 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) (export 'load-clx)
#+clx-ansi-common-lisp
(common-lisp:in-package :common-lisp-user) (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 ;;;; Compile CLX
...@@ -54,6 +310,54 @@ ...@@ -54,6 +310,54 @@
;;; out correctly, but you may have to explicitly give the source and ;;; out correctly, but you may have to explicitly give the source and
;;; binary file types. ;;; 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 (defun compile-clx (&optional
(source-pathname-defaults "") (source-pathname-defaults "")
(binary-pathname-defaults "") (binary-pathname-defaults "")
...@@ -74,6 +378,7 @@ ...@@ -74,6 +378,7 @@
:version (pathname-version source-path))) :version (pathname-version source-path)))
(binary-path (merge-pathnames binary-pathname-defaults (binary-path (merge-pathnames binary-pathname-defaults
path)) path))
#+clx-ansi-common-lisp (*compile-verbose* t)
(*load-verbose* t)) (*load-verbose* t))
;; Make sure source-path and binary-path file types are distinct so ;; Make sure source-path and binary-path file types are distinct so
...@@ -87,28 +392,76 @@ ...@@ -87,28 +392,76 @@
(format t "~&;;; Default paths: ~s ~s~%" source-path binary-path) (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) (labels ((compile-lisp (filename)
(let ((source (merge-pathnames filename source-path)) (let ((source (merge-pathnames filename source-path))
(binary (merge-pathnames filename binary-path))) (binary (merge-pathnames filename binary-path)))
;; If the source and binary pathnames are the same, ;; If the source and binary pathnames are the same,
;; then don't supply an output file just to be sure ;; then don't supply an output file just to be sure
;; compile-file defaults correctly. ;; compile-file defaults correctly.
#+(or kcl ibcl) (load source)
(if (equal source binary) (if (equal source binary)
(compile-file source) (compile-file source)
(compile-file source :output-file binary)) (compile-file source :output-file binary))
binary)) binary))
(compile-and-load (filename) (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. ;; Now compile and load all the files.
;; Defer compiler warnings until everything's compiled, if possible. ;; 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") (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 "depdefs")
(compile-and-load "clx") (compile-and-load "clx")
(compile-and-load "dependent") (compile-and-load "dependent")
#+excl (compile-and-load "exclcmac") ; these are just macros
(compile-and-load "macros") ; these are just macros (compile-and-load "macros") ; these are just macros
(compile-and-load "bufmac") ; these are just macros (compile-and-load "bufmac") ; these are just macros
(compile-and-load "buffer") (compile-and-load "buffer")
...@@ -147,6 +500,7 @@ ...@@ -147,6 +500,7 @@
;;; (LOAD <clx-defsystem-file>) ;;; (LOAD <clx-defsystem-file>)
;;; (LOAD-CLX <binary-specific-clx-directory>) ;;; (LOAD-CLX <binary-specific-clx-directory>)
#-(or lispm allegro Minima)
(defun load-clx (&optional (binary-pathname-defaults "") (defun load-clx (&optional (binary-pathname-defaults "")
&key (macrosp nil)) &key (macrosp nil))
...@@ -167,10 +521,13 @@ ...@@ -167,10 +521,13 @@
(load binary)))) (load binary))))
(load-binary "package") (load-binary "package")
#+(or lucid kcl ibcl cmu) (clx-foreign-files binary-path)
#+excl (load-binary "excldep")
(load-binary "depdefs") (load-binary "depdefs")
(load-binary "clx") (load-binary "clx")
(load-binary "dependent") (load-binary "dependent")
(when macrosp (when macrosp
#+excl (load-binary "exclcmac")
(load-binary "macros") (load-binary "macros")
(load-binary "bufmac")) (load-binary "bufmac"))
(load-binary "buffer") (load-binary "buffer")
...@@ -188,3 +545,27 @@ ...@@ -188,3 +545,27 @@
(load-binary "image") (load-binary "image")
(load-binary "resource") (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+)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment