mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-20 03:30:57 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'develop' into deprecate-short-longflags

Browse source
This commit is contained in:
MatthewRock 2016-09-17 23:01:52 +02:00
commit bd9c88b440
243 changed files with 6648 additions and 64559 deletions
Download patch file Download diff file Expand all files Collapse all files

9
.gitignore vendored
View file

@ -39,7 +39,7 @@ msvc/lsp/*.[ch]
BUILD-STAMP
MODULES
Makefile
/Makefile
src/autom4te.cache
src/config.log
@ -62,3 +62,10 @@ regressions/eformat-tests/*.txt
/src/doc/new-doc/new-doc.fts
/src/doc/new-doc/new-doc.cf
/src/doc/new-doc/new-doc.cfs
/examples/ecl_qt/qt/ecl_qtdemo
/examples/ecl_qt/hello-lisp-system--all-systems.fasb
/examples/ecl_qt/lisp-envi.a
/examples/ecl_qt/qt/.qmake.stash
/examples/ecl_qt/qt/Makefile
*fasc
*.orig

47
CHANGELOG
View file

@ -23,30 +23,50 @@
have a C compiler accessible to ECL, you may use
(ext:install-c-compiler) to switch back to the Lisp-to-C compiler.
- Before issuing make check on the package package developer has to
- Before issuing =make check= on the package package developer has to
install ECL on the preferred destination (specified with "--prefix"
parameter given to configure script).
* Pending changes since 16.1.2
** API changes
- make-random-state: fix problem with simple-vectors
The correct initialization types for =make-random-state= are:
=(OR RANDOM-STATE (MEMBER T NIL))=
=(OR RANDOM-STATE FIXNUM (MEMBER T NIL))=.
Initializing a random state with an appropriate array (element type and
arity) or with a fixnum is now possible only with the #$ reader macro.
arity dependent on platform) is also possible.
- ext:random-state-array: new extension for random-states. Usage:
=(ext:random-state-array random-state)=.
- ext:terminate-process: new extension for external processes. Usage:
=(ext:terminate-process process)= with a second, optional boolean argument
whenever termination should be forced or not.
** Enhancements
- ASDF has been upgraded to version 3.1.7
- Bundled CLX has been purged
Lately I've fixed ECL support on portable CLX maintained by sharplispers on
https://github.com/sharplispers/clx (available via QuickLisp).
- Initial port for the Haiku platform
The port is done by Kacper Kasper's work, one of Haiku developers. Threads
are not supported yet.
- Refactored ECL internal tests framework
Tests in =src/tests= are now asdf-loadable (with =load-source-op=) and
divided into test suites. =make check= target runs all regression and
feature tests which aren't supposed to fail.
- Removed 15000 lines of obsolete code
Files not included in the buildsystem but lingering in the codebase or
options failing to build. All info is added in the new documentation in
options failing to build. All info is added in the new documentation in the
section "Removed interfaces".
- Improved man page and help output.
Man page now contains up-to-date list of flags, as well
as explanation of flag's behavior.
Man page now contains up-to-date list of flags, as well as explanation of
flag's behavior.
- Indented C/C++ code to follow emacs's gnu C style
This is a first step towards coding standards in the
@ -57,6 +77,15 @@ appropraite documentation section (new-doc).
Function was obfuscated with ifdefs with non-even pairs of =#\{= and =#\}=.
** Issues fixed
- ECL builds now succesfully with `--with-ieee-fp=no' option
- ext:file-stream-fd
Doesn't cause an internal-error if fed with not a file-stream (signals a
SIMPLE-TYPE-ERROR condtition).
- stable-sort bugfix and improvement in speed
Adapted from SBCL by Diogo Franco.
- typep: accept * type specifier as abbreviation of t as described in
'2.4.3 Type Specifiers' of the specification.
@ -72,6 +101,8 @@ Until now #$ reader macro accepted simple vectors as an argument, what lead
to bugs if vector didn't match specific requirements like the element type
or the arity. Now we sanitize this.
- make-load-form: provide implementation for random-state objects
- thread fix on msvc: on windows importing thread was closing the thread
handler so the thread wakeup wasn't working because the handler is not more valid.

1
LICENSE
View file

@ -29,7 +29,6 @@
and the directories
contrib/ ; User contributed extensions
examples/ ; Examples for the ECL usage
src/clx/ ; portable CLX library from Telent
Look the precise copyright of these extensions in the corresponding
files.

2
Makefile.in
View file

@ -53,7 +53,7 @@ libdir=@libdir@
TAR_CONTENTS=Makefile.in README.md LGPL ANNOUNCEMENT LICENSE doc \
configure src/c src/cmp src/clos src/CHANGELOG src/lsp src/doc \
src/h src/gmp src/config* src/install.sh src/Makefile.in \
src/util contrib/ src/clx src/gc src/*.in src/*.m4 src/gabriel \
src/util contrib/ src/gc src/*.in src/*.m4 src/gabriel \
src/tests/Makefile.in msvc examples
# ==================== Utility Programs for the Build ====================

237
contrib/asdf/README.md
View file

@ -8,37 +8,56 @@ ASDF is the de facto standard build facility for Common Lisp.
Your Lisp implementation probably contains a copy of ASDF,
which you can load using `(require "asdf")`.
If you come from the C/C++ world, the function ASDF covers a bit of what
each of make, autoconf, dlopen and libc do for C programs:
If you come from the C/C++ world, ASDF covers a bit of what each of
`make`, `autoconf`, `dlopen` and `libc` do for C programs:
it orchestrates the compilation and dependency management,
handles some of the portability issues, dynamically finds and loads code,
and offers some portable system access.
Except everything is different in Common Lisp, and ultimately much simpler,
though it requires acquiring some basic concepts.
Importantly, ASDF builds all software in the current Lisp image.
and offers some portable system access library.
Except everything is different in Common Lisp, and ultimately much simpler overall,
though it does require acquiring some basic concepts
that do not exactly match those of the C and Unix world.
Importantly, ASDF builds all software in the current Lisp image,
as opposed to building software into separate processes.
Where to find ASDF?
-------------------
ASDF's home page contains more information and additional links, and can be found at:
<https://common-lisp.net/project/asdf/>
The one and only official source control repository is at:
<https://gitlab.common-lisp.net/asdf/asdf>
The one and only official bug tracker is at:
<https://bugs.launchpad.net/asdf>
How to use ASDF?
----------------
To use ASDF, read our manual:
<http://common-lisp.net/project/asdf/asdf.html>
http://common-lisp.net/project/asdf/asdf.html
The first few sections, Loading ASDF, Configuring ASDF and Using ASDF,
The first few sections,
[Loading ASDF](https://common-lisp.net/project/asdf/asdf/Loading-ASDF.html),
[Configuring ASDF](https://common-lisp.net/project/asdf/asdf/Configuring-ASDF.html) and
[Using ASDF](https://common-lisp.net/project/asdf/asdf/Using-ASDF.html)
will get you started as a simple user.
If you want to define your own systems, further read the section
Defining systems with defsystem.
The manual is also in the doc/ subdirectory, and can be prepared with:
If you want to define your own systems, further read the section
[Defining systems with defsystem](https://common-lisp.net/project/asdf/asdf/Defining-systems-with-defsystem.html)
The manual is also in the [doc/](doc/) subdirectory, and can be prepared with:
make doc
ASDF 3 now includes an extensive runtime support library:
UIOP, the Utilities for Implementation- and OS- Portability.
Its documentation unhappily lies mainly in the source code and docstrings.
See [`uiop/README.md`](uiop/README.md) for an introduction.
[UIOP, the Utilities for Implementation- and OS- Portability](uiop/).
Its documentation unhappily lies mainly in the source code and its docstrings.
See [uiop/README.md](uiop/README.md) for an introduction.
More information and additional links can be found on ASDF's home page at:
http://common-lisp.net/project/asdf/
Quick Start
@ -49,13 +68,16 @@ Just use `(require "asdf")` to load your implementation-provided ASDF.
If it is recent enough (3.0 or later, check its `(asdf:asdf-version)`),
then it will automatically upgrade to the ASDF provided as source code,
assuming the source code in under a path registered by the source-registry.
If it isn't present or isn't recent enough, we recommend you install a recent
ASDF release into your implementation using [tools/install-asdf.lisp](tools/install-asdf.lisp)
Building and testing it
-----------------------
Building it
-----------
First, make sure ASDF is checked out under a path registered by the source-registry,
if that isn't the case yet (see the manual). One place would be:
if that isn't the case yet (see the [manual](http://common-lisp.net/project/asdf/asdf.html)).
One place would be:
~/.local/share/common-lisp/source/asdf/
@ -64,127 +86,196 @@ or, assuming your implementation provides ASDF 3.1 or later:
~/common-lisp/asdf/
If you cloned our git repository, bootstrap a copy of build/asdf.lisp with:
If you cloned our git repository, rather than extracted a tarball,
bootstrap a copy of `build/asdf.lisp` with:
make
Testing it
----------
Before you may run tests, you need a few CL libraries.
The simplest way to get them is as follows, but read below:
make ext
The above make target uses `git submodule update --init` to download
_NOTA BENE_: You may also need to run `make ext` again
after you `git pull` or switch branch, to update the `ext/` directory.
This is unhappily not automatic.
If for some reason tests fail, particularly due to an error
compiling, loading or running a library, then run `make ext` and try again.
The above `make` target uses `git submodule update --init` to download
all these libraries using git. If you don't otherwise maintain your
own set of carefully controlled CL libraries, that's what you want to use.
However, if you do maintain your own set of carefully controlled CL libraries
then you will want to use whichever tools you use (e.g. quicklisp, clbuild,
or your own scripts around git) to download these libraries:
alexandria, closer-mop, cl-ppcre, fare-mop, fare-quasiquote, fare-utils,
inferior-shell, lisp-invocation, named-readtables, optima.
However, it is only available if you have a git checkout of ASDF;
not if you used a tarball.
If you use a tarball or otherwise do maintain your own set
of carefully controlled CL libraries then you will want to use whichever tools
you use (e.g. `quicklisp`, `clbuild`, or your own scripts around `git`)
to download these libraries:
`alexandria`, `asdf-encodings`, `cl-launch`, `closer-mop`, `cl-ppcre`,
`cl-scripting`, `fare-mop`, `fare-quasiquote`, `fare-utils`, `inferior-shell`,
`lisp-invocation`, `named-readtables`, `optima`.
If you are a CL developer, you may already have them, or may want
to use your own tools to download a version of them you control.
If you use Quicklisp, you may let Quicklisp download those you don't have.
In these cases, you do NOT want to use
However, if you want to let ASDF download known-working versions
If you use [Quicklisp](https://www.quicklisp.org/), you may let
Quicklisp download those you don't have.
In these cases, you may NOT want to use the git submodules from `make ext`.
Otherwise, if you want to let ASDF download known-working versions
of its dependencies, you can do it with:
make ext
To run all the tests on your favorite Lisp implementation $L,
choose your most elaborate installed system $S, and try:
ASDF by default uses Clozure Common Lisp (CCL) to run the scripts that orchestrate its tests.
By defining and exporting the variable `LISP` to be one of `ccl`, `sbcl` or `allegro`, you
can have it use an alternate Common Lisp implementation instead.
Install CCL (respectively SBCL or Allegro) and make sure an executable called
`ccl` (respectively `sbcl` or `alisp`) is in your `PATH`,
or that you export a variable `CCL` (respectively `SBCL` or `ALLEGRO`)
that points to the executable.
To use a further Common Lisp implementation, suitably edit the script
[`tools/asdf-tools`](tools/asdf-tools),
or, on Windows, the batch file [`tools/asdf-tools.bat`](tools/asdf-tools.bat).
(Note that as of SBCL 1.2.13, we recommend against using SBCL on Windows.)
Once you have all the required libraries and the asdf-tools script can find
a suitable Common Lisp implementation, you may run all the tests
on a given Common Lisp implementation `$L`, with your favorite installed system `$S`, using:
make t u l=$L s=$S
To run only the regression test scripts, try simply:
Debugging tip
-------------
make l=$L test-scripts
To load ASDF in such a way that M-. will work, install the source code, and run:
Note that an executable `build/asdf-tools` is being built the first time you test ASDF.
When you update ASDF, via e.g. `git pull` or a branch switch, you may have to update it, with:
make build-asdf-tools
The reason this is not done automatically everytime is because
building it depends on a working ASDF;
but when you're modifying ASDF and testing it, you cannot rely on a working ASDF:
indeed, a developer may not only make mistakes, but may deliberately
introduce or re-introduce bugs at some place to test code in another place.
Debugging it
------------
To interactively debug ASDF, you may load it in such a way that `M-.` will work,
by installing the source code, and running:
(asdf:load-system :uiop) ;; loading uiop is simple
(map () 'load ;; loading asdf/defsystem is tricky
(mapcar 'asdf:component-pathname
(asdf::required-components :asdf/defsystem :keep-component 'asdf:cl-source-file)))
Note that the above can be adapted in a general recipe to get all the files in a system, in order.
To also have the files in systems it transitively depends on, add the `:other-systems t` keyword
argument to the call to `asdf::required-components`.
To interactively use the `asdf-tools`, you need to either have
all its dependencies installed and configured.
If you're using them through the `ext/` directory and `make ext`,
then you may need to emulate what the script in [tools/asdf-tools](tools/asdf-tools) does
with respect to initializing the source-registry.
Note that it also declares a system for `cl-launch/dispatch`;
you can either do something similar, or expand the source for `cl-launch` with
`make -C ext/cl-launch source` so `cl-launch.asd` will be created.
What has changed?
-----------------
You can consult the `debian/changelog` for an overview of the
You can consult the [doc/Changelog](doc/Changelog) for an overview of the
significant changes in each release, and
the `git log` for a detailed description of each commit.
How do I navigate this source directory?
----------------------------------------
How do I navigate this source tree?
-----------------------------------
* `asdf.asd`
* [asdf.asd](asdf.asd)
* The system definition for building ASDF with ASDF.
* `*.lisp`
* The source code files for asdf/defsystem.
See asdf.asd for the order in which they are loaded.
* The source code files for `asdf/defsystem`.
See [asdf.asd](asdf.asd) for the order in which they are loaded.
* `uiop/`
* [uiop/](uiop/)
* Utilities of Implementation- and OS- Portability,
the portability layer of ASDF. It has its own `README`,
the portability layer of ASDF. It has its own [README](uiop/README.md),
and functions all have docstrings.
* `Makefile`
* a minimal Makefile for bootstrapping purposes.
Most of the logic is in the asdf-tools system
* [Makefile](Makefile)
* a minimal `Makefile` for bootstrap and development purposes.
Most of the logic is in the [asdf-tools](tools/asdf-tools.asd) system below.
* `tools/`
* Some scripts to help ASDF users
* `load-asdf.lisp` -- a build script to load, configure and use ASDF
* `install-asdf.lisp` -- replace and update an implementation's ASDF
* `cl-source-registry-cache.lisp` -- update a cache for the source-registry
* [tools/](tools/)
* `asdf-tools`, a system to build, test and release ASDF. It includes:
* [asdf-tools](tools/asdf-tools) -- a shell script to run it as a shell command.
* [asdf-tools.bat](tools/asdf-tools.bat) -- a Windows batch file to run the above.
* [asdf-tools.asd](tools/asdf-tools.asd) -- system definition for asdf-tools
* `*.lisp` -- the source code for the `asdf-tools` system, except for the few files below.
* also a couple scripts to help ASDF users:
* [load-asdf.lisp](tools/load-asdf.lisp) -- a working example script to load, configure and use ASDF in a self-contained project
* [install-asdf.lisp](install-asdf.lisp) -- replace and update an implementation's ASDF
* [cl-source-registry-cache.lisp](cl-source-registry-cache.lisp) -- update a cache for the source-registry as a standalone script.
* `build.xcvb`
* [build.xcvb](build.xcvb)
* The system definition for building ASDF with XCVB.
It hasn't been tested or maintained for years and has bitrotten.
* `version.lisp-expr`
* [version.lisp-expr](version.lisp-expr)
* The current version. Bumped up every time the code changes, using:
./tools/asdf-builder bump
make bump
* `doc/`
* [doc/](doc/)
* documentation for ASDF, including:
* `index.html` -- the web page for http://common-lisp.net/project/asdf/
* `asdf.texinfo` -- our manual
* `Makefile` -- how to build the manual
* `cclan.png` `lisp-logo120x80.png` `style.css` `favicon.ico`
-- auxiliaries of `index.html`
* [index.html](doc/index.html) -- the web page for <http://common-lisp.net/project/asdf/>
* [asdf.texinfo](doc/asdf.texinfo) -- our manual
* [Makefile](doc/Makefile) -- how to build the manual
* [cclan.png](doc/cclan.png) [lisp-logo120x80.png](doc/lisp-logo120x80.png)
[style.css](doc/style.css) [favicon.ico](doc/favicon.ico)
-- auxiliaries of [index.html](doc/index.html)
* `test/`
* [test/](test/)
* regression test scripts (and ancillary files) for developers to check
that they don't unintentionally break any of the functionality of ASDF.
Far from covering all of ASDF.
Far from covering all of ASDF, but a good start.
* `contrib/`
* a few contributed files that show case how to use ASDF.
* [contrib/](contrib/)
* a few contributed files that show case how to use ASDF
or help with debugging it or debugging programs that use it.
* `debian/`
files for packaging on debian, ubuntu, etc.
* [debian/](debian/)
* files for packaging on Debian, Ubuntu, etc.
(now only present in the debian branch).
* `build/`
* where the Makefile and asdf-tools store their output files, including
* [build/](build/)
* where the `Makefile` and `asdf-tools` store their output files, including
* `asdf.lisp` -- the current one-file deliverable of ASDF
* `asdf-XXX.lisp` -- for upgrade test purposes, old versions
* `results/` -- logs of tests that have been run
* `fasls/` -- output files while running tests.
* `ext/`
* [ext/](ext/)
* external dependencies, that can be populated with `make ext`
or equivalently with `git submodule update --init`.
Depopulate it with `make noext`.
* `README`
* [README.md](README.md)
* this file
* `TODO`
* [TODO](TODO)
* plenty of ideas for how to further improve ASDF.
Last updated Thursday, September 11th, 2014.
Last updated Tuesday, January 12th, 2016.

890
contrib/asdf/asdf.lisp
View file

File diff suppressed because it is too large Load diff

1390
contrib/asdf/asdf.texinfo
View file

File diff suppressed because it is too large Load diff

7
contrib/profile/profile.lisp
View file

@ -246,10 +246,6 @@ extern ECL_API size_t GC_get_total_bytes();
(dolist (name names)
(etypecase name
(symbol (funcall function name))
(list
(legal-fun-name-or-type-error name)
;; Then we map onto it.
(funcall function name))
(string (let ((package (si:coerce-to-package name)))
(do-symbols (symbol package)
(when (eq (symbol-package symbol) package)
@ -259,7 +255,8 @@ extern ECL_API size_t GC_get_total_bytes();
(funcall function symbol))
(let ((setf-name `(setf ,symbol)))
(when (fboundp setf-name)
(funcall function setf-name)))))))))
(funcall function setf-name)))))))
(t (warn "ignoring invalid argument: ~S" name))))
(values))
;;; Profile the named function, which should exist and not be profiled

4
contrib/sockets/sockets.lisp
View file

@ -1430,6 +1430,10 @@ ecl_make_stream_from_fd(#0,#1,(enum ecl_smmode)#2,
"#define NETDB_SUCCESS 0"
)
#+:haiku
(clines
"#define ESOCKTNOSUPPORT ENOTSUP")
(Clines
"#ifndef NETDB_INTERNAL"
"#define NETDB_INTERNAL 0"

64
doc/Makefile Normal file
View file

@ -0,0 +1,64 @@
XMLTO = xmlto
XSLTPROC = xsltproc
GEN_XMLFILES= tmp/COPYING.GFDL.xml
XMLFILES= ecl.xml bibliography.xmlf clos.xmlf compiler.xmlf \
declarations.xmlf ecldev.xmlf \
internals.xmlf interpreter.xmlf preface.xmlf \
io.xmlf mp.xmlf asdf.xmlf os.xmlf pde.xmlf \
copyright.xmlf ffi.xmlf ref_os.xmlf \
uffi/ref_primitive.xml uffi/ref_aggregate.xml uffi/ref_object.xml \
uffi/ref_string.xml uffi/ref_func_libr.xml \
mp.xmlf ref_mp.xmlf memory.xmlf ref_memory.xmlf \
mop.xmlf embed.xmlf ref_embed.xmlf signals.xmlf \
ansi_arrays.xml ansi_overview.xml \
ansi_characters.xml ansi_packages.xml ansi_conses.xml \
ansi_printer.xml ansi_data_flow.xml ansi_reader.xml \
ansi_environment.xml ansi_sequences.xml ansi_evaluation.xml \
ansi_streams.xml ansi_filenames.xml ansi_strings.xml \
ansi_files.xml ansi_structures.xml ansi_hash_tables.xml \
ansi_symbols.xml ansi_numbers.xml ansi_system_construction.xml \
ansi_objects.xml ansi_types.xml \
ref_c_evaluation.xml ref_c_data_flow.xml ref_c_symbols.xml \
ref_c_numbers.xml ref_c_characters.xml ref_c_strings.xml \
ref_c_conses.xml ref_c_hash_tables.xml ref_c_sequences.xml \
ref_c_filenames.xml ref_c_packages.xml ref_c_printer.xml \
ref_c_system_construction.xml ref_c_environment.xml \
ref_c_objects.xml ref_c_conditions.xml ref_c_structures.xml \
ref_signals.xmlf ref_c_arrays.xml $(GEN_XMLFILES)
HTML_XSLFILES= xsl/customization.xml xsl/lispfunc.xml xsl/refentryintoc.xml
PDF_XSLFILES= xsl/customization.xml xsl/lispfunc-po.xml
all: html/ecl.css
ecl2.xml: $(XMLFILES) xsl/add_indexterm.xml
@test -d html || mkdir html
$(XSLTPROC) --xinclude xsl/add_indexterm.xml ecl.xml | \
sed 's, xmlns="",,g;s,&#151,,g;' > ecl2.xml
html/index.html: ecl2.xml $(HTML_XSLFILES)
$(XMLTO) -vv --skip-validation $(subst xsl, -m xsl,$(HTML_XSLFILES)) -o html html ecl2.xml
cp ecl.css html/
html/ecl.css: ecl.css html/index.html
cp ecl.css html/
@test -d html/figures || mkdir html/figures
cp figures/*.png html/figures/
ecl.pdf: ecl2.xml $(PDF_XSLFILES)
-mkdir tex
dblatex -V -d --tmpdir=tex -P latex.encoding=utf8 ecl2.xml
mv ecl2.pdf $@
tmp/ecl.ent: ecl.ent
cp $< $@
tmp/COPYING.GFDL.xml: COPYING.GFDL Makefile
echo '<![CDATA[' > $@
cat $< >> $@
echo ']]>' >> $@
jing:
jing -t -i /usr/local/Cellar/docbook/5.0/docbook/xml/5.0/rng/docbookxi.rnc ecl.xml
clean:
rm -f tmp/ecl.ent ecl2.xml $(GEN_XMLFILES) html/*.html ecl.pdf
rm -rf tex

15
doc/ansi_packages.xml
View file

@ -55,12 +55,6 @@
<entry><package>CMP</package></entry>
<entry>The compiler</entry>
</row>
<row>
<entry><package>XLIB</package></entry>
<entry><package>CLX</package></entry>
<entry><package>XLIB</package></entry>
<entry>CLX library for X-Windows</entry>
</row>
<row>
<entry><package>SB-BSD-SOCKETS</package></entry>
<entry></entry>
@ -86,12 +80,11 @@
<para>In <xref linkend="table.all-packages"/> we list all packages
available in &ECL;. The nicknames are aliases for a package. Thus,
<symbol>system:symbol</symbol> may be written as
<symbol>sys:symbol</symbol> or <symbol>si:symbol</symbol>. The module field
explains which library provides what package. For instance, the
<symbol>sys:symbol</symbol> or <symbol>si:symbol</symbol>. The module
field explains which library provides what package. For instance, the
<package>ASDF</package> is obtained when loading the
<package>ASDF</package> library with <code>(require 'asdf)</code>; and the
<package>XLIB</package> package when configuring and loading the
<package>CLX</package> library.</para>
<package>ASDF</package> library with <code>(require
'asdf)</code>.</para>
<xi:include href="ref_c_packages.xml" xpointer="ansi.packages.c-dict" xmlns:xi="http://www.w3.org/2001/XInclude"/>

1
doc/copyright.xmlf
View file

@ -31,7 +31,6 @@
src/lsp/format.lsp ; CMUCL's format
and the directories
contrib/ ; User contributed extensions
src/clx/ ; portable CLX library from Telent
Look the precise copyright of these extensions in the corresponding
files.

1
doc/preface.xmlf
View file

@ -191,7 +191,6 @@
src/lsp/format.lsp ; CMUCL's format
and the directories
contrib/ ; User contributed extensions
src/clx/ ; portable CLX library from Telent
Look the precise copyright of these extensions in the corresponding
files.

332
doc/tmp/COPYING.GFDL.xml
View file

@ -1,332 +0,0 @@
<![CDATA[
GNU Free Documentation License
Version 1.1, March 2000
Copyright (C) 2000 Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
0. PREAMBLE
The purpose of this License is to make a manual, textbook, or other
written document "free" in the sense of freedom: to assure everyone
the effective freedom to copy and redistribute it, with or without
modifying it, either commercially or noncommercially. Secondarily,
this License preserves for the author and publisher a way to get
credit for their work, while not being considered responsible for
modifications made by others.
This License is a kind of "copyleft", which means that derivative
works of the document must themselves be free in the same sense. It
complements the GNU General Public License, which is a copyleft
license designed for free software.
We have designed this License in order to use it for manuals for free
software, because free software needs free documentation: a free
program should come with manuals providing the same freedoms that the
software does. But this License is not limited to software manuals;
it can be used for any textual work, regardless of subject matter or
whether it is published as a printed book. We recommend this License
principally for works whose purpose is instruction or reference.
1. APPLICABILITY AND DEFINITIONS
This License applies to any manual or other work that contains a
notice placed by the copyright holder saying it can be distributed
under the terms of this License. The "Document", below, refers to any
such manual or work. Any member of the public is a licensee, and is
addressed as "you".
A "Modified Version" of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.
A "Secondary Section" is a named appendix or a front-matter section of
the Document that deals exclusively with the relationship of the
publishers or authors of the Document to the Document's overall subject
(or to related matters) and contains nothing that could fall directly
within that overall subject. (For example, if the Document is in part a
textbook of mathematics, a Secondary Section may not explain any
mathematics.) The relationship could be a matter of historical
connection with the subject or with related matters, or of legal,
commercial, philosophical, ethical or political position regarding
them.
The "Invariant Sections" are certain Secondary Sections whose titles
are designated, as being those of Invariant Sections, in the notice
that says that the Document is released under this License.
The "Cover Texts" are certain short passages of text that are listed,
as Front-Cover Texts or Back-Cover Texts, in the notice that says that
the Document is released under this License.
A "Transparent" copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, whose contents can be viewed and edited directly and
straightforwardly with generic text editors or (for images composed of
pixels) generic paint programs or (for drawings) some widely available
drawing editor, and that is suitable for input to text formatters or
for automatic translation to a variety of formats suitable for input
to text formatters. A copy made in an otherwise Transparent file
format whose markup has been designed to thwart or discourage
subsequent modification by readers is not Transparent. A copy that is
not "Transparent" is called "Opaque".
Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, LaTeX input format, SGML
or XML using a publicly available DTD, and standard-conforming simple
HTML designed for human modification. Opaque formats include
PostScript, PDF, proprietary formats that can be read and edited only
by proprietary word processors, SGML or XML for which the DTD and/or
processing tools are not generally available, and the
machine-generated HTML produced by some word processors for output
purposes only.
The "Title Page" means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the material
this License requires to appear in the title page. For works in
formats which do not have any title page as such, "Title Page" means
the text near the most prominent appearance of the work's title,
preceding the beginning of the body of the text.
2. VERBATIM COPYING
You may copy and distribute the Document in any medium, either
commercially or noncommercially, provided that this License, the
copyright notices, and the license notice saying this License applies
to the Document are reproduced in all copies, and that you add no other
conditions whatsoever to those of this License. You may not use
technical measures to obstruct or control the reading or further
copying of the copies you make or distribute. However, you may accept
compensation in exchange for copies. If you distribute a large enough
number of copies you must also follow the conditions in section 3.
You may also lend copies, under the same conditions stated above, and
you may publicly display copies.
3. COPYING IN QUANTITY
If you publish printed copies of the Document numbering more than 100,
and the Document's license notice requires Cover Texts, you must enclose
the copies in covers that carry, clearly and legibly, all these Cover
Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
the back cover. Both covers must also clearly and legibly identify
you as the publisher of these copies. The front cover must present
the full title with all words of the title equally prominent and
visible. You may add other material on the covers in addition.
Copying with changes limited to the covers, as long as they preserve
the title of the Document and satisfy these conditions, can be treated
as verbatim copying in other respects.
If the required texts for either cover are too voluminous to fit
legibly, you should put the first ones listed (as many as fit
reasonably) on the actual cover, and continue the rest onto adjacent
pages.
If you publish or distribute Opaque copies of the Document numbering
more than 100, you must either include a machine-readable Transparent
copy along with each Opaque copy, or state in or with each Opaque copy
a publicly-accessible computer-network location containing a complete
Transparent copy of the Document, free of added material, which the
general network-using public has access to download anonymously at no
charge using public-standard network protocols. If you use the latter
option, you must take reasonably prudent steps, when you begin
distribution of Opaque copies in quantity, to ensure that this
Transparent copy will remain thus accessible at the stated location
until at least one year after the last time you distribute an Opaque
copy (directly or through your agents or retailers) of that edition to
the public.
It is requested, but not required, that you contact the authors of the
Document well before redistributing any large number of copies, to give
them a chance to provide you with an updated version of the Document.
4. MODIFICATIONS
You may copy and distribute a Modified Version of the Document under
the conditions of sections 2 and 3 above, provided that you release
the Modified Version under precisely this License, with the Modified
Version filling the role of the Document, thus licensing distribution
and modification of the Modified Version to whoever possesses a copy
of it. In addition, you must do these things in the Modified Version:
A. Use in the Title Page (and on the covers, if any) a title distinct
from that of the Document, and from those of previous versions
(which should, if there were any, be listed in the History section
of the Document). You may use the same title as a previous version
if the original publisher of that version gives permission.
B. List on the Title Page, as authors, one or more persons or entities
responsible for authorship of the modifications in the Modified
Version, together with at least five of the principal authors of the
Document (all of its principal authors, if it has less than five).
C. State on the Title page the name of the publisher of the
Modified Version, as the publisher.
D. Preserve all the copyright notices of the Document.
E. Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.
F. Include, immediately after the copyright notices, a license notice
giving the public permission to use the Modified Version under the
terms of this License, in the form shown in the Addendum below.
G. Preserve in that license notice the full lists of Invariant Sections
and required Cover Texts given in the Document's license notice.
H. Include an unaltered copy of this License.
I. Preserve the section entitled "History", and its title, and add to
it an item stating at least the title, year, new authors, and
publisher of the Modified Version as given on the Title Page. If
there is no section entitled "History" in the Document, create one
stating the title, year, authors, and publisher of the Document as
given on its Title Page, then add an item describing the Modified
Version as stated in the previous sentence.
J. Preserve the network location, if any, given in the Document for
public access to a Transparent copy of the Document, and likewise
the network locations given in the Document for previous versions
it was based on. These may be placed in the "History" section.
You may omit a network location for a work that was published at
least four years before the Document itself, or if the original
publisher of the version it refers to gives permission.
K. In any section entitled "Acknowledgements" or "Dedications",
preserve the section's title, and preserve in the section all the
substance and tone of each of the contributor acknowledgements
and/or dedications given therein.
L. Preserve all the Invariant Sections of the Document,
unaltered in their text and in their titles. Section numbers
or the equivalent are not considered part of the section titles.
M. Delete any section entitled "Endorsements". Such a section
may not be included in the Modified Version.
N. Do not retitle any existing section as "Endorsements"
or to conflict in title with any Invariant Section.
If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no material
copied from the Document, you may at your option designate some or all
of these sections as invariant. To do this, add their titles to the
list of Invariant Sections in the Modified Version's license notice.
These titles must be distinct from any other section titles.
You may add a section entitled "Endorsements", provided it contains
nothing but endorsements of your Modified Version by various
parties--for example, statements of peer review or that the text has
been approved by an organization as the authoritative definition of a
standard.
You may add a passage of up to five words as a Front-Cover Text, and a
passage of up to 25 words as a Back-Cover Text, to the end of the list
of Cover Texts in the Modified Version. Only one passage of
Front-Cover Text and one of Back-Cover Text may be added by (or
through arrangements made by) any one entity. If the Document already
includes a cover text for the same cover, previously added by you or
by arrangement made by the same entity you are acting on behalf of,
you may not add another; but you may replace the old one, on explicit
permission from the previous publisher that added the old one.
The author(s) and publisher(s) of the Document do not by this License
give permission to use their names for publicity for or to assert or
imply endorsement of any Modified Version.
5. COMBINING DOCUMENTS
You may combine the Document with other documents released under this
License, under the terms defined in section 4 above for modified
versions, provided that you include in the combination all of the
Invariant Sections of all of the original documents, unmodified, and
list them all as Invariant Sections of your combined work in its
license notice.
The combined work need only contain one copy of this License, and
multiple identical Invariant Sections may be replaced with a single
copy. If there are multiple Invariant Sections with the same name but
different contents, make the title of each such section unique by
adding at the end of it, in parentheses, the name of the original
author or publisher of that section if known, or else a unique number.
Make the same adjustment to the section titles in the list of
Invariant Sections in the license notice of the combined work.
In the combination, you must combine any sections entitled "History"
in the various original documents, forming one section entitled
"History"; likewise combine any sections entitled "Acknowledgements",
and any sections entitled "Dedications". You must delete all sections
entitled "Endorsements."
6. COLLECTIONS OF DOCUMENTS
You may make a collection consisting of the Document and other documents
released under this License, and replace the individual copies of this
License in the various documents with a single copy that is included in
the collection, provided that you follow the rules of this License for
verbatim copying of each of the documents in all other respects.
You may extract a single document from such a collection, and distribute
it individually under this License, provided you insert a copy of this
License into the extracted document, and follow this License in all
other respects regarding verbatim copying of that document.
7. AGGREGATION WITH INDEPENDENT WORKS
A compilation of the Document or its derivatives with other separate
and independent documents or works, in or on a volume of a storage or
distribution medium, does not as a whole count as a Modified Version
of the Document, provided no compilation copyright is claimed for the
compilation. Such a compilation is called an "aggregate", and this
License does not apply to the other self-contained works thus compiled
with the Document, on account of their being thus compiled, if they
are not themselves derivative works of the Document.
If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one quarter
of the entire aggregate, the Document's Cover Texts may be placed on
covers that surround only the Document within the aggregate.
Otherwise they must appear on covers around the whole aggregate.
8. TRANSLATION
Translation is considered a kind of modification, so you may
distribute translations of the Document under the terms of section 4.
Replacing Invariant Sections with translations requires special
permission from their copyright holders, but you may include
translations of some or all Invariant Sections in addition to the
original versions of these Invariant Sections. You may include a
translation of this License provided that you also include the
original English version of this License. In case of a disagreement
between the translation and the original English version of this
License, the original English version will prevail.
9. TERMINATION
You may not copy, modify, sublicense, or distribute the Document except
as expressly provided for under this License. Any other attempt to
copy, modify, sublicense or distribute the Document is void, and will
automatically terminate your rights under this License. However,
parties who have received copies, or rights, from you under this
License will not have their licenses terminated so long as such
parties remain in full compliance.
10. FUTURE REVISIONS OF THIS LICENSE
The Free Software Foundation may publish new, revised versions
of the GNU Free Documentation License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns. See
http://www.gnu.org/copyleft/.
Each version of the License is given a distinguishing version number.
If the Document specifies that a particular numbered version of this
License "or any later version" applies to it, you have the option of
following the terms and conditions either of that specified version or
of any later version that has been published (not as a draft) by the
Free Software Foundation. If the Document does not specify a version
number of this License, you may choose any version ever published (not
as a draft) by the Free Software Foundation.
]]>

0
examples/ecl_qt/.gitkeep Normal file
View file

13
examples/ecl_qt/Makefile Normal file
View file

@ -0,0 +1,13 @@
all: qt/lisp-envi.a qt/hello-lisp-system--all-systems.fasb
#lisp environment.
qt/lisp-envi.a: lisp-envi.asd lisp-envi.lisp build_static.lisp
ecl -load build_static.lisp
#your lisp system.
qt/hello-lisp-system--all-systems.fasb: hello-lisp-system.asd hello-lisp.lisp \
build_fasl.lisp
ecl -load build_fasl.lisp
clean:
-rm -f qt/hello-lisp-system--all-systems.fasb qt/lisp-envi.a

52
examples/ecl_qt/README.md Normal file
View file

@ -0,0 +1,52 @@
This demo shows how to embed ECL into Qt5 and serve as kernel. This
also discuss how to compile ECL with C++(14). You can extend on this
demo to form a more complicate and productive project.
# Preparation
Before you build the demo, make sure you have those dependencies installed:
1. ECL, of course. We recommend version 16.1.2.
2. g++/clang compiler with at least C++14 support.
3. make
4. Qt5.x with Qt Creator.
5. Quicklisp installed on your ECL.
We use the external Lisp package :lparallel so you better download
that package in advance using `(ql:quickload :lparallel)`.
# Build
## Build CL Library and FASB
Run `make` in current directory and you get two files in the directory
`qt/` (if successful). `lisp-envi.a` and
`hello-lisp-system--all-systems.fasb`.
## Configure and build your Qt Project
To build the example it is enough to change to the `qt/` directory,
generate a Makefile with `qmake` and to call `make`.
```shell
cd qt/
qmake
make
```
If you want to change your Qt project, open it with the `Qt
Creator`. It can build the executable for you (instead of manually
working with make).
# Run
After you go through the steps above, go for the executable file and
try that demo.
Notice: For OSX users, you should manually move the .fasb file into
the directory where your executable file is in. So run the command:
```
mv hello-lisp-system--all-systems.fasb ecl_qtdemo.app/Contents/MacOS/
```
Happy hacking with ECL!
ntr(Lexicall)

8
examples/ecl_qt/build_fasl.lisp Normal file
View file

@ -0,0 +1,8 @@
;;(require 'asdf)
(push "./" asdf:*central-registry*)
(asdf:make-build :hello-lisp-system
:type :fasl
:monolithic t
:move-here "qt/")
(quit)

8
examples/ecl_qt/build_static.lisp Normal file
View file

@ -0,0 +1,8 @@
;;(require 'asdf)
(push "./" asdf:*central-registry*)
(asdf:make-build :lisp-envi
:type :static-library
:move-here "qt/")
(quit)

4
examples/ecl_qt/hello-lisp-system.asd Normal file
View file

@ -0,0 +1,4 @@
(defsystem :hello-lisp-system
:depends-on (:lparallel)
:components ((:file "hello-lisp")))

33
examples/ecl_qt/hello-lisp.lisp Normal file
View file

@ -0,0 +1,33 @@
(defpackage :hello-lisp
(:use :cl :lparallel))
(in-package :hello-lisp) ;;package name hello-lisp
(setf lparallel:*kernel* (lparallel:make-kernel 4))
(lparallel:defpun pfib (n)
(if (< n 2)
n
(plet ((a (pfib (- n 1)))
(b (pfib (- n 2))))
(+ a b))))
(defun qsort (seq pred)
(if (null seq) nil
(let* ((pivot (first seq))
(left (remove-if-not (lambda (x)
(funcall pred x pivot))
(cdr seq)))
(right (remove-if (lambda (x)
(funcall pred x pivot))
(cdr seq))))
(append (qsort left pred)
(list pivot)
(qsort right pred)))))
(defun say-hello ()
"Bonjour, lisp!")

3
examples/ecl_qt/lisp-envi.asd Normal file
View file

@ -0,0 +1,3 @@
(defsystem :lisp-envi
:depends-on ()
:components ((:file "lisp-envi")))

3
examples/ecl_qt/lisp-envi.lisp Normal file
View file

@ -0,0 +1,3 @@
(princ "Lisp Environment Booted.")

0
examples/ecl_qt/qt/.gitkeep Normal file
View file

11
examples/ecl_qt/qt/cl_bridge_utils.cpp Normal file
View file

@ -0,0 +1,11 @@
#include "cl_bridge_utils.hpp"
cl_object lispfy(string str){
return c_string_to_object(str.data());
}
string __spc_expr(string first){
return first;
}

103
examples/ecl_qt/qt/cl_bridge_utils.hpp Normal file
View file

@ -0,0 +1,103 @@
#ifndef CL_BRIDGE_UTILS_HPP
#define CL_BRIDGE_UTILS_HPP
#include <iostream>
#include <string>
#ifdef slots
#undef slots
#endif
#include <ecl/ecl.h>
using std::string;
using lisp_expr = std::string;
using std::cout;
using std::endl;
//extern string CL_MAIN_FASB ;
//extern string CL_MAIN_PACKAGE_NAME ;
cl_object lispfy(string str); /* convert a std::string to cl_object */
/* add spaces among several strings. */
string __spc_expr(string first);
template <typename ...str>
string __spc_expr (string first, str ... next){
return first+" "+__spc_expr(next...);
}
/* encapsule expressions in parenthesis. */
/* to create lisp expr. */
template<typename ...str>
lisp_expr par_expr(str... all){
return "("+__spc_expr(all...)+")";
}
/* turn the sequence into a lisp list expr. */
/* ex: par_list("hello", "lisp", "world");
* -> '("hello" "lisp" "world") */
template<typename ...str>
lisp_expr par_list(str... all){
return "'"+par_expr(all...);
}
/* an enhanced version of cl_eval */
template<typename ...str>
cl_object cl_eval(str... all){
std::cout<<par_expr(all...)<<std::endl;
return cl_eval(lispfy(par_expr(all...)));
}
auto cl_list_traverse=[](auto& cl_lst, auto fn){
while(!Null(cl_lst))
{
fn(cl_car(cl_lst));
cl_lst=cl_cdr(cl_lst);
}
};
/* enhanced cl_object in c++ */
class cl_obj {
private:
cl_object __obj;
public:
cl_obj(cl_object &&obj){this->__obj=obj;}
cl_obj(const cl_object &obj){this->__obj=obj;}
/* list index */
inline cl_obj car(){return cl_obj(cl_car(this->__obj));}
inline cl_obj cdr(){return cl_obj(cl_cdr(this->__obj));}
inline cl_obj cadr(){return this->cdr().car();}
inline cl_obj caar(){return this->car().car();}
inline cl_obj cddr(){return this->cdr().cdr();}
/* predicates */
inline bool nullp(){return Null(this->__obj);}
inline bool atomp(){return ECL_ATOM(this->__obj);}
inline bool listp(){return ECL_LISTP(this->__obj);}
inline bool symbolp(){return ECL_SYMBOLP(this->__obj);}
inline int to_int(){return ecl_to_int(this->__obj);}
inline char to_char(){return ecl_to_char(this->__obj);}
/* turn the cl_object into string. */
inline std::string to_std_string(){
std::string val;
auto & str=this->__obj->string;
for(unsigned long i=0;i<str.fillp;i+=1)
val+=*(typeof(str.elttype) *)(str.self+i);
return val;
}
/* traverse the cl_object as a list. */
template<typename function>
inline void list_traverse(function fn){cl_list_traverse(this->__obj, fn);}
inline cl_obj operator=(cl_object &&obj){return cl_obj(obj);}
};
#endif // CL_BRIDGE_UTILS_HPP

38
examples/ecl_qt/qt/ecl_qtdemo.pro Normal file
View file

@ -0,0 +1,38 @@
#-------------------------------------------------
#
# Project created by QtCreator 2016-08-10T18:00:40
#
#-------------------------------------------------
QT += core gui
CONFIG+=c++14
greaterThan(QT_MAJOR_VERSION, 4): QT += widgets
TARGET = ecl_qtdemo
TEMPLATE = app
SOURCES += main.cpp\
hybrid_main.cpp \
cl_bridge_utils.cpp
HEADERS += hybrid_main.h \
cl_bridge_utils.hpp
FORMS += hybrid_main.ui
# The include path that contains ecl/ecl.h
QMAKE_CFLAGS += `ecl-config --cflags`
QMAKE_CXXFLAGS += `ecl-config --cflags`
# The ECL shared library directory.
QMAKE_LFLAGS += `ecl-config --ldflags`
# Lisp library written by a user
LIBS += $$_PRO_FILE_PWD_/lisp-envi.a
LIBS += -lecl
RESOURCES += \
resource.qrc

76
examples/ecl_qt/qt/hybrid_main.cpp Normal file
View file

@ -0,0 +1,76 @@
#include "hybrid_main.h"
#include "ui_hybrid_main.h"
#include <sstream>
#include <QMessageBox>
#include "cl_bridge_utils.hpp"
using ss=std::stringstream;
using std::cout;
using std::endl;
hybrid_main::hybrid_main(QWidget *parent) :
QMainWindow(parent),
ui(new Ui::hybrid_main)
{
ui->setupUi(this);
}
hybrid_main::~hybrid_main()
{
delete ui;
}
/* int -> string */
auto itos=[](auto in){
ss s;s<<in;string res;s>>res;
return res;
};
/* when called, an alert dialog shows up */
auto jump_out_alert_window=[](std::string str){
QMessageBox::critical(0 ,
"critical message" , QString::fromStdString(str),
QMessageBox::Ok | QMessageBox::Default ,
QMessageBox::Cancel | QMessageBox::Escape , 0 );
};
/* concurrent fibonacci */
void hybrid_main::on_pushButton_clicked()
{
auto str=ui->edit->text().toStdString();
if(str==""){
jump_out_alert_window("You haven't input anything!");
} else {
cl_obj rtv=cl_eval("pfib", str);
string strt=itos(rtv.to_int());
ui->ans->setText(QString::fromStdString(strt));
}
}
/* quick sort. */
void hybrid_main::on_pushButton_2_clicked()
{
auto str=ui->input->text().toStdString();
if(str=="")
{
jump_out_alert_window("You haven't input anything!");
} else {
cout<<par_list(str)<<endl;
cl_obj rtvl=cl_eval("qsort", par_list(str), "#'<");
cout<<rtvl.car().to_int();
string lab="";
auto read_list_to_string=[&](auto elem){lab=lab+" "+itos(ecl_to_int(elem));};
rtvl.list_traverse(read_list_to_string);
ui->output->setText(QString::fromStdString(lab));
}
}
/* hello lisp */
void hybrid_main::on_pushButton_3_clicked()
{
string s=cl_obj(cl_eval("say-hello")).to_std_string();
jump_out_alert_window(s);
}

32
examples/ecl_qt/qt/hybrid_main.h Normal file
View file

@ -0,0 +1,32 @@
#ifndef HYBRID_MAIN_H
#define HYBRID_MAIN_H
#include <QMainWindow>
namespace Ui {
class hybrid_main;
}
class hybrid_main : public QMainWindow
{
Q_OBJECT
public:
explicit hybrid_main(QWidget *parent = 0);
~hybrid_main();
private slots:
void on_pushButton_clicked();
void on_pushButton_2_clicked();
void on_pushButton_3_clicked();
private:
Ui::hybrid_main *ui;
};
#endif // HYBRID_MAIN_H

248
examples/ecl_qt/qt/hybrid_main.ui Normal file
View file

@ -0,0 +1,248 @@
<?xml version="1.0" encoding="UTF-8"?>
<ui version="4.0">
<class>hybrid_main</class>
<widget class="QMainWindow" name="hybrid_main">
<property name="geometry">
<rect>
<x>0</x>
<y>0</y>
<width>641</width>
<height>430</height>
</rect>
</property>
<property name="windowTitle">
<string>hybrid_main</string>
</property>
<widget class="QWidget" name="centralWidget">
<widget class="QLineEdit" name="edit">
<property name="geometry">
<rect>
<x>112</x>
<y>60</y>
<width>121</width>
<height>21</height>
</rect>
</property>
<property name="inputMask">
<string/>
</property>
<property name="text">
<string/>
</property>
<property name="placeholderText">
<string>Input N here.</string>
</property>
</widget>
<widget class="QPushButton" name="pushButton">
<property name="geometry">
<rect>
<x>240</x>
<y>55</y>
<width>113</width>
<height>32</height>
</rect>
</property>
<property name="text">
<string>calculate!</string>
</property>
</widget>
<widget class="QLabel" name="label">
<property name="geometry">
<rect>
<x>30</x>
<y>60</y>
<width>71</width>
<height>16</height>
</rect>
</property>
<property name="text">
<string>Fibonacci:</string>
</property>
</widget>
<widget class="QLabel" name="label_2">
<property name="geometry">
<rect>
<x>160</x>
<y>100</y>
<width>241</width>
<height>16</height>
</rect>
</property>
<property name="text">
<string>Quick Sort List Processing Test</string>
</property>
</widget>
<widget class="QLabel" name="label_3">
<property name="geometry">
<rect>
<x>30</x>
<y>130</y>
<width>59</width>
<height>16</height>
</rect>
</property>
<property name="text">
<string>Input</string>
</property>
</widget>
<widget class="QLabel" name="label_4">
<property name="geometry">
<rect>
<x>30</x>
<y>170</y>
<width>59</width>
<height>16</height>
</rect>
</property>
<property name="text">
<string>Output</string>
</property>
</widget>
<widget class="QPushButton" name="pushButton_2">
<property name="geometry">
<rect>
<x>20</x>
<y>200</y>
<width>113</width>
<height>32</height>
</rect>
</property>
<property name="text">
<string>sort!</string>
</property>
</widget>
<widget class="QLineEdit" name="input">
<property name="geometry">
<rect>
<x>110</x>
<y>130</y>
<width>491</width>
<height>21</height>
</rect>
</property>
<property name="placeholderText">
<string>Input a sequence of number, seperate by space.</string>
</property>
</widget>
<widget class="QLineEdit" name="output">
<property name="geometry">
<rect>
<x>110</x>
<y>170</y>
<width>491</width>
<height>21</height>
</rect>
</property>
<property name="readOnly">
<bool>true</bool>
</property>
<property name="placeholderText">
<string>Sorted sequence output</string>
</property>
</widget>
<widget class="Line" name="line">
<property name="geometry">
<rect>
<x>30</x>
<y>80</y>
<width>601</width>
<height>16</height>
</rect>
</property>
<property name="orientation">
<enum>Qt::Horizontal</enum>
</property>
</widget>
<widget class="QLabel" name="label_5">
<property name="geometry">
<rect>
<x>270</x>
<y>240</y>
<width>61</width>
<height>91</height>
</rect>
</property>
<property name="styleSheet">
<string notr="true">border-image:url(:/pic/madeinlisp.png)</string>
</property>
<property name="text">
<string/>
</property>
</widget>
<widget class="QLabel" name="label_6">
<property name="geometry">
<rect>
<x>370</x>
<y>300</y>
<width>191</width>
<height>41</height>
</rect>
</property>
<property name="text">
<string>(Core made in Lisp.)</string>
</property>
</widget>
<widget class="QLabel" name="label_7">
<property name="geometry">
<rect>
<x>160</x>
<y>10</y>
<width>301</width>
<height>16</height>
</rect>
</property>
<property name="text">
<string>Concurrent Compution Test (lparallel)</string>
</property>
</widget>
<widget class="QPushButton" name="pushButton_3">
<property name="geometry">
<rect>
<x>350</x>
<y>270</y>
<width>181</width>
<height>32</height>
</rect>
</property>
<property name="text">
<string>Hello, Lisp!</string>
</property>
</widget>
<widget class="QLineEdit" name="ans">
<property name="geometry">
<rect>
<x>360</x>
<y>60</y>
<width>113</width>
<height>21</height>
</rect>
</property>
<property name="inputMask">
<string/>
</property>
<property name="readOnly">
<bool>true</bool>
</property>
<property name="placeholderText">
<string>Answer output</string>
</property>
</widget>
<widget class="QLabel" name="label_8">
<property name="geometry">
<rect>
<x>400</x>
<y>240</y>
<width>111</width>
<height>16</height>
</rect>
</property>
<property name="text">
<string>String Test</string>
</property>
</widget>
</widget>
</widget>
<layoutdefault spacing="6" margin="11"/>
<resources/>
<connections/>
</ui>

BIN
examples/ecl_qt/qt/madeinlisp.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 431 KiB

43
examples/ecl_qt/qt/main.cpp Normal file
View file

@ -0,0 +1,43 @@
#include "hybrid_main.h"
#include <QApplication>
#include "cl_bridge_utils.hpp"
string CL_MAIN_FASB = "\"hello-lisp-system--all-systems.fasb\"";
string CL_MAIN_PACKAGE_NAME = "hello-lisp";
/* Initialization.
* This time we load the fasb file after
* the Lisp Environment is booted.
* */
#define __cl_init_name init_lib_LISP_ENVI
extern "C"{
extern void __cl_init_name(cl_object);
}
void init_cl_env(int argc, char * argv[]){
/* Initialize CL environment */
cl_boot(argc, argv);
ecl_init_module(NULL, __cl_init_name);
/* load fasb */
cl_eval("load", CL_MAIN_FASB);
/* set context to current package */
cl_eval("in-package", CL_MAIN_PACKAGE_NAME);
/* hook for shutting down cl env */
atexit(cl_shutdown);
}
#undef __cl_init_name
int main(int argc, char *argv[]){
QApplication a(argc, argv);
hybrid_main w;
w.show();
init_cl_env(argc, argv); /* init env */
return a.exec();
}

5
examples/ecl_qt/qt/resource.qrc Normal file
View file

@ -0,0 +1,5 @@
<RCC>
<qresource prefix="/pic">
<file>madeinlisp.png</file>
</qresource>
</RCC>

10
msvc/Makefile
View file

@ -53,8 +53,6 @@ ECL_CMP =
ECL_ASDF =
# TCP support
ECL_SOCKETS =
# X Windows support
# ECL_CLX = 1
# Regression Tests support
ECL_RT =
# Defsystem support
@ -181,10 +179,6 @@ ECL_FEATURES = (cons :wants-asdf $(ECL_FEATURES))
ECL_MODULES = $(ECL_MODULES) sockets
ECL_FEATURES = (cons :wants-sockets $(ECL_FEATURES))
!endif
!ifdef ECL_CLX
ECL_MODULES = $(ECL_MODULES) clx
ECL_FEATURES = (cons :wants-clx $(ECL_FEATURES))
!endif
!ifdef ECL_RT
ECL_MODULES = $(ECL_MODULES) rt
ECL_FEATURES = (cons :wants-rt $(ECL_FEATURES))
@ -473,10 +467,10 @@ test2:
test3:
-mkdir stage2
cp -rf lsp clos cmp stage2
-for i in lsp cmp clos clx tk; do test -f lib$$i.a && mv lib$$i.a stage2; done
-for i in lsp cmp clos tk; do test -f lib$$i.a && mv lib$$i.a stage2; done
$(MAKE) clean_lisp
./ecl < compile.lsp
-for i in lsp clos cmp clx tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done | less
-for i in lsp clos cmp tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done | less
test:
$(MAKE) -C tests
$(MAKE) -C ansi-tests > ansi-tests/log

4
msvc/c/Makefile
View file

@ -5,10 +5,8 @@ top_srcdir = ..\..\src
srcdir = ..\..\src\c
!if "$(ECL_WIN64)" != ""
ECL_FFI_OBJ=
ECL_FPE_CODE=fpe_none.c
!else
ECL_FFI_OBJ=ffi_x86.obj
ECL_FPE_CODE=fpe_x86.c
!endif
@ -103,7 +101,7 @@ OBJS = main.obj symbol.obj package.obj cons.obj list.obj\
mapfun.obj multival.obj hash.obj format.obj pathname.obj\
structure.obj load.obj unixfsys.obj unixsys.obj \
ffi.obj alloc_2.obj tcp.obj $(THREADS_OBJ) serialize.obj \
$(ECL_FFI_OBJ) $(ECL_UCD_OBJ) $(ECL_SSE_OBJ)
$(ECL_UCD_OBJ) $(ECL_SSE_OBJ)
all: $(DPP) ..\eclmin.lib ..\cinit.obj

27
msvc/doc/Makefile
View file

@ -30,21 +30,17 @@ FILTER = ..\c\cut$(EXE) "@PACKAGE_VERSION@" "$(ECL_VERSION)"
ECL = ../ecl
all: $(INFO_FILES) $(HTML_FILES) developers_manual user_manual clx_manual
all: $(INFO_FILES) $(HTML_FILES) developers_manual user_manual_manual
ecl.dvi: $(srcdir)/user.txi $(srcdir)/macros.txi clisp.sty ecl.sty
tex $(srcdir)/user.txi
ecldev.dvi: $(srcdir)/devel.txi $(srcdir)/macros.txi clisp.sty ecl.sty
tex $(srcdir)/devel.txi
clx.dvi: clx.texinfo
tex clx.texinfo
ecl.ps: ecl.dvi $(srcdir)/macros.txi
dvips -o $@ ecl.dvi
ecldev.ps: ecldev.dvi $(srcdir)/macros.txi
dvips -o $@ ecldev.dvi
clx.ps: clx.dvi
dvips -o $@ clx.dvi
install: all
IF NOT EXIST $(docdir) $(MKDIR) $(docdir)
@ -54,8 +50,6 @@ install: all
for %i in (ecldev\*) do $(CP) %i $(docdir)\ecldev
IF NOT EXIST $(docdir)\ecl $(MKDIR) $(docdir)\ecl
for %i in (ecl\*) do $(CP) %i $(docdir)\ecl
IF NOT EXIST $(docdir)\clx $(MKDIR) $(docdir)\clx
for %i in (clx\*) do $(CP) %i $(docdir)\clx
flatinstall: all
IF NOT EXIST $(docdir) $(MKDIR) $(docdir)
for %i in (LICENSE LGPL) do $(CP) $(top_srcdir)\..\%i $(docdir)
@ -64,8 +58,6 @@ flatinstall: all
for %i in (ecldev\*) do $(CP) %i $(docdir)\ecldev
IF NOT EXIST $(docdir)\ecl $(MKDIR) $(docdir)\ecl
for %i in (ecl\*) do $(CP) %i $(docdir)\ecl
IF NOT EXIST $(docdir)\clx $(MKDIR) $(docdir)\clx
for %i in (clx\*) do $(CP) %i $(docdir)\clx
uninstall:
for k in $(INFO_FILES); do \
@ -77,7 +69,7 @@ uninstall:
rm -r $(infodir)/ecl.$(INFOEXT) $(infodir)/ecldev.$(INFOEXT); \
rm $(mandir)/man$(manext)/ecl.$(manext)
head2: developers_manual user_manual clx_manual $(srcdir)/head Makefile
head2: developers_manual user_manual manual $(srcdir)/head Makefile
IF EXIST ecl\index.html ( \
..\c\cut.exe "ecl/user.html" "ecl/index.html" \
"ecldev/devel.html" "ecldev/index.html" \
@ -89,16 +81,10 @@ ecl.info.gz: ecl.info
gzip < ecl.info > ecl.info.gz
ecldev.info.gz: ecldev.info
gzip < ecldev.info > ecldev.info.gz
clx.info.gz: clx.info
gzip < clx.info > clx.info.gz
ecl.info: $(srcdir)/user.txi $(srcdir)/macros.txi
makeinfo -I $(srcdir) --no-split $(srcdir)/user.txi
ecldev.info: $(srcdir)/devel.txi $(srcdir)/macros.txi
makeinfo -I $(srcdir) --no-split $(srcdir)/devel.txi
clx.info: clx.texinfo
makeinfo --no-split clx.texinfo
clx.texinfo: $(top_srcdir)/clx/manual/clx.texinfo
cp $(top_srcdir)/clx/manual/clx.texinfo .
download.html: $(srcdir)/download.in.html head2
( type head2 $(srcdir)\download.in.html $(srcdir)\end ) | $(FILTER) > $@
@ -152,11 +138,6 @@ developers_manual: $(srcdir)/devel.txi $(srcdir)/macros.txi
IF NOT EXIST ecldev MKDIR ecldev
makeinfo -v -I $(srcdir) --html $(srcdir)/devel.txi
echo > developers_manual
clx_manual: $(srcdir)/../clx/manual/clx.texinfo
echo "Producing clx.html; ignore error messages."
IF NOT EXIST clx MKDIR clx
makeinfo -v --html $(srcdir)\..\clx\manual\clx.texinfo
echo > clx_manual
clean:
-for %i in (ecl ecldev clx ..\gabriel) do $(RMDIR) %i
-for %i in (ecl.info* ecldev.info* $(HTML_FILES) head2 user_manual developers_manual clx_manual ..\gabriel\BENCHMARK) do $(RM) %i
-for %i in (ecl ecldev ..\gabriel) do $(RMDIR) %i
-for %i in (ecl.info* ecldev.info* $(HTML_FILES) head2 user_manual developers_manual_manual ..\gabriel\BENCHMARK) do $(RM) %i

12
msvc/ecl/config.h.msvc6
View file

@ -218,12 +218,16 @@ typedef unsigned char ecl_base_char;
/* #undef HAVE_FLOAT_COMPLEX */
/* Missing integer types */
#if _MSC_VER < 1900
typedef char int8_t;
typedef short int16_t;
typedef int int32_t;
typedef unsigned char uint8_t;
typedef unsigned short uint16_t;
typedef unsigned int uint32_t;
#else
#include <stdint.h>
#endif
/* We can use small, two-words conses, without type information */
/* #undef ECL_SMALL_CONS */
@ -249,8 +253,6 @@ typedef unsigned int uint32_t;
* FEATURES LINKED IN:
*/
/* CLX */
#define CLX 1
/* Locatives */
/* #undef LOCATIVE */
/* Use old MIT LOOP macro system */
@ -417,14 +419,14 @@ typedef unsigned int uint32_t;
# define stack_align(n) (((n) + 03) & ~03)
#endif
/* #undef FILE_CNT */
#undef FILE_CNT
#if 0 == 1
# define FILE_CNT(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr)
#endif
#if 0 == 2
# define FILE_CNT(fp) ((fp)->_r)
#endif
#if 3 == 3
#if ( defined(_MSC_VER) && (_MSC_VER < 1900) ) && 3 == 3
# define FILE_CNT(fp) ((fp)->_cnt)
#endif
@ -447,7 +449,9 @@ typedef unsigned int uint32_t;
#endif
#define strcasecmp _stricmp
#if defined(_MSC_VER) && (_MSC_VER < 1900)
#define isnan _isnan
#endif
#define finite _finite
#define sleep _sleep

15
src/Makefile.in
View file

@ -234,7 +234,7 @@ mostlyclean: clean_lisp
$(RM) *.c *.o *.a *.eclh *.h *.data *.fas *.dat *.la *.so *.dylib
clean_lisp:
-$(RM) help.doc $(TARGETS)
-for i in lsp cmp clos clx tk ext; do $(RM) lib$$i.a $$i/?*.{o,eclh,data,c,sdat,h,fas}; done
-for i in lsp cmp clos tk ext; do $(RM) lib$$i.a $$i/?*.{o,eclh,data,c,sdat,h,fas}; done
distclean: clean
realclean: distclean
#
@ -261,16 +261,17 @@ selfbuild:
exit 2
test -d stage2 || mkdir stage2
cp -rf lsp clos cmp stage2
-for i in lsp cmp clos clx tk; do test -f lib$$i.a && mv lib$$i.a stage2; done
-for i in lsp cmp clos tk; do test -f lib$$i.a && mv lib$$i.a stage2; done
$(MAKE) clean_lisp
./ecl compile
-for i in lsp clos cmp clx tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done | less
-for i in lsp clos cmp tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done | less
.git/tags:
( cd $(srcdir)/../.git && which ctags && ctags -f tags -R --langmap=c:+.d ../src ) || echo "tags generation failed, but this does not break the build."
# Make sure to also include *.d files; and match DPP's idiosyncracies
# like "@si::foo" and "@(defun si::foo".
# This rule is allowed to fail when etags does not exist.
.git/tags:
( cd $(srcdir)/../.git && ctags -o tags -R --langmap=c:+.d ../src ) || true
# like "@si::foo" and "@(defun si::foo". This rule is allowed to fail
# when etags does not exist.
TAGS:
-if test "x$(ETAGS)" != "x"; then \
srcfiles=`find $(srcdir)/c $(srcdir)/h -name '*.[chd]'` && \

36
src/aclocal.m4 vendored
View file

@ -249,7 +249,7 @@ THREAD_LIBS=''
THREAD_GC_FLAGS='--enable-threads=posix'
INSTALL_TARGET='install'
THREAD_OBJ="$THREAD_OBJ threads/process threads/queue threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox"
clibs=''
clibs='-lm'
SONAME=''
SONAME_LDFLAGS=''
case "${host_os}" in
@ -260,7 +260,7 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH='-Wl,--rpath,~A'
clibs="-ldl"
clibs="-ldl ${clibs}"
# Maybe CFLAGS="-D_ISOC99_SOURCE ${CFLAGS}" ???
CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 -DANDROID -DPLATFORM_ANDROID -DUSE_GET_STACKBASE_FOR_MAIN -DIGNORE_DYNAMIC_LOADING -DAO_REQUIRE_CAS ${CFLAGS}"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
@ -276,7 +276,7 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH='-Wl,--rpath,~A'
clibs="-ldl"
clibs="-ldl ${clibs}"
# Maybe CFLAGS="-D_ISOC99_SOURCE ${CFLAGS}" ???
CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 ${CFLAGS}"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
@ -289,7 +289,7 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH='-Wl,--rpath,~A'
clibs="-ldl"
clibs="-ldl ${clibs}"
CFLAGS="-D_GNU_SOURCE ${CFLAGS}"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
@ -301,7 +301,7 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH='-Wl,--rpath,~A'
clibs="-ldl"
clibs="-ldl ${clibs}"
CFLAGS="-D_GNU_SOURCE ${CFLAGS}"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
@ -312,7 +312,7 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH="-Wl,--rpath,~A"
clibs=""
clibs="${clibs}"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
;;
@ -322,7 +322,7 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH="-Wl,--rpath,~A"
clibs=""
clibs="${clibs}"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
;;
@ -332,7 +332,7 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH="-Wl,--rpath,~A"
clibs=""
clibs="${clibs}"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
;;
@ -343,7 +343,7 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH="-Wl,--rpath,~A"
clibs="-lpthread -lm"
clibs="-lpthread ${clibs}"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
;;
@ -354,9 +354,9 @@ case "${host_os}" in
BUNDLE_LDFLAGS="-dy -G ${LDFLAGS}"
ECL_LDRPATH='-Wl,-R,~A'
TCPLIBS='-lsocket -lnsl -lintl'
clibs='-ldl'
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
clibs='${clibs} -ldl'
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
if test "x$GCC" = "xyes"; then
CFLAGS="${CFLAGS} -std=gnu99 -D_XOPEN_SOURCE=600 -D__EXTENSIONS__"
SHARED_LDFLAGS="-shared $SHARED_LDFLAGS"
@ -440,7 +440,17 @@ case "${host_os}" in
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH='-Wld=\"-rld_l ~A\"'
clibs="-Wld=-lrld"
clibs="-Wld=-lrld ${clibs}"
;;
haiku*)
thehost='haiku'
THREAD_LIBS=''
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
ECL_LDRPATH="-Wl,--rpath,~A"
clibs="-lnetwork"
SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION"
SONAME_LDFLAGS="-Wl,-soname,SONAME"
;;
aix*)
PICFLAG='-DPIC'

36
src/c/alloc_2.d
View file

@ -1124,9 +1124,45 @@ standard_finalizer(cl_object o)
}
static void
wrapped_finalizer(cl_object o, cl_object finalizer);
static void
deferred_finalizer(cl_object o)
{
wrapped_finalizer(cl_first(o), cl_second(o));
}
void
wrapped_finalizer(cl_object o, cl_object finalizer)
{
if (finalizer != ECL_NIL && finalizer != NULL) {
#ifdef ECL_THREADS
const cl_env_ptr the_env = ecl_process_env();
if (!the_env
|| !the_env->own_process
|| the_env->own_process->process.phase < ECL_PROCESS_ACTIVE)
{
/*
* The finalizer is invoked while we are registering or setup a
* new lisp process. As example that may happen when we are
* doing ecl_import_current_thread. That mean the finalizer
* can not be executed right now, so in some way we need to
* queue the finalization. When we return from this function
* the original finalizer is no more registered to o, and if o
* is not anymore reachable it will be colleted. To prevent
* this we need to make this object reachable again after that
* roundtrip and postpone the finalization to the next garbace
* colletion. Given that this is a rare condition one way to
* do that is:
*/
GC_finalization_proc ofn;
void *odata;
GC_register_finalizer_no_order(cl_list(2,o,finalizer),
(GC_finalization_proc)deferred_finalizer, 0,
&ofn, &odata);
return;
}
#endif /* ECL_THREADS */
CL_NEWENV_BEGIN {
if (finalizer != ECL_T) {
funcall(2, finalizer, o);

2
src/c/compiler.d
View file

@ -2920,7 +2920,7 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context)
if ((nreq+nopt+(!Null(rest))+nkey) >= ECL_CALL_ARGUMENTS_LIMIT)
FEprogram_error_noreturn("LAMBDA: Argument list ist too long, ~S.", 1,
org_lambda_list);
@(return CONS(ecl_make_fixnum(nreq), lists[0]);
@(return CONS(ecl_make_fixnum(nreq), lists[0])
CONS(ecl_make_fixnum(nopt), lists[1])
rest
key_flag

7
src/c/dpp.c
View file

@ -74,6 +74,10 @@
#include <ctype.h>
#include <string.h>
#if defined(_MSC_VER) && (_MSC_VER >= 1800)
#include <stdbool.h>
#endif
#define DPP
#include <ecl/config.h>
#include "symbols_list2.h"
@ -90,8 +94,11 @@
#define FALSE 0
#ifndef __cplusplus
#if ! ( defined(__bool_true_false_are_defined) \
&&__bool_true_false_are_defined )
typedef int bool;
#endif
#endif
FILE *in, *out;

11
src/c/file.d
View file

@ -4201,8 +4201,9 @@ si_file_stream_fd(cl_object s)
{
cl_object ret;
unlikely_if (!ECL_ANSI_STREAM_P(s))
FEerror("file_stream_fd: not a stream", 0);
unlikely_if (!ECL_FILE_STREAM_P(s)) {
not_a_file_stream(s);
}
switch ((enum ecl_smmode)s->stream.mode) {
case ecl_smm_input:
@ -4218,7 +4219,7 @@ si_file_stream_fd(cl_object s)
default:
ecl_internal_error("not a file stream");
}
@(return ret);;
@(return ret);
}
/**********************************************************************
@ -4592,7 +4593,7 @@ ecl_unread_char(ecl_character c, cl_object strm)
stream_dispatch_table(strm)->unread_char(strm, c);
}
int
bool
ecl_listen_stream(cl_object strm)
{
return stream_dispatch_table(strm)->listen(strm);
@ -4664,7 +4665,7 @@ ecl_stream_element_type(cl_object strm)
return stream_dispatch_table(strm)->element_type(strm);
}
int
bool
ecl_interactive_stream_p(cl_object strm)
{
return stream_dispatch_table(strm)->interactive_p(strm);

22
src/c/main.d
View file

@ -201,7 +201,7 @@ _ecl_dealloc_env(cl_env_ptr env)
ecl_internal_error("Unable to deallocate environment structure.");
#else
# if defined(ECL_USE_GUARD_PAGE)
if (!VirtualFree(env, sizeof(*env), MEM_RELEASE))
if (!VirtualFree(env, 0, MEM_RELEASE))
ecl_internal_error("Unable to deallocate environment structure.");
# endif
#endif
@ -714,23 +714,29 @@ cl_boot(int argc, char **argv)
ECL_SET(@'mp::+load-compile-lock+',
ecl_make_lock(@'mp::+load-compile-lock+', 1));
#endif
aux = cl_list(
#ifdef ENABLE_DLOPEN
11,
aux = cl_list(11,
CONS(ECL_NIL, @'si::load-source'),
CONS(str_fas, @'si::load-binary'),
CONS(str_fasl, @'si::load-binary'),
CONS(str_fasb, @'si::load-binary'),
CONS(str_FASB, @'si::load-binary'),
#else
7,
#endif
CONS(str_lsp, @'si::load-source'),
CONS(str_lisp, @'si::load-source'),
CONS(str_LSP, @'si::load-source'),
CONS(str_LISP, @'si::load-source'),
CONS(str_fasc, @'si::load-bytecodes'),
CONS(str_FASC, @'si::load-bytecodes'),
CONS(ECL_NIL, @'si::load-source'));
CONS(str_FASC, @'si::load-bytecodes'));
#else
aux = cl_list(7,
CONS(ECL_NIL, @'si::load-source'),
CONS(str_lsp, @'si::load-source'),
CONS(str_lisp, @'si::load-source'),
CONS(str_LSP, @'si::load-source'),
CONS(str_LISP, @'si::load-source'),
CONS(str_fasc, @'si::load-bytecodes'),
CONS(str_FASC, @'si::load-bytecodes'));
#endif
ECL_SET(@'ext::*load-hooks*', aux);
init_error();
init_macros();

50
src/c/num_rand.d
View file

@ -50,10 +50,10 @@
cl_object
init_genrand(ulong seed)
{
int j;
cl_object array = ecl_alloc_simple_vector((MT_N + 1), ecl_aet_b64);
ulong *mt = array->vector.self.b64;
mt[0] = seed;
int j;
for (j=1; j<MT_N; j++)
mt[j] = (6364136223846793005ULL * (mt[j-1] ^ (mt[j-1] >> 62)) + j);
@ -134,8 +134,8 @@ init_genrand(ulong seed)
{
cl_object array = ecl_alloc_simple_vector((MT_N + 1), ecl_aet_b32);
ulong *mt = array->vector.self.b32;
mt[0] = seed;
int j;
mt[0] = seed;
for (j=1; j < MT_N; j++)
mt[j] = (1812433253UL * (mt[j-1] ^ (mt[j-1] >> 30)) + j);
@ -281,23 +281,45 @@ cl_object
ecl_make_random_state(cl_object rs)
{
cl_object z = ecl_alloc_object(t_random);
const char *type
= "(OR RANDOM-STATE FIXNUM (MEMBER T NIL))";
if (rs == ECL_T) {
z->random.value = init_random_state();
return z;
}
if (Null(rs))
} else if (Null(rs)) {
rs = ecl_symbol_value(@'*random-state*');
if (ecl_t_of(rs) == t_random) {
z->random.value = cl_copy_seq(rs->random.value);
return z;
}
const char *type
= "(OR RANDOM-STATE FIXNUM (MEMBER T NIL))";
FEwrong_type_only_arg(@[make-random-state], rs,
ecl_read_from_cstring(type));
switch (ecl_t_of(rs)) {
case t_random:
z->random.value = cl_copy_seq(rs->random.value);
break;
case t_fixnum:
z->random.value = init_genrand(ecl_fixnum(rs));
break;
case t_vector: /* intentionaly undocumented (only for internal use) */
#if ECL_FIXNUM_BITS > 32
if (rs->vector.dim == 313 && rs->vector.elttype == ecl_aet_b64) {
z = ecl_alloc_object(t_random);
z->random.value = cl_copy_seq(rs);
break;
}
#else /* 32 bit version */
if (rs->vector.dim == 625 && rs->vector.elttype == ecl_aet_b32) {
z = ecl_alloc_object(t_random);
z->random.value = cl_copy_seq(rs);
break;
}
#endif
default:
FEwrong_type_only_arg(@[make-random-state], rs,
ecl_read_from_cstring(type));
}
return z;
}
@(defun random (x &optional (rs ecl_symbol_value(@'*random-state*')))
@ -316,3 +338,9 @@ cl_random_state_p(cl_object x)
{
@(return (ECL_RANDOM_STATE_P(x) ? ECL_T : ECL_NIL));
}
cl_object
si_random_state_array(cl_object rs) {
ecl_check_cl_type(@'ext::random-state-array', rs, t_random);
return rs->random.value;
}

14
src/c/number.d
View file

@ -916,3 +916,17 @@ _ecl_float_to_integer(float d)
return _ecl_big_register_copy(z);
}
}
#ifdef ECL_IEEE_FP
cl_object
si_nan() {
cl_object x = ecl_alloc_object(t_doublefloat);
ecl_double_float(x) = NAN;
}
cl_object
si_infinity() {
cl_object x = ecl_alloc_object(t_doublefloat);
ecl_double_float(x) = INFINITY;
}
#endif /* ECL_IEEE_FP */

25
src/c/read.d
View file

@ -1383,30 +1383,7 @@ sharp_dollar_reader(cl_object in, cl_object c, cl_object d)
if (d != ECL_NIL && !read_suppress)
extra_argument('$', in, d);
c = ecl_read_object(in);
switch (ecl_t_of(c)) {
case t_vector:
#if ECL_FIXNUM_BITS > 32
if (c->vector.dim == 313 && c->vector.elttype == ecl_aet_b64) {
rs = ecl_alloc_object(t_random);
rs->random.value = cl_copy_seq(c);
break;
}
#else /* 32 bit version */
if (c->vector.dim == 625 && c->vector.elttype == ecl_aet_b32) {
rs = ecl_alloc_object(t_random);
rs->random.value = cl_copy_seq(c);
break;
}
#endif
case t_fixnum:
rs = ecl_alloc_object(t_random);
rs->random.value = init_genrand(ecl_fixnum(c));
break;
default:
rs = ecl_make_random_state(c);
break;
}
rs = ecl_make_random_state(c);
@(return rs);
}

6
src/c/reader/parse_number.d
View file

@ -43,6 +43,7 @@ infinity(cl_index exp_char, int sign)
{
cl_object var;
switch (exp_char) {
#ifdef ECL_IEEE_FP
case 'e': case 'E':
return infinity(ecl_current_read_default_float_format(), sign);
case 's': case 'S':
@ -52,17 +53,18 @@ infinity(cl_index exp_char, int sign)
@'ext::single-float-positive-infinity';
break;
case 'l': case 'L':
#ifdef ECL_LONG_FLOAT
# ifdef ECL_LONG_FLOAT
var = (sign<0)?
@'ext::long-float-negative-infinity' :
@'ext::long-float-positive-infinity';
break;
#endif
# endif
case 'd': case 'D':
var = (sign<0)?
@'ext::double-float-negative-infinity' :
@'ext::double-float-positive-infinity';
break;
#endif /* ECL_IEEE_FP */
default:
return OBJNULL;
}

15
src/c/symbols_list.h
View file

@ -1225,6 +1225,7 @@ cl_symbols[] = {
{SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL},
{SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3, OBJNULL},
{EXT_ "RUN-PROGRAM", EXT_ORDINARY, si_run_program, -1, OBJNULL},
{EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, si_terminate_process, -1, OBJNULL},
{SYS_ "WAIT-FOR-ALL-PROCESSES", SI_ORDINARY, si_wait_for_all_processes, -1, OBJNULL},
{EXT_ "SAFE-EVAL", EXT_ORDINARY, ECL_NAME(si_safe_eval), -1, OBJNULL},
{SYS_ "SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2, OBJNULL},
@ -1900,22 +1901,28 @@ cl_symbols[] = {
{EXT_ "*BYTECODES-COMPILER*", EXT_SPECIAL, NULL, -1, ECL_NIL},
#ifdef ECL_IEEE_FP
{SYS_ "NAN", EXT_ORDINARY, si_nan, 0, OBJNULL},
{SYS_ "INFINITY", EXT_ORDINARY, si_infinity, 0, OBJNULL},
{EXT_ "SHORT-FLOAT-POSITIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL},
{EXT_ "SINGLE-FLOAT-POSITIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL},
{EXT_ "DOUBLE-FLOAT-POSITIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL},
{EXT_ "LONG-FLOAT-POSITIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL},
{EXT_ "SHORT-FLOAT-NEGATIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL},
{EXT_ "SINGLE-FLOAT-NEGATIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL},
{EXT_ "DOUBLE-FLOAT-NEGATIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL},
{EXT_ "LONG-FLOAT-NEGATIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL},
#endif /* ECL_IEEE_FP */
{EXT_ "FLOAT-NAN-P", EXT_ORDINARY, si_float_nan_p, 1, OBJNULL},
{EXT_ "FLOAT-INFINITY-P", EXT_ORDINARY, si_float_infinity_p, 1, OBJNULL},
{SYS_ "READ-OBJECT-OR-IGNORE", EXT_ORDINARY, si_read_object_or_ignore, 2, OBJNULL},
{EXT_ "FLOAT-NAN-STRING", EXT_ORDINARY, NULL, 1, OBJNULL},
{EXT_ "FLOAT-INFINITY-STRING", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "READ-OBJECT-OR-IGNORE", EXT_ORDINARY, si_read_object_or_ignore, 2, OBJNULL},
{EXT_ "READTABLE-LOCK", EXT_ORDINARY, si_readtable_lock, -1, OBJNULL},
{SYS_ "+IO-SYNTAX-PROGV-LIST+", SI_CONSTANT, NULL, -1, OBJNULL},
@ -2207,6 +2214,8 @@ cl_symbols[] = {
{EXT_ "HASH-TABLE-CONTENT", EXT_ORDINARY, si_hash_table_content, 1, OBJNULL},
{EXT_ "HASH-TABLE-FILL", EXT_ORDINARY, si_hash_table_fill, 2, OBJNULL},
{EXT_ "RANDOM-STATE-ARRAY", EXT_ORDINARY, si_random_state_array, 1, OBJNULL},
{SYS_ "REPORT-FUNCTION", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "DO-DEFSETF", SI_ORDINARY, ECL_NAME(si_do_defsetf), -1, OBJNULL},

15
src/c/symbols_list2.h
View file

@ -1225,6 +1225,7 @@ cl_symbols[] = {
{SYS_ "REPLACE-ARRAY","si_replace_array"},
{SYS_ "ROW-MAJOR-ASET","si_row_major_aset"},
{EXT_ "RUN-PROGRAM","si_run_program"},
{EXT_ "TERMINATE-PROCESS","si_terminate_process"},
{SYS_ "WAIT-FOR-ALL-PROCESSES","si_wait_for_all_processes"},
{EXT_ "SAFE-EVAL","ECL_NAME(si_safe_eval)"},
{SYS_ "SCH-FRS-BASE","si_sch_frs_base"},
@ -1900,22 +1901,28 @@ cl_symbols[] = {
{EXT_ "*BYTECODES-COMPILER*",NULL},
#ifdef ECL_IEEE_FP
{SYS_ "NAN","si_nan"},
{SYS_ "INFINITY","si_infinity"},
{EXT_ "SHORT-FLOAT-POSITIVE-INFINITY",NULL},
{EXT_ "SINGLE-FLOAT-POSITIVE-INFINITY",NULL},
{EXT_ "DOUBLE-FLOAT-POSITIVE-INFINITY",NULL},
{EXT_ "LONG-FLOAT-POSITIVE-INFINITY",NULL},
{EXT_ "SHORT-FLOAT-NEGATIVE-INFINITY",NULL},
{EXT_ "SINGLE-FLOAT-NEGATIVE-INFINITY",NULL},
{EXT_ "DOUBLE-FLOAT-NEGATIVE-INFINITY",NULL},
{EXT_ "LONG-FLOAT-NEGATIVE-INFINITY",NULL},
#endif /* ECL_IEEE_FP */
{EXT_ "FLOAT-NAN-P","si_float_nan_p"},
{EXT_ "FLOAT-INFINITY-P","si_float_infinity_p"},
{SYS_ "READ-OBJECT-OR-IGNORE","si_read_object_or_ignore"},
{EXT_ "FLOAT-NAN-STRING",NULL},
{EXT_ "FLOAT-INFINITY-STRING",NULL},
{SYS_ "READ-OBJECT-OR-IGNORE","si_read_object_or_ignore"},
{EXT_ "READTABLE-LOCK","si_readtable_lock"},
{SYS_ "+IO-SYNTAX-PROGV-LIST+",NULL},
@ -2207,6 +2214,8 @@ cl_symbols[] = {
{EXT_ "HASH-TABLE-CONTENT","si_hash_table_content"},
{EXT_ "HASH-TABLE-FILL","si_hash_table_fill"},
{EXT_ "RANDOM-STATE-ARRAY","si_random_state_array"},
{SYS_ "REPORT-FUNCTION",NULL},
{SYS_ "DO-DEFSETF","ECL_NAME(si_do_defsetf)"},

12
src/c/threads/process.d
View file

@ -31,16 +31,6 @@
#include "threads/ecl_atomics.h"
#ifdef ECL_WINDOWS_THREADS
/*
* We have to put this explicit definition here because Boehm GC
* is designed to produce a DLL and we rather want a static
* reference
*/
# include <gc.h>
extern HANDLE WINAPI GC_CreateThread(
LPSECURITY_ATTRIBUTES lpThreadAttributes,
DWORD dwStackSize, LPTHREAD_START_ROUTINE lpStartAddress,
LPVOID lpParameter, DWORD dwCreationFlags, LPDWORD lpThreadId );
# ifndef WITH___THREAD
DWORD cl_env_key;
# endif
@ -382,7 +372,6 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
ecl_set_process_env(env_aux);
env = _ecl_alloc_env(0);
ecl_set_process_env(env);
env->cleanup = registered;
/* Link environment and process together */
env->own_process = process = alloc_process(name, bindings);
@ -392,6 +381,7 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
ecl_list_process(process);
ecl_init_env(env);
env->cleanup = registered;
env->bindings_array = process->process.initial_bindings;
env->thread_local_bindings_size = env->bindings_array->vector.dim;
env->thread_local_bindings = env->bindings_array->vector.self.t;

24
src/c/unixint.d
View file

@ -1122,16 +1122,11 @@ _ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep)
static cl_object
W32_handle_in_new_thread(cl_object signal_code)
{
/* XXX: there is some bug present only on windows platform
with importing the current thread. Don't know how to track
it though. */
#if 0
int outside_ecl = ecl_import_current_thread(@'si::handle-signal', ECL_NIL);
mp_process_run_function(4, @'si::handle-signal',
@'si::handle-signal',
signal_code, ECL_NIL);
if (outside_ecl) ecl_release_current_thread();
#endif /* 0 */
}
BOOL WINAPI W32_console_ctrl_handler(DWORD type)
@ -1139,20 +1134,21 @@ BOOL WINAPI W32_console_ctrl_handler(DWORD type)
switch (type) {
case CTRL_C_EVENT:
case CTRL_BREAK_EVENT: {
/* cl_object function = */
/* ECL_SYM_FUN(@'si::terminal-interrupt'); */
/* if (function) */
/* W32_handle_in_new_thread(function); */
cl_object function =
ECL_SYM_FUN(@'si::terminal-interrupt');
if (function)
W32_handle_in_new_thread(function);
return TRUE;
}
case CTRL_CLOSE_EVENT:
case CTRL_LOGOFF_EVENT:
case CTRL_SHUTDOWN_EVENT:
/* Doing nothing is arguably the most
reasonable. Calling (quit) causes process to exit
and Windows has problems, because "process has
unexpectably died.*/
case CTRL_SHUTDOWN_EVENT: {
cl_object function =
ECL_SYM_FUN(@'ext::quit');
if (function)
W32_handle_in_new_thread(function);
return TRUE;
}
default:
return FALSE;
}

30
src/c/unixsys.d
View file

@ -301,6 +301,33 @@ ecl_waitpid(cl_object pid, cl_object wait)
@(return status code pid);
}
@(defun ext::terminate-process (process &optional (force ECL_NIL))
@
{
cl_env_ptr env = ecl_process_env();
bool error_encountered = FALSE;
ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock);
{
cl_object pid = external_process_pid(process);
if (!Null(pid)) {
int ret;
#if defined(ECL_MS_WINDOWS_HOST)
ret = TerminateProcess(ecl_fixnum(pid), -1);
error_encountered = (ret == 0);
#else
ret = kill(ecl_fixnum(pid), Null(force) ? SIGTERM : SIGKILL);
error_encountered = (ret != 0);
#endif
}
}
ECL_WITH_SPINLOCK_END;
if (error_encountered)
FEerror("Cannot terminate the process ~A", 1, process);
return ECL_NIL;
}
@)
@(defun si::wait-for-all-processes (&key (process ECL_NIL))
@
{
@ -320,7 +347,8 @@ ecl_waitpid(cl_object pid, cl_object wait)
update_process_status(p, status, code);
}
if (status != @':running') {
remove_external_process(env, p); ecl_delete_eq(p, cl_core.external_processes);
remove_external_process(env, p);
ecl_delete_eq(p, cl_core.external_processes);
}
}
} while (1);

107
src/clos/print.lsp
View file

@ -136,6 +136,9 @@ printer and we should rather use MAKE-LOAD-FORM."
(values
`(ext:hash-table-fill ,make-form ',content)
nil))))
(random-state
(let ((state (ext:random-state-array object)))
(values `(make-random-state ,state) nil)))
(t
(no-make-load-form object)))))
@ -150,7 +153,7 @@ printer and we should rather use MAKE-LOAD-FORM."
(defun no-make-load-form (object)
(declare (si::c-local))
(error "No adequate specialization of MAKE-LOAD-FORM for an object of type"
(error "No adequate specialization of MAKE-LOAD-FORM for an object type ~A"
(type-of object)))
(defmethod make-load-form ((class class) &optional environment)
@ -169,12 +172,10 @@ printer and we should rather use MAKE-LOAD-FORM."
;;; ----------------------------------------------------------------------
(defmethod print-object ((instance t) stream)
(if (typep instance 'standard-object)
(let ((*package* (find-package "CL")))
(print-unreadable-object (instance stream)
(format stream "~S"
(class-name (si:instance-class instance)))))
(write instance :stream stream))
(let ((*package* (find-package "CL")))
(print-unreadable-object (instance stream)
(format stream "~S"
(class-name (si:instance-class instance)))))
instance)
(defmethod print-object ((instance standard-object) stream)
@ -198,47 +199,67 @@ printer and we should rather use MAKE-LOAD-FORM."
(defmethod print-object ((m standard-method) stream)
(print-unreadable-object (m stream :type t)
(format stream "~A ~A"
(let ((gf (method-generic-function m)))
(if gf
(generic-function-name gf)
'UNNAMED))
(method-specializers m)))
(format stream "~A ~{~S ~}~S"
(let ((gf (method-generic-function m)))
(if gf
(generic-function-name gf)
'UNNAMED))
(method-qualifiers m)
(loop for spec in (method-specializers m)
collect (cond ((and (classp spec)
(class-name spec)))
((typep spec 'eql-specializer)
`(eql ,(eql-specializer-object spec)))
(t spec)))))
m)
(defun ext::float-nan-string (x)
(when *print-readably*
(error 'print-not-readable :object x))
(cdr (assoc (type-of x)
'((single-float . "#<single-float quiet NaN>")
(double-float . "#<double-float quiet NaN>")
(long-float . "#<long-float quiet NaN>")
(short-float . "#<short-float quiet NaN>")))))
(unless (ext:float-nan-p x)
(signal 'type-error :datum x :expected-type 'float-nan))
(cond
((null *print-readably*)
(etypecase x
(single-float "#<single-float quiet NaN>")
(double-float "#<double-float quiet NaN>")
(long-float "#<long-float quiet NaN>")
(short-float "#<short-float quiet NaN>")))
#+ieee-floating-point
(*read-eval*
(etypecase x
(single-float "#.(coerce (si:nan) 'single-float)")
(double-float "#.(coerce (si:nan) 'double-float)")
(long-float "#.(coerce (si:nan) 'long-float)")
(short-float "#.(coerce (si:nan) 'short-float)")))
(t (error 'print-not-readable :object x))))
(defun ext::float-infinity-string (x)
(when (and *print-readably* (null *read-eval*))
(error 'print-not-readable :object x))
(let* ((negative-infinities '((single-float .
"#.ext::single-float-negative-infinity")
(double-float .
"#.ext::double-float-negative-infinity")
(long-float .
"#.ext::long-float-negative-infinity")
(short-float .
"#.ext::short-float-negative-infinity")))
(positive-infinities '((single-float .
"#.ext::single-float-positive-infinity")
(double-float .
"#.ext::double-float-positive-infinity")
(long-float .
"#.ext::long-float-positive-infinity")
(short-float .
"#.ext::short-float-positive-infinity")))
(record (assoc (type-of x)
(if (plusp x) positive-infinities negative-infinities))))
(unless record
(error "Not an infinity"))
(cdr record)))
(unless (ext:float-infinity-p x)
(signal 'type-error :datum x :expected-type 'float-infinity))
(cond
((null *print-readably*)
(etypecase x
(ext:negative-single-float "#<single-float negative infinity>")
(ext:positive-single-float "#<single-float positive infinity>")
(ext:negative-double-float "#<double-float negative infinity>")
(ext:positive-double-float "#<double-float positive infinity>")
(ext:negative-long-float "#<long-float negative infinity>")
(ext:positive-long-float "#<long-float positive infinity>")
(ext:negative-short-float "#<short-float negative infinity>")
(ext:positive-short-float "#<short-float positive infinity>")))
#+ieee-floating-point
(*read-eval*
(etypecase x
(ext:negative-single-float "#.ext::single-float-negative-infinity")
(ext:positive-single-float "#.ext::single-float-positive-infinity")
(ext:negative-double-float "#.ext::double-float-negative-infinity")
(ext:positive-double-float "#.ext::double-float-positive-infinity")
(ext:negative-long-float "#.ext::long-float-negative-infinity")
(ext:positive-long-float "#.ext::long-float-positive-infinity")
(ext:negative-short-float "#.ext::short-float-negative-infinity")
(ext:positive-short-float "#.ext::short-float-positive-infinity")))
(t (error 'print-not-readable :object x))))
;;; ----------------------------------------------------------------------
;;; Describe

1
src/clx/.cvsignore
View file

@ -1 +0,0 @@
*.fasl

55
src/clx/CHANGES
View file

@ -1,55 +0,0 @@
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.

164
src/clx/NEWS
View file

@ -1,164 +0,0 @@
-*- Text -*-
-- 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.

112
src/clx/README
View file

@ -1,112 +0,0 @@
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>

52
src/clx/README-R5
View file

@ -1,52 +0,0 @@
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.

643
src/clx/attributes.lisp
View file

@ -1,643 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; Window Attributes
;;;
;;; 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.
;;;
;;; The special variable *window-attributes* is an alist containg:
;;; (drawable attributes attribute-changes geometry geometry-changes)
;;; Where DRAWABLE is the associated window or pixmap
;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's
;;; attributes for use by the accessors.
;;; ATTRIBUTE-CHANGES is NIL or an array. The first element
;;; of the array is a "value-mask", indicating which
;;; attributes have changed. The other elements are
;;; integers associated with the changed values, ready
;;; for insertion into a server request.
;;; GEOMETRY is like ATTRIBUTES, but for window geometry
;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry
;;;
;;; Attribute and Geometry accessors and SETF's look on the special variable
;;; *window-attributes* for the drawable. If its not there, the accessor is
;;; NOT within a WITH-STATE, and a server request is made to get or put a value.
;;; If an entry is found in *window-attributes*, the cache buffers are used
;;; for the access.
;;;
;;; 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.
(in-package :xlib)
(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
;; Window Attribute reply buffer resource
(defvar *context-free-list* nil) ;; resource of free reply buffers
(defun allocate-context ()
(or (threaded-atomic-pop *context-free-list* reply-next reply-buffer)
(make-reply-buffer +context-size+)))
(defun deallocate-context (context)
(declare (type reply-buffer context))
(threaded-atomic-push context *context-free-list* reply-next reply-buffer))
(defmacro state-attributes (state) `(second ,state))
(defmacro state-attribute-changes (state) `(third ,state))
(defmacro state-geometry (state) `(fourth ,state))
(defmacro state-geometry-changes (state) `(fifth ,state))
(defmacro drawable-equal-function ()
;; Since drawables are not always cached, we must use drawable-equal
;; to determine equality.
''drawable-equal)
(defmacro window-equal-function ()
;; Since windows are not always cached, we must use window-equal
;; to determine equality.
''window-equal)
(defmacro with-state ((drawable) &body body)
;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
;; ConfigureWindow. The body is not surrounded by a with-display. Within the
;; indefinite scope of the body, on a per-process basis in a multi-process
;; environment, the first call within an Accessor Group on the specified drawable
;; (the object, not just the variable) causes the complete results of the protocol
;; request to be retained, and returned in any subsequent accessor calls. Calls
;; within a Setf Group are delayed, and executed in a single request on exit from
;; the body. In addition, if a call on a function within an Accessor Group follows
;; a call on a function in the corresponding Setf Group, then all delayed setfs for
;; that group are executed, any retained accessor information for that group is
;; discarded, the corresponding protocol request is (re)issued, and the results are
;; (again) retained, and returned in any subsequent accessor calls.
;; Accessor Group A (for GetWindowAttributes):
;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity,
;; window-backing-store, window-backing-planes, window-backing-pixel,
;; window-save-under, window-colormap, window-colormap-installed-p,
;; window-map-state, window-all-event-masks, window-event-mask,
;; window-do-not-propagate-mask, window-override-redirect
;; Setf Group A (for ChangeWindowAttributes):
;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
;; window-backing-pixel, window-save-under, window-event-mask,
;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
;; window-cursor
;; Accessor Group G (for GetGeometry):
;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
;; drawable-height, drawable-border-width
;; Setf Group G (for ConfigureWindow):
;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
;; window-priority
(let ((state-entry (gensym)))
;; alist of (drawable attributes attribute-changes geometry geometry-changes)
`(with-stack-list (,state-entry ,drawable nil nil nil nil)
(with-stack-list* (*window-attributes* ,state-entry *window-attributes*)
(multiple-value-prog1
(progn ,@body)
(cleanup-state-entry ,state-entry))))))
(defun cleanup-state-entry (state)
;; Return buffers to the free-list
(let ((entry (state-attributes state)))
(when entry (deallocate-context entry)))
(let ((entry (state-attribute-changes state)))
(when entry
(put-window-attribute-changes (car state) entry)
(deallocate-gcontext-state entry)))
(let ((entry (state-geometry state)))
(when entry (deallocate-context entry)))
(let ((entry (state-geometry-changes state)))
(when entry
(put-drawable-geometry-changes (car state) entry)
(deallocate-gcontext-state entry))))
(defun change-window-attribute (window number value)
;; Called from window attribute SETF's to alter an attribute value
;; number is the change-attributes request mask bit number
(declare (type window window)
(type card8 number)
(type card32 value))
(let ((state-entry nil)
(changes nil))
(if (and *window-attributes*
(setq state-entry (assoc window (the list *window-attributes*)
:test (window-equal-function))))
(progn ; Within a WITH-STATE - cache changes
(setq changes (state-attribute-changes state-entry))
(unless changes
(setq changes (allocate-gcontext-state))
(setf (state-attribute-changes state-entry) changes)
(setf (aref changes 0) 0)) ;; Initialize mask to zero
(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+)
(window window)
(card32 (ash 1 number) value)))))
;;
;; These two are twins (change-window-attribute change-drawable-geometry)
;; If you change one, you probably need to change the other...
;;
(defun change-drawable-geometry (drawable number value)
;; Called from drawable geometry SETF's to alter an attribute value
;; number is the change-attributes request mask bit number
(declare (type drawable drawable)
(type card8 number)
(type card29 value))
(let ((state-entry nil)
(changes nil))
(if (and *window-attributes*
(setq state-entry (assoc drawable (the list *window-attributes*)
:test (drawable-equal-function))))
(progn ; Within a WITH-STATE - cache changes
(setq changes (state-geometry-changes state-entry))
(unless changes
(setq changes (allocate-gcontext-state))
(setf (state-geometry-changes state-entry) changes)
(setf (aref changes 0) 0)) ;; Initialize mask to zero
(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+)
(drawable drawable)
(card16 (ash 1 number))
(card29 value)))))
(defun get-window-attributes-buffer (window)
(declare (type window window))
(let ((state-entry nil)
(changes nil))
(or (and *window-attributes*
(setq state-entry (assoc window (the list *window-attributes*)
:test (window-equal-function)))
(null (setq changes (state-attribute-changes state-entry)))
(state-attributes state-entry))
(let ((display (window-display window)))
(with-display (display)
;; When SETF's have been done, flush changes to the server
(when changes
(put-window-attribute-changes window changes)
(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))
((window window))
(let ((repbuf (or (state-attributes state-entry) (allocate-context))))
(declare (type reply-buffer repbuf))
;; Copy into repbuf from reply buffer
(buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
(when state-entry (setf (state-attributes state-entry) repbuf))
repbuf)))))))
;;
;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer)
;; If you change one, you probably need to change the other...
;;
(defun get-drawable-geometry-buffer (drawable)
(declare (type drawable drawable))
(let ((state-entry nil)
(changes nil))
(or (and *window-attributes*
(setq state-entry (assoc drawable (the list *window-attributes*)
:test (drawable-equal-function)))
(null (setq changes (state-geometry-changes state-entry)))
(state-geometry state-entry))
(let ((display (drawable-display drawable)))
(with-display (display)
;; When SETF's have been done, flush changes to the server
(when changes
(put-drawable-geometry-changes drawable changes)
(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))
((drawable drawable))
(let ((repbuf (or (state-geometry state-entry) (allocate-context))))
(declare (type reply-buffer repbuf))
;; Copy into repbuf from reply buffer
(buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
(when state-entry (setf (state-geometry state-entry) repbuf))
repbuf)))))))
(defun put-window-attribute-changes (window changes)
;; change window attributes
;; Always from Called within a WITH-DISPLAY
(declare (type window window)
(type gcontext-state changes))
(let* ((display (window-display window))
(mask (aref changes 0)))
(declare (type display display)
(type mask32 mask))
(with-buffer-request (display +x-changewindowattributes+)
(window window)
(card32 mask)
(progn ;; Insert a word in the request for each one bit in the mask
(do ((bits mask (ash bits -1))
(request-size 2) ;Word count
(i 1 (index+ i 1))) ;Entry count
((zerop bits)
(card16-put 2 (index-incf request-size))
(index-incf (buffer-boffset display) (index* request-size 4)))
(declare (type mask32 bits)
(type array-index i request-size))
(when (oddp bits)
(card32-put (index* (index-incf request-size) 4) (aref changes i))))))))
;;
;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes)
;; If you change one, you probably need to change the other...
;;
(defun put-drawable-geometry-changes (window changes)
;; change window attributes or geometry (depending on request-number...)
;; Always from Called within a WITH-DISPLAY
(declare (type window window)
(type gcontext-state changes))
(let* ((display (window-display window))
(mask (aref changes 0)))
(declare (type display display)
(type mask16 mask))
(with-buffer-request (display +x-configurewindow+)
(window window)
(card16 mask)
(progn ;; Insert a word in the request for each one bit in the mask
(do ((bits mask (ash bits -1))
(request-size 2) ;Word count
(i 1 (index+ i 1))) ;Entry count
((zerop bits)
(card16-put 2 (incf request-size))
(index-incf (buffer-boffset display) (* request-size 4)))
(declare (type mask16 bits)
(type fixnum request-size)
(type array-index i))
(when (oddp bits)
(card29-put (* (incf request-size) 4) (aref changes i))))))))
(defmacro with-attributes ((window &rest options) &body body)
`(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window)))
(declare (type reply-buffer .with-attributes-reply-buffer.))
(prog1
(with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body)
(unless *window-attributes*
(deallocate-context .with-attributes-reply-buffer.)))))
;;
;; These two are twins (with-attributes with-geometry)
;; If you change one, you probably need to change the other...
;;
(defmacro with-geometry ((window &rest options) &body body)
`(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window)))
(declare (type reply-buffer .with-geometry-reply-buffer.))
(prog1
(with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body)
(unless *window-attributes*
(deallocate-context .with-geometry-reply-buffer.)))))
;;;-----------------------------------------------------------------------------
;;; Group A: (for GetWindowAttributes)
;;;-----------------------------------------------------------------------------
(defun window-visual (window)
(declare (type window window))
(declare (clx-values resource-id))
(with-attributes (window :sizes 32)
(resource-id-get 8)))
(defun window-visual-info (window)
(declare (type window window))
(declare (clx-values visual-info))
(with-attributes (window :sizes 32)
(visual-info (window-display window) (resource-id-get 8))))
(defun window-class (window)
(declare (type window window))
(declare (clx-values (member :input-output :input-only)))
(with-attributes (window :sizes 16)
(member16-get 12 :copy :input-output :input-only)))
(defun set-window-background (window background)
(declare (type window window)
(type (or (member :none :parent-relative) pixel pixmap) background))
(cond ((eq background :none) (change-window-attribute window 0 0))
((eq background :parent-relative) (change-window-attribute window 0 1))
((integerp background) ;; Background pixel
(change-window-attribute window 0 0) ;; pixmap :NONE
(change-window-attribute window 1 background))
((type? background 'pixmap) ;; Background pixmap
(change-window-attribute window 0 (pixmap-id background)))
(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)
(declare (type window window)
(type (or (member :copy) pixel pixmap) border))
(cond ((eq border :copy) (change-window-attribute window 2 0))
((type? border 'pixmap) ;; Border pixmap
(change-window-attribute window 2 (pixmap-id border)))
((integerp border) ;; Border pixel
(change-window-attribute window 3 border))
(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)
;; setf'able
(declare (type window window))
(declare (clx-values bit-gravity))
(with-attributes (window :sizes 8)
(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))
gravity)
(defsetf window-bit-gravity set-window-bit-gravity)
(defun window-gravity (window)
;; setf'able
(declare (type window window))
(declare (clx-values win-gravity))
(with-attributes (window :sizes 8)
(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))
gravity)
(defsetf window-gravity set-window-gravity)
(defun window-backing-store (window)
;; setf'able
(declare (type window window))
(declare (clx-values (member :not-useful :when-mapped :always)))
(with-attributes (window :sizes 8)
(member8-get 1 :not-useful :when-mapped :always)))
(defun set-window-backing-store (window when)
(change-window-attribute
window 6 (encode-type (member :not-useful :when-mapped :always) when))
when)
(defsetf window-backing-store set-window-backing-store)
(defun window-backing-planes (window)
;; setf'able
(declare (type window window))
(declare (clx-values pixel))
(with-attributes (window :sizes 32)
(card32-get 16)))
(defun set-window-backing-planes (window planes)
(change-window-attribute window 7 (encode-type card32 planes))
planes)
(defsetf window-backing-planes set-window-backing-planes)
(defun window-backing-pixel (window)
;; setf'able
(declare (type window window))
(declare (clx-values pixel))
(with-attributes (window :sizes 32)
(card32-get 20)))
(defun set-window-backing-pixel (window pixel)
(change-window-attribute window 8 (encode-type card32 pixel))
pixel)
(defsetf window-backing-pixel set-window-backing-pixel)
(defun window-save-under (window)
;; setf'able
(declare (type window window))
(declare (clx-values (member :off :on)))
(with-attributes (window :sizes 8)
(member8-get 24 :off :on)))
(defun set-window-save-under (window when)
(change-window-attribute window 10 (encode-type (member :off :on) when))
when)
(defsetf window-save-under set-window-save-under)
(defun window-override-redirect (window)
;; setf'able
(declare (type window window))
(declare (clx-values (member :off :on)))
(with-attributes (window :sizes 8)
(member8-get 27 :off :on)))
(defun set-window-override-redirect (window when)
(change-window-attribute window 9 (encode-type (member :off :on) when))
when)
(defsetf window-override-redirect set-window-override-redirect)
(defun window-event-mask (window)
;; setf'able
(declare (type window window))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 36)))
(defsetf window-event-mask (window) (event-mask)
(let ((em (gensym)))
`(let ((,em ,event-mask))
(declare (type event-mask ,em))
(change-window-attribute ,window 11 (encode-event-mask ,em))
,em)))
(defun window-do-not-propagate-mask (window)
;; setf'able
(declare (type window window))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 40)))
(defsetf window-do-not-propagate-mask (window) (device-event-mask)
(let ((em (gensym)))
`(let ((,em ,device-event-mask))
(declare (type device-event-mask ,em))
(change-window-attribute ,window 12 (encode-device-event-mask ,em))
,em)))
(defun window-colormap (window)
(declare (type window window))
(declare (clx-values (or null colormap)))
(with-attributes (window :sizes 32)
(let ((id (resource-id-get 28)))
(if (zerop id)
nil
(let ((colormap (lookup-colormap (window-display window) id)))
(unless (colormap-visual-info colormap)
(setf (colormap-visual-info colormap)
(visual-info (window-display window) (resource-id-get 8))))
colormap)))))
(defun set-window-colormap (window colormap)
(change-window-attribute
window 13 (encode-type (or (member :copy) colormap) colormap))
colormap)
(defsetf window-colormap set-window-colormap)
(defun window-cursor (window)
(declare (type window window))
(declare (clx-values cursor))
window
(error "~S can only be set" 'window-cursor))
(defun set-window-cursor (window cursor)
(change-window-attribute
window 14 (encode-type (or (member :none) cursor) cursor))
cursor)
(defsetf window-cursor set-window-cursor)
(defun window-colormap-installed-p (window)
(declare (type window window))
(declare (clx-values generalized-boolean))
(with-attributes (window :sizes 8)
(boolean-get 25)))
(defun window-all-event-masks (window)
(declare (type window window))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 32)))
(defun window-map-state (window)
(declare (type window window))
(declare (clx-values (member :unmapped :unviewable :viewable)))
(with-attributes (window :sizes 8)
(member8-get 26 :unmapped :unviewable :viewable)))
;;;-----------------------------------------------------------------------------
;;; Group G: (for GetGeometry)
;;;-----------------------------------------------------------------------------
(defun drawable-root (drawable)
(declare (type drawable drawable))
(declare (clx-values window))
(with-geometry (drawable :sizes 32)
(window-get 8 (drawable-display drawable))))
(defun drawable-x (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (clx-values int16))
(with-geometry (drawable :sizes 16)
(int16-get 12)))
(defun set-drawable-x (drawable x)
(change-drawable-geometry drawable 0 (encode-type int16 x))
x)
(defsetf drawable-x set-drawable-x)
(defun drawable-y (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (clx-values int16))
(with-geometry (drawable :sizes 16)
(int16-get 14)))
(defun set-drawable-y (drawable y)
(change-drawable-geometry drawable 1 (encode-type int16 y))
y)
(defsetf drawable-y set-drawable-y)
(defun drawable-width (drawable)
;; setf'able
;; Inside width, excluding border.
(declare (type drawable drawable))
(declare (clx-values card16))
(with-geometry (drawable :sizes 16)
(card16-get 16)))
(defun set-drawable-width (drawable width)
(change-drawable-geometry drawable 2 (encode-type card16 width))
width)
(defsetf drawable-width set-drawable-width)
(defun drawable-height (drawable)
;; setf'able
;; Inside height, excluding border.
(declare (type drawable drawable))
(declare (clx-values card16))
(with-geometry (drawable :sizes 16)
(card16-get 18)))
(defun set-drawable-height (drawable height)
(change-drawable-geometry drawable 3 (encode-type card16 height))
height)
(defsetf drawable-height set-drawable-height)
(defun drawable-depth (drawable)
(declare (type drawable drawable))
(declare (clx-values card8))
(with-geometry (drawable :sizes 8)
(card8-get 1)))
(defun drawable-border-width (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (clx-values integer))
(with-geometry (drawable :sizes 16)
(card16-get 20)))
(defun set-drawable-border-width (drawable width)
(change-drawable-geometry drawable 4 (encode-type card16 width))
width)
(defsetf drawable-border-width set-drawable-border-width)
(defun set-window-priority (mode window sibling)
(declare (type (member :above :below :top-if :bottom-if :opposite) mode)
(type window window)
(type (or null window) sibling))
(with-state (window)
(change-drawable-geometry
window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode))
(when sibling
(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))

31
src/clx/big-requests.lisp
View file

@ -1,31 +0,0 @@
;;; -*- 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.
(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)))))

1417
src/clx/buffer.lisp
View file

File diff suppressed because it is too large Load diff

184
src/clx/bufmac.lisp
View file

@ -1,184 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; This file contains macro definitions for the BUFFER object for Common-Lisp
;;; X windows version 11
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them.
(defmacro write-card8 (byte-index item)
`(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
(defmacro write-int8 (byte-index item)
`(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
(defmacro write-card16 (byte-index item)
#+clx-overlapping-arrays
`(aset-card16 (the card16 ,item) buffer-wbuf
(index+ buffer-woffset (index-ash ,byte-index -1)))
#-clx-overlapping-arrays
`(aset-card16 (the card16 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
(defmacro write-int16 (byte-index item)
#+clx-overlapping-arrays
`(aset-int16 (the int16 ,item) buffer-wbuf
(index+ buffer-woffset (index-ash ,byte-index -1)))
#-clx-overlapping-arrays
`(aset-int16 (the int16 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
(defmacro write-card32 (byte-index item)
#+clx-overlapping-arrays
`(aset-card32 (the card32 ,item) buffer-lbuf
(index+ buffer-loffset (index-ash ,byte-index -2)))
#-clx-overlapping-arrays
`(aset-card32 (the card32 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
(defmacro write-int32 (byte-index item)
#+clx-overlapping-arrays
`(aset-int32 (the int32 ,item) buffer-lbuf
(index+ buffer-loffset (index-ash ,byte-index -2)))
#-clx-overlapping-arrays
`(aset-int32 (the int32 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
(defmacro write-card29 (byte-index item)
#+clx-overlapping-arrays
`(aset-card29 (the card29 ,item) buffer-lbuf
(index+ buffer-loffset (index-ash ,byte-index -2)))
#-clx-overlapping-arrays
`(aset-card29 (the card29 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries
;; and always are written high-order byte first.
(defmacro write-char2b (byte-index item)
;; It is impossible to do an overlapping write, so only nonoverlapping here.
`(let ((%item ,item)
(%byte-index (index+ buffer-boffset ,byte-index)))
(declare (type card16 %item)
(type array-index %byte-index))
(aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index)
(aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1))))
(defmacro set-buffer-offset (value &environment env)
env
`(let ((.boffset. ,value))
(declare (type array-index .boffset.))
(setq buffer-boffset .boffset.)
#+clx-overlapping-arrays
,@(when (member 16 (macroexpand '(%buffer-sizes) env))
`((setq buffer-woffset (index-ash .boffset. -1))))
#+clx-overlapping-arrays
,@(when (member 32 (macroexpand '(%buffer-sizes) env))
`((setq buffer-loffset (index-ash .boffset. -2))))
#+clx-overlapping-arrays
.boffset.))
(defmacro advance-buffer-offset (value)
`(set-buffer-offset (index+ buffer-boffset ,value)))
(defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body)
(unless (listp sizes) (setq sizes (list sizes)))
`(let ((%buffer ,buffer))
(declare (type display %buffer))
,(declare-bufmac)
,(when length
`(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer))
(buffer-flush %buffer)))
(let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer))))
#-clx-overlapping-arrays
(buffer-bbuf (buffer-obuf8 %buffer))
#+clx-overlapping-arrays
,@(append
(when (member 8 sizes)
`((buffer-bbuf (buffer-obuf8 %buffer))))
(when (or (member 16 sizes) (member 160 sizes))
`((buffer-woffset (index-ash buffer-boffset -1))
(buffer-wbuf (buffer-obuf16 %buffer))))
(when (member 32 sizes)
`((buffer-loffset (index-ash buffer-boffset -2))
(buffer-lbuf (buffer-obuf32 %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)))
;;; This macro is just used internally in buffer
(defmacro writing-buffer-chunks (type args decls &body body)
(when (> (length body) 2)
(error "writing-buffer-chunks called with too many forms"))
(let* ((size (* 8 (index-increment type)))
(form #-clx-overlapping-arrays
(first body)
#+clx-overlapping-arrays ; XXX type dependencies
(or (second body)
(first body))))
`(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8))))
;; Loop filling the buffer
(do* (,@args
;; Number of bytes needed to output
(len ,(if (= size 8)
`(index- end start)
`(index-ash (index- end start) ,(truncate size 16)))
(index- len chunk))
;; Number of bytes available in buffer
(chunk (index-min len (index- (buffer-size buffer) buffer-boffset))
(index-min len (index- (buffer-size buffer) buffer-boffset))))
((not (index-plusp len)))
(declare ,@decls
(type array-index len chunk))
,form
(index-incf buffer-boffset chunk)
;; Flush the buffer
(when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer)))
(setf (buffer-boffset buffer) buffer-boffset)
(buffer-flush buffer)
(setq buffer-boffset (buffer-boffset buffer))
#+clx-overlapping-arrays
,(case size
(16 '(setq buffer-woffset (index-ash buffer-boffset -1)))
(32 '(setq buffer-loffset (index-ash buffer-boffset -2))))))
(setf (buffer-boffset buffer) (lround buffer-boffset)))))

33
src/clx/build-clx.lisp
View file

@ -1,33 +0,0 @@
;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
;;; 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:")))

5
src/clx/clx-module.lisp
View file

@ -1,5 +0,0 @@
;;;(in-package :xlib)
;;;(common-lisp:use-package (list :common-lisp))
(provide :clx)
(load "clx:defsystem.lisp")
(load-clx (translate-logical-pathname "CLX:"))

216
src/clx/clx.asd
View file

@ -1,216 +0,0 @@
;;; -*- Lisp -*- mode
;;; Original copyright message from defsystem.lisp:
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Portions Copyright (C) 1987 Texas Instruments Incorporated.
;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca.
;;;
;;; Permission is granted to any individual or institution to use,
;;; copy, modify, and distribute this software, provided that this
;;; complete copyright and permission notice is maintained, intact, in
;;; all copies and supporting documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is"
;;; without express or implied warranty.
;;;
;;; Franz Incorporated provides this software "as is" without express
;;; or implied warranty.
(defpackage :clx-system (:use :cl :asdf))
(in-package :clx-system)
(pushnew :clx-ansi-common-lisp *features*)
(defclass clx-source-file (cl-source-file) ())
(defclass xrender-source-file (clx-source-file) ())
;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of
;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-)
(defclass example-source-file (cl-source-file) ())
(defclass legacy-file (static-file) ())
(defsystem CLX
:depends-on (#+sbcl sb-bsd-sockets)
:version "0.7.2"
:serial t
:default-component-class clx-source-file
:components
((:file "package")
(:file "depdefs")
(:file "clx")
#-(or openmcl allegro) (:file "dependent")
#+openmcl (:file "dep-openmcl")
#+allegro (:file "dep-allegro")
(:file "macros")
(:file "bufmac")
(:file "buffer")
(:file "display")
(:file "gcontext")
(:file "input")
(:file "requests")
(:file "fonts")
(:file "graphics")
(:file "text")
(:file "attributes")
(:file "translate")
(:file "keysyms")
(:file "manager")
(:file "image")
(:file "resource")
#+allegro
(:file "excldep" :pathname "excldep.lisp")
(:module extensions
:pathname #.(make-pathname :directory '(:relative))
:components
((:file "shape")
(:file "big-requests")
(:file "xvidmode")
(:xrender-source-file "xrender")
(:file "glx")
(:file "gl" :depends-on ("glx"))
(:file "dpms")
(:file "xtest")
(:file "screensaver")
(:file "xinerama")))
(:module demo
:default-component-class example-source-file
:components
((:file "bezier")
;; KLUDGE: this requires "bezier" for proper operation,
;; but we don't declare that dependency here, because
;; asdf doesn't load example files anyway.
(:file "beziertest")
(:file "clclock")
(:file "clipboard")
(:file "clx-demos")
(:file "gl-test")
;; FIXME: compiling this generates 30-odd spurious code
;; deletion notes. Find out why, and either fix or
;; workaround the problem.
(:file "mandel")
(:file "menu")
(:file "zoid")))
(:module test
:default-component-class example-source-file
:components
((:file "image")
;; KLUDGE: again, this depends on "zoid"
(:file "trapezoid")))
(:static-file "NEWS")
(:static-file "CHANGES")
(:static-file "README")
(:static-file "README-R5")
(:legacy-file "exclMakefile")
(:legacy-file "exclREADME")
(:legacy-file "exclcmac" :pathname "exclcmac.lisp")
(:legacy-file "excldepc" :pathname "excldep.c")
(:legacy-file "sockcl" :pathname "sockcl.lisp")
(:legacy-file "socket" :pathname "socket.c")
(:legacy-file "defsystem" :pathname "defsystem.lisp")
(:legacy-file "provide" :pathname "provide.lisp")
(:legacy-file "cmudep" :pathname "cmudep.lisp")
(:module manual
;; TODO: teach asdf how to process texinfo files
:components ((:static-file "clx.texinfo")))
(:module debug
:default-component-class legacy-file
:components
((:file "debug" :pathname "debug.lisp")
(:file "describe" :pathname "describe.lisp")
(:file "event-test" :pathname "event-test.lisp")
(:file "keytrans" :pathname "keytrans.lisp")
(:file "trace" :pathname "trace.lisp")
(:file "util" :pathname "util.lisp")))))
(defmethod perform ((o load-op) (f example-source-file))
;; do nothing. We want to compile them when CLX is compiled, but
;; not load them when CLX is loaded.
t)
#+sbcl
(defmethod perform :around ((o compile-op) (f xrender-source-file))
;; RENDER would appear to be an inherently slow protocol; further,
;; it's not set in stone, and consequently we care less about speed
;; than we do about correctness.
(handler-bind ((sb-ext:compiler-note #'muffle-warning))
(call-next-method)))
#+sbcl
(defmethod perform :around ((o compile-op) (f clx-source-file))
;; our CLX library should compile without WARNINGs, and ideally
;; without STYLE-WARNINGs. Since it currently does, let's enforce
;; it here so that we can catch regressions easily.
(let ((on-warnings (operation-on-warnings o))
(on-failure (operation-on-failure o)))
(unwind-protect
(progn
(setf (operation-on-warnings o) :error
(operation-on-failure o) :error)
;; a variety of accessors, such as AREF-CARD32, are not
;; declared INLINE. Without this (non-ANSI)
;; static-type-inference behaviour, SBCL emits an extra 100
;; optimization notes (roughly one fifth of all of the
;; notes emitted). Since the internals are unlikely to
;; change much, and certainly the internals should stay in
;; sync, enabling this extension is a win. (Note that the
;; use of this does not imply that applications using CLX
;; calls that expand into calls to these accessors will be
;; optimized in the same way).
(let ((sb-ext:*derive-function-types* t)
(sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c))
(sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext)))
;; deeply unportable stuff, this. I will be shot. We
;; want to enable the dynamic-extent declarations in CLX.
(when (and sadx (sb-c::policy-quality-name-p sadx))
;; no way of setting it back short of yet more yukky stuff
(proclaim `(optimize (,sadx 3))))
(if sadx-var
(progv (list sadx-var) (list t)
(call-next-method))
(call-next-method))))
(setf (operation-on-warnings o) on-warnings
(operation-on-failure o) on-failure))))
#+sbcl
(defmethod perform :around (o (f clx-source-file))
;; SBCL signals an error if DEFCONSTANT is asked to redefine a
;; constant unEQLly. For CLX's purposes, however, we are defining
;; structured constants (lists and arrays) not for EQLity, but for
;; the purposes of constant-folding operations such as (MEMBER FOO
;; +BAR+), so it is safe to abort the redefinition provided the
;; structured data is sufficiently equal.
(handler-bind
((sb-ext:defconstant-uneql
(lambda (c)
;; KLUDGE: this really means "don't warn me about
;; efficiency of generic array access, please"
(declare (optimize (sb-ext:inhibit-warnings 3)))
(let ((old (sb-ext:defconstant-uneql-old-value c))
(new (sb-ext:defconstant-uneql-new-value c)))
(typecase old
(list (when (equal old new) (abort c)))
(string (when (and (typep new 'string)
(string= old new))
(abort c)))
(simple-vector
(when (and (typep new 'simple-vector)
(= (length old) (length new))
(every #'eql old new))
(abort c)))
(array
(when (and (typep new 'array)
(equal (array-dimensions old)
(array-dimensions new))
(equal (array-element-type old)
(array-element-type new))
(dotimes (i (array-total-size old) t)
(unless (eql (row-major-aref old i)
(row-major-aref new i))
(return nil))))
(abort c))))))))
(call-next-method)))

940
src/clx/clx.lisp
View file

@ -1,940 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;;
;;; 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.
;;;
;; Primary Interface Author:
;; Robert W. Scheifler
;; MIT Laboratory for Computer Science
;; 545 Technology Square, Room 418
;; Cambridge, MA 02139
;; rws@zermatt.lcs.mit.edu
;; Design Contributors:
;; Dan Cerys, Texas Instruments
;; Scott Fahlman, CMU
;; Charles Hornig, Symbolics
;; John Irwin, Franz
;; Kerry Kimbrough, Texas Instruments
;; Chris Lindblad, MIT
;; Rob MacLachlan, CMU
;; Mike McMahon, Symbolics
;; David Moon, Symbolics
;; LaMott Oren, Texas Instruments
;; Daniel Weinreb, Symbolics
;; John Wroclawski, MIT
;; Richard Zippel, Symbolics
;; Primary Implementation Author:
;; LaMott Oren, Texas Instruments
;; Implementation Contributors:
;; Charles Hornig, Symbolics
;; John Irwin, Franz
;; Chris Lindblad, MIT
;; Robert Scheifler, MIT
;;;
;;; Change history:
;;;
;;; Date Author Description
;;; -------------------------------------------------------------------------------------
;;; 04/07/87 R.Scheifler Created code stubs
;;; 04/08/87 L.Oren Started Implementation
;;; 05/11/87 L.Oren Included draft 3 revisions
;;; 07/07/87 L.Oren Untested alpha release to MIT
;;; 07/17/87 L.Oren Alpha release
;;; 08/**/87 C.Lindblad Rewrite of buffer code
;;; 08/**/87 et al Various random bug fixes
;;; 08/**/87 R.Scheifler General syntactic and portability cleanups
;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing
;;; 09/02/87 L.Oren Change events from resource-ids to objects
;;; 12/24/87 R.Budzianowski KCL support
;;; 12/**/87 J.Irwin ExCL 2.0 support
;;; 01/20/88 L.Oren Add server extension mechanisms
;;; 01/20/88 L.Oren Only force output when blocking on input
;;; 01/20/88 L.Oren Uniform support for :event-window on events
;;; 01/28/88 L.Oren Add window manager property functions
;;; 01/28/88 L.Oren Add character translation facility
;;; 02/**/87 J.Irwin Allegro 2.2 support
;;; This is considered a somewhat changeable interface. Discussion of better
;;; integration with CLOS, support for user-specified subclassess of basic
;;; 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.
;; Note: all of the following is in the package XLIB.
(in-package :xlib)
(pushnew :clx *features*)
(pushnew :xlib *features*)
(defparameter *version* "MIT R5.02")
(pushnew :clx-mit-r4 *features*)
(pushnew :clx-mit-r5 *features*)
(defparameter *protocol-major-version* 11.)
(defparameter *protocol-minor-version* 0)
(defparameter *x-tcp-port* 6000) ;; add display number
;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
;; the relationships should be fairly obvious. We have no intention of writing yet
;; another moby document for this interface.
;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
;; These types are defined solely by a functional interface; we do not specify
;; whether they are implemented as structures or flavors or ... Although functions
;; below are written using DEFUN, this is not an implementation requirement (although
;; it is a requirement that they be functions as opposed to macros or special forms).
;; It is unclear whether with-slots in the Common Lisp Object System must work on
;; them.
;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
;; compound objects, rather than as integer resource-ids. This allows applications
;; to deal with multiple displays without having an explicit display argument in the
;; most common functions. Every function uses the display object indicated by the
;; first argument that is or contains a display; it is an error if arguments contain
;; different displays, and predictable results are not guaranteed.
;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following
;; five functions:
;(defun make-<mumble> (display resource-id)
; ;; This function should almost never be called by applications, except in handling
; ;; events. To minimize consing in some implementations, this may use a cache in
; ;; the display. Make-gcontext creates with :cache-p nil. Make-font creates with
; ;; cache-p true.
; (declare (type display display)
; (type integer resource-id)
; (clx-values <mumble>)))
;(defun <mumble>-display (<mumble>)
; (declare (type <mumble> <mumble>)
; (clx-values display)))
;(defun <mumble>-id (<mumble>)
; (declare (type <mumble> <mumble>)
; (clx-values integer)))
;(defun <mumble>-equal (<mumble>-1 <mumble>-2)
; (declare (type <mumble> <mumble>-1 <mumble>-2)))
;(defun <mumble>-p (<mumble>-1 <mumble>-2)
; (declare (type <mumble> <mumble>-1 <mumble>-2)
; (clx-values boolean)))
(deftype generalized-boolean () 't) ; (or null (not null))
(deftype card32 () '(unsigned-byte 32))
(deftype card29 () '(unsigned-byte 29))
(deftype card24 () '(unsigned-byte 24))
(deftype int32 () '(signed-byte 32))
(deftype card16 () '(unsigned-byte 16))
(deftype int16 () '(signed-byte 16))
(deftype card8 () '(unsigned-byte 8))
(deftype int8 () '(signed-byte 8))
(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.
(deftype rgb-val () '(real 0 1))
; Note that we are explicitly using a different angle representation than what
; is actually transmitted in the protocol.
(deftype angle () '(real #.(* -2 pi) #.(* 2 pi)))
(deftype mask32 () 'card32)
(deftype mask16 () 'card16)
(deftype pixel () '(unsigned-byte 32))
(deftype image-depth () '(integer 0 32))
(deftype resource-id () 'card29)
(deftype keysym () 'card32)
; The following functions are provided by color objects:
; The intention is that IHS and YIQ and CYM interfaces will also exist.
; Note that we are explicitly using a different spectrum representation
; than what is actually transmitted in the protocol.
(def-clx-class (color (:constructor make-color-internal (red green blue))
(:copier nil) (:print-function print-color))
(red 0.0 :type rgb-val)
(green 0.0 :type rgb-val)
(blue 0.0 :type rgb-val))
(defun print-color (color stream depth)
(declare (type color color)
(ignore depth))
(print-unreadable-object (color stream :type t)
(prin1 (color-red color) stream)
(write-string " " stream)
(prin1 (color-green color) stream)
(write-string " " stream)
(prin1 (color-blue color) stream)))
(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys)
(declare (type rgb-val red green blue))
(declare (clx-values color))
(make-color-internal red green blue))
(defun color-rgb (color)
(declare (type color color))
(declare (clx-values red green blue))
(values (color-red color) (color-green color) (color-blue color)))
(def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format))
(unit 8 :type (member 8 16 32))
(pad 8 :type (member 8 16 32))
(lsb-first-p nil :type generalized-boolean))
(defun print-bitmap-format (bitmap-format stream depth)
(declare (type bitmap-format bitmap-format)
(ignore depth))
(print-unreadable-object (bitmap-format stream :type t)
(format stream "unit ~D pad ~D ~:[M~;L~]SB first"
(bitmap-format-unit bitmap-format)
(bitmap-format-pad bitmap-format)
(bitmap-format-lsb-first-p bitmap-format))))
(def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format))
(depth 0 :type image-depth)
(bits-per-pixel 8 :type (member 1 4 8 12 16 24 32))
(scanline-pad 8 :type (member 8 16 32)))
(defun print-pixmap-format (pixmap-format stream depth)
(declare (type pixmap-format pixmap-format)
(ignore depth))
(print-unreadable-object (pixmap-format stream :type t)
(format stream "depth ~D bits-per-pixel ~D scanline-pad ~D"
(pixmap-format-depth pixmap-format)
(pixmap-format-bits-per-pixel pixmap-format)
(pixmap-format-scanline-pad pixmap-format))))
(defparameter *atom-cache-size* 200)
(defparameter *resource-id-map-size* 500)
(def-clx-class (display (:include buffer)
(:constructor make-display-internal)
(:print-function print-display)
(:copier nil))
(host) ; Server Host
(display 0 :type integer) ; Display number on host
(after-function nil) ; Function to call after every request
(event-lock
(make-process-lock "CLX Event Lock")) ; with-event-queue lock
(event-queue-lock
(make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock
(event-queue-tail ; last event in the event queue
nil :type (or null reply-buffer))
(event-queue-head ; Threaded queue of events
nil :type (or null reply-buffer))
(atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*)
:type hash-table) ; Hash table relating atoms keywords
; to atom id's
(font-cache nil) ; list of font
(protocol-major-version 0 :type card16) ; Major version of server's X protocol
(protocol-minor-version 0 :type card16) ; minor version of servers X protocol
(vendor-name "" :type string) ; vendor of the server hardware
(resource-id-base 0 :type resource-id) ; resouce ID base
(resource-id-mask 0 :type resource-id) ; resource ID mask bits
(resource-id-byte nil) ; resource ID mask field (used with DPB & LDB)
(resource-id-count 0 :type resource-id) ; resource ID mask count
; (used for allocating ID's)
(resource-id-map (make-hash-table :test (resource-id-map-test)
:size *resource-id-map-size*)
:type hash-table) ; hash table maps resource-id's to
; objects (used in lookup functions)
(xid 'resourcealloc) ; allocator function
(byte-order #+clx-little-endian :lsbfirst ; connection byte order
#-clx-little-endian :msbfirst)
(release-number 0 :type card32) ; release of the server
(max-request-length 0 :type card16) ; maximum number 32 bit words in request
(default-screen) ; default screen for operations
(roots nil :type list) ; List of screens
(motion-buffer-size 0 :type card32) ; size of motion buffer
(xdefaults) ; contents of defaults from server
(image-lsb-first-p nil :type generalized-boolean)
(bitmap-format (make-bitmap-format) ; Screen image info
:type bitmap-format)
(pixmap-formats nil :type sequence) ; list of pixmap formats
(min-keycode 0 :type card8) ; minimum key-code
(max-keycode 0 :type card8) ; maximum key-code
(error-handler 'default-error-handler) ; Error handler function
(close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode
(authorization-name "" :type string)
(authorization-data "" :type (or (array (unsigned-byte 8)) string))
(last-width nil :type (or null card29)) ; Accumulated width of last string
(keysym-mapping nil ; Keysym mapping cached from server
:type (or null (array * (* *))))
(modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms
(keysym-translation nil :type list) ; An alist of (keysym object function)
; for display-local keysyms
(extension-alist nil :type list) ; extension alist, which has elements:
; (name major-opcode first-event first-error)
(event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys
(performance-info) ; Hook for gathering performance info
(trace-history) ; Hook for debug trace
(plist nil :type list) ; hook for extension to hang data
;; These slots are used to manage multi-process input.
(input-in-progress nil) ; Some process reading from the stream.
; Updated with CONDITIONAL-STORE.
(pending-commands nil) ; Threaded list of PENDING-COMMAND objects
; for all commands awaiting replies.
; Protected by WITH-EVENT-QUEUE-INTERNAL.
(asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects
; containing error messages for commands
; which did not expect replies.
; Protected by WITH-EVENT-QUEUE-INTERNAL.
(report-asynchronous-errors ; When to report asynchronous errors
'(:immediately) :type list) ; The keywords that can be on this list
; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING,
; and :AFTER-FINISH-OUTPUT
(event-process nil) ; Process ID of process awaiting events.
; Protected by WITH-EVENT-QUEUE.
(new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the
; event queue.
; Protected by WITH-EVENT-QUEUE.
(current-event-symbol ; Bound with PROGV by event handling macros
(list (gensym) (gensym)) :type cons)
(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
#-allegro (princ (display-host display) stream)
#+allegro (write-string (string (display-host display)) stream)
(write-string ":" stream)
(princ (display-display display) stream))
(t
(write-string "(no display)" stream)))
display)
(defun print-display (display stream depth)
(declare (type display display)
(ignore depth))
(print-unreadable-object (display stream :type t)
(print-display-name display stream)
(write-string " (" stream)
(write-string (display-vendor-name display) stream)
(write-string " R" stream)
(prin1 (display-release-number display) stream)
(write-string ")" stream)))
;;(deftype drawable () '(or window pixmap))
(def-clx-class (drawable (:copier nil) (:print-function print-drawable))
(id 0 :type resource-id)
(display nil :type (or null display))
(plist nil :type list) ; Extension hook
)
(defun print-drawable (drawable stream depth)
(declare (type drawable drawable)
(ignore depth))
(print-unreadable-object (drawable stream :type t)
(print-display-name (drawable-display drawable) stream)
(write-string " " stream)
(let ((*print-base* 16)) (prin1 (drawable-id drawable) stream))))
(def-clx-class (window (:include drawable) (:copier nil)
(:print-function print-drawable))
)
(def-clx-class (pixmap (:include drawable) (:copier nil)
(:print-function print-drawable))
)
(def-clx-class (visual-info (:copier nil) (:print-function print-visual-info))
(id 0 :type resource-id)
(display nil :type (or null display))
(class :static-gray :type (member :static-gray :static-color :true-color
:gray-scale :pseudo-color :direct-color))
(red-mask 0 :type pixel)
(green-mask 0 :type pixel)
(blue-mask 0 :type pixel)
(bits-per-rgb 1 :type card8)
(colormap-entries 0 :type card16)
(plist nil :type list) ; Extension hook
)
(defun print-visual-info (visual-info stream depth)
(declare (type visual-info visual-info)
(ignore depth))
(print-unreadable-object (visual-info stream :type t)
(prin1 (visual-info-bits-per-rgb visual-info) stream)
(write-string "-bit " stream)
(princ (visual-info-class visual-info) stream)
(write-string " " stream)
(print-display-name (visual-info-display visual-info) stream)
(write-string " " stream)
(prin1 (visual-info-id visual-info) stream)))
(def-clx-class (colormap (:copier nil) (:print-function print-colormap))
(id 0 :type resource-id)
(display nil :type (or null display))
(visual-info nil :type (or null visual-info))
)
(defun print-colormap (colormap stream depth)
(declare (type colormap colormap)
(ignore depth))
(print-unreadable-object (colormap stream :type t)
(when (colormap-visual-info colormap)
(princ (visual-info-class (colormap-visual-info colormap)) stream)
(write-string " " stream))
(print-display-name (colormap-display colormap) stream)
(write-string " " stream)
(prin1 (colormap-id colormap) stream)))
(def-clx-class (cursor (:copier nil) (:print-function print-cursor))
(id 0 :type resource-id)
(display nil :type (or null display))
)
(defun print-cursor (cursor stream depth)
(declare (type cursor cursor)
(ignore depth))
(print-unreadable-object (cursor stream :type t)
(print-display-name (cursor-display cursor) stream)
(write-string " " stream)
(prin1 (cursor-id cursor) stream)))
; Atoms are accepted as strings or symbols, and are always returned as keywords.
; Protocol-level integer atom ids are hidden, using a cache in the display object.
(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))
(deftype stringable () '(or string symbol))
(deftype fontable () '(or stringable font))
; Nil stands for CurrentTime.
(deftype timestamp () '(or null card32))
(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))
(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
:center :east :south-west :south :south-east :static))
(deftype grab-status ()
'(member :success :already-grabbed :invalid-time :not-viewable))
; An association list.
(deftype alist (key-type-and-name datum-type-and-name)
(declare (ignore key-type-and-name datum-type-and-name))
'list)
(deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list)
(deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence)
; A sequence, containing zero or more repetitions of the given elements,
; with the elements expressed as (type name).
(deftype repeat-seq (&rest elts) elts 'sequence)
(deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
(deftype arc-seq ()
'(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
(angle angle1) (angle angle2)))
(deftype gcontext-state () 'simple-vector)
(def-clx-class (gcontext (:copier nil) (:print-function print-gcontext))
;; The accessors convert to CLX data types.
(id 0 :type resource-id)
(display nil :type (or null display))
(drawable nil :type (or null drawable))
(cache-p t :type generalized-boolean)
(server-state (allocate-gcontext-state) :type gcontext-state)
(local-state (allocate-gcontext-state) :type gcontext-state)
(plist nil :type list) ; Extension hook
(next nil #-explorer :type #-explorer (or null gcontext))
)
(defun print-gcontext (gcontext stream depth)
(declare (type gcontext gcontext)
(ignore depth))
(print-unreadable-object (gcontext stream :type t)
(print-display-name (gcontext-display gcontext) stream)
(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))
(deftype event-mask-class ()
'(member :key-press :key-release :owner-grab-button :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 :exposure :visibility-change
:structure-notify :resize-redirect :substructure-notify :substructure-redirect
:focus-change :property-change :colormap-change :keymap-state))
(deftype event-mask ()
'(or mask32 (clx-list event-mask-class)))
(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
: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 ()
'(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))
(deftype device-event-mask-class ()
'(member :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 ()
'(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))
(deftype modifier-key ()
'(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
(deftype modifier-mask ()
'(or (member :any) mask16 (clx-list modifier-key)))
(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))
(deftype gcontext-key ()
'(member :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 event-key ()
'(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
:illegal-request :implementation :length :match :name :pixmap :value :window))
(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))
(deftype boole-constant ()
`(member ,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))
(def-clx-class (screen (:copier nil) (:print-function print-screen))
(root nil :type (or null window))
(width 0 :type card16)
(height 0 :type card16)
(width-in-millimeters 0 :type card16)
(height-in-millimeters 0 :type card16)
(depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals)))
(root-depth 1 :type image-depth)
(root-visual-info nil :type (or null visual-info))
(default-colormap nil :type (or null colormap))
(white-pixel 0 :type pixel)
(black-pixel 1 :type pixel)
(min-installed-maps 1 :type card16)
(max-installed-maps 1 :type card16)
(backing-stores :never :type (member :never :when-mapped :always))
(save-unders-p nil :type generalized-boolean)
(event-mask-at-open 0 :type mask32)
(plist nil :type list) ; Extension hook
)
(defun print-screen (screen stream depth)
(declare (type screen screen)
(ignore depth))
(print-unreadable-object (screen stream :type t)
(let ((display (drawable-display (screen-root screen))))
(print-display-name display stream)
(write-string "." stream)
(princ (position screen (display-roots display)) stream))
(write-string " " stream)
(prin1 (screen-width screen) stream)
(write-string "x" stream)
(prin1 (screen-height screen) stream)
(write-string "x" stream)
(prin1 (screen-root-depth screen) stream)
(when (screen-root-visual-info screen)
(write-string " " stream)
(princ (visual-info-class (screen-root-visual-info screen)) stream))))
(defun screen-root-visual (screen)
(declare (type screen screen)
(clx-values resource-id))
(visual-info-id (screen-root-visual-info screen)))
;; The list contains alternating keywords and integers.
(deftype font-props () 'list)
(def-clx-class (font-info (:copier nil) (:predicate nil))
(direction :left-to-right :type draw-direction)
(min-char 0 :type card16) ;; First character in font
(max-char 0 :type card16) ;; Last character in font
(min-byte1 0 :type card8) ;; The following are for 16 bit fonts
(max-byte1 0 :type card8) ;; and specify min&max values for
(min-byte2 0 :type card8) ;; the two character bytes
(max-byte2 0 :type card8)
(all-chars-exist-p nil :type generalized-boolean)
(default-char 0 :type card16)
(min-bounds nil :type (or null vector))
(max-bounds nil :type (or null vector))
(ascent 0 :type int16)
(descent 0 :type int16)
(properties nil :type font-props))
(def-clx-class (font (:constructor make-font-internal) (:copier nil)
(:print-function print-font))
(id-internal nil :type (or null resource-id)) ;; NIL when not opened
(display nil :type (or null display))
(reference-count 0 :type fixnum)
(name "" :type (or null string)) ;; NIL when ID is for a GContext
(font-info-internal nil :type (or null font-info))
(char-infos-internal nil :type (or null (simple-array int16 (*))))
(local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally
(plist nil :type list) ; Extension hook
)
(defun print-font (font stream depth)
(declare (type font font)
(ignore depth))
(print-unreadable-object (font stream :type t)
(if (font-name font)
(princ (font-name font) stream)
(write-string "(gcontext)" stream))
(write-string " " stream)
(print-display-name (font-display font) stream)
(when (font-id-internal font)
(write-string " " stream)
(prin1 (font-id font) stream))))
(defun font-id (font)
;; Get font-id, opening font if needed
(or (font-id-internal font)
(open-font-internal font)))
(defun font-font-info (font)
(or (font-font-info-internal font)
(query-font font)))
(defun font-char-infos (font)
(or (font-char-infos-internal font)
(progn (query-font font)
(font-char-infos-internal font))))
(defun make-font (&key id
display
(reference-count 0)
(name "")
(local-only-p t)
font-info-internal)
(make-font-internal :id-internal id
:display display
:reference-count reference-count
:name name
:local-only-p local-only-p
:font-info-internal font-info-internal))
; For each component (<name> <unspec> :type <type>) of font-info,
; there is a corresponding function:
;(defun font-<name> (font)
; (declare (type font font)
; (clx-values <type>)))
(macrolet ((make-font-info-accessors (useless-name &body fields)
`(within-definition (,useless-name make-font-info-accessors)
,@(mapcar
#'(lambda (field)
(let* ((type (second field))
(n (string (first field)))
(name (xintern 'font- n))
(accessor (xintern 'font-info- n)))
`(defun ,name (font)
(declare (type font font))
(declare (clx-values ,type))
(,accessor (font-font-info font)))))
fields))))
(make-font-info-accessors ignore
(direction draw-direction)
(min-char card16)
(max-char card16)
(min-byte1 card8)
(max-byte1 card8)
(min-byte2 card8)
(max-byte2 card8)
(all-chars-exist-p generalized-boolean)
(default-char card16)
(min-bounds vector)
(max-bounds vector)
(ascent int16)
(descent int16)
(properties font-props)))
(defun font-property (font name)
(declare (type font font)
(type keyword name))
(declare (clx-values (or null int32)))
(getf (font-properties font) name))
(macrolet ((make-mumble-equal (type)
;; Since caching is only done for objects created by the
;; client, we must always compare ID and display for
;; non-identical mumbles.
(let ((predicate (xintern type '-equal))
(id (xintern type '-id))
(dpy (xintern type '-display)))
`(within-definition (,type make-mumble-equal)
(defun ,predicate (a b)
(declare (type ,type a b))
(or (eql a b)
(and (= (,id a) (,id b))
(eq (,dpy a) (,dpy b)))))))))
(make-mumble-equal window)
(make-mumble-equal pixmap)
(make-mumble-equal cursor)
(make-mumble-equal font)
(make-mumble-equal gcontext)
(make-mumble-equal colormap)
(make-mumble-equal drawable))
;;;
;;; Event-mask encode/decode functions
;;; 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.
(declare (type (simple-array keyword (*)) key-vector)
(type (or mask32 list) key-list))
(declare (clx-values (or mask32 null)))
(typecase key-list
(mask32 key-list)
(list (let ((mask 0))
(dolist (key key-list mask)
(let ((bit (position key (the vector key-vector) :test #'eq)))
(unless bit
(x-type-error key key-type))
(setq mask (logior mask (ash 1 bit)))))))))
(defun decode-mask (key-vector mask)
(declare (type (simple-array keyword (*)) key-vector)
(type mask32 mask))
(declare (clx-values list))
(do ((m mask (ash m -1))
(bit 0 (1+ bit))
(len (length key-vector))
(result nil))
((or (zerop m) (>= bit len)) result)
(declare (type mask32 m)
(fixnum bit len)
(list result))
(when (oddp m)
(push (aref key-vector bit) result))))
(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)
(x-type-error event-mask 'event-mask)))
(defun make-event-mask (&rest keys)
;; This is only defined for core events.
;; 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))
(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))
(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
'device-event-mask-class)
(x-type-error device-event-mask 'device-event-mask)))
(defun encode-modifier-mask (modifier-mask)
(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)
(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)
(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))
(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))
(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
'pointer-event-mask-class)
(x-type-error pointer-event-mask 'pointer-event-mask)))

19
src/clx/cmudep.lisp
View file

@ -1,19 +0,0 @@
;;; -*- 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: /loaclhost/usr/local/src/cvs/clx/cmudep.lisp,v 1.1 2000/07/02 19:19:46 dan Exp $")
;;;
;;; **********************************************************************
;;;
(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))

77
src/clx/debug/debug.lisp
View file

@ -1,77 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; Patch-file:T -*-
;;; CLX debugging code
;;;
;;; 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.
;;;
;;; Created 04/09/87 14:30:41 by LaMott G. OREN
(in-package :xlib)
(export '(display-listen
readflush
check-buffer
check-finish
check-force
clear-next))
(defun display-listen (display)
(listen (display-input-stream display)))
(defun readflush (display)
;; Flushes Display's input stream, returning what was there
(let ((stream (display-input-stream display)))
(loop while (listen stream) collect (read-byte stream))))
;;-----------------------------------------------------------------------------
;; The following are useful display-after functions
(defun check-buffer (display)
;; Ensure the output buffer in display is correct
(with-buffer-output (display :length :none :sizes (8 16))
(do* ((i 0 (+ i length))
request
length)
((>= i buffer-boffset)
(unless (= i buffer-boffset)
(warn "Buffer size ~d Requests end at ~d" buffer-boffset i)))
(let ((buffer-boffset 0)
#+clx-overlapping-arrays
(buffer-woffset 0))
(setq request (card8-get i))
(setq length (* 4 (card16-get (+ i 2)))))
(when (zerop request)
(warn "Zero request in buffer")
(return nil))
(when (zerop length)
(warn "Zero length in buffer")
(return nil)))))
(defun check-finish (display)
(check-buffer display)
(display-finish-output display))
(defun check-force (display)
(check-buffer display)
(display-force-output display))
(defun clear-next (display)
;; Never append requests
(setf (display-last-request display) nil))
;; End of file

1243
src/clx/debug/describe.lisp
View file

File diff suppressed because it is too large Load diff

237
src/clx/debug/event-test.lisp
View file

@ -1,237 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*-
(in-package :xtest :use '(:xlib :lisp))
(defstruct event
key ; Event key
display ; Display event was reported to
;; The following are from the CLX event
code
state
time
event-window
root
drawable
window
child
parent
root-x
root-y
x
y
width
height
border-width
override-redirect-p
same-screen-p
configure-p
hint-p
kind
mode
keymap
focus-p
count
major
minor
above-sibling
place
atom
selection
requestor
target
property
colormap
new-p
installed-p
format
type
data
send-event-p
)
(defun process-input (display &optional timeout)
"Process one event"
(declare (type display display) ; The display (from initialize-clue)
(type (or null number) timeout) ; optional timeout in seconds
(values (or null character))) ; Returns NIL only if timeout exceeded
(let ((event (make-event)))
(setf (event-display event) display)
(macrolet ((set-event (&rest parameters)
`(progn ,@(mapcar #'(lambda (parm)
`(setf (,(intern (concatenate 'string
(string 'event-)
(string parm)))
event) ,parm))
parameters)))
(dispatch (contact)
`(dispatch-event event event-key send-event-p ,contact)))
(let ((result
(xlib:event-case (display :timeout timeout :force-output-p t)
((:key-press :key-release :button-press :button-release)
(code time root window child root-x root-y x y
state same-screen-p event-key send-event-p)
(set-event code time root window child root-x root-y x y
state same-screen-p)
(dispatch window))
(:motion-notify
(hint-p time root window child root-x root-y x y
state same-screen-p event-key send-event-p)
(set-event hint-p time root window child root-x root-y x y
state same-screen-p)
(dispatch window))
((:enter-notify :leave-notify)
(kind time root window child root-x root-y x y
state mode focus-p same-screen-p event-key send-event-p)
(set-event kind time root window child root-x root-y x y
state mode focus-p same-screen-p)
(dispatch window))
((:focus-in :focus-out)
(kind window mode event-key send-event-p)
(set-event kind window mode)
(dispatch window))
(:keymap-notify
(window keymap event-key send-event-p)
(set-event window keymap)
(dispatch window))
(:exposure
(window x y width height count event-key send-event-p)
(set-event window x y width height count)
(dispatch window))
(:graphics-exposure
(drawable x y width height count major minor event-key send-event-p)
(set-event drawable x y width height count major minor)
(dispatch drawable))
(:no-exposure
(drawable major minor event-key send-event-p)
(set-event drawable major minor)
(dispatch drawable))
(:visibility-notify
(window state event-key send-event-p)
(set-event window state)
(dispatch window))
(:create-notify
(parent window x y width height border-width
override-redirect-p event-key send-event-p)
(set-event parent window x y width height border-width
override-redirect-p)
(dispatch parent))
(:destroy-notify
(event-window window event-key send-event-p)
(set-event event-window window)
(dispatch event-window))
(:unmap-notify
(event-window window configure-p event-key send-event-p)
(set-event event-window window configure-p)
(dispatch event-window))
(:map-notify
(event-window window override-redirect-p event-key send-event-p)
(set-event event-window window override-redirect-p)
(dispatch event-window))
(:map-request
(parent window event-key send-event-p)
(set-event parent window)
(dispatch parent))
(:reparent-notify
(event-window window parent x y override-redirect-p event-key send-event-p)
(set-event event-window window parent x y override-redirect-p)
(dispatch event-window))
(:configure-notify
(event-window window above-sibling x y width height border-width
override-redirect-p event-key send-event-p)
(set-event event-window window above-sibling x y width height
border-width override-redirect-p)
(dispatch event-window))
(:configure-request
(parent window above-sibling x y width height border-width event-key send-event-p)
(set-event parent window above-sibling x y width height border-width)
(dispatch parent))
(:gravity-notify
(event-window window x y event-key send-event-p)
(set-event event-window window x y)
(dispatch event-window))
(:resize-request
(window width height event-key send-event-p)
(set-event window width height)
(dispatch window))
(:circulate-notify
(event-window window parent place event-key send-event-p)
(set-event event-window window parent place)
(dispatch event-window))
(:circulate-request
(parent window place event-key send-event-p)
(set-event parent window place)
(dispatch parent))
(:property-notify
(window atom time state event-key send-event-p)
(set-event window atom time state)
(dispatch window))
(:selection-clear
(time window selection event-key send-event-p)
(set-event time window selection)
(dispatch window))
(:selection-request
(time window requestor selection target property event-key send-event-p)
(set-event time window requestor selection target property)
(dispatch window))
(:selection-notify
(time window selection target property event-key send-event-p)
(set-event time window selection target property)
(dispatch window))
(:colormap-notify
(window colormap new-p installed-p event-key send-event-p)
(set-event window colormap new-p installed-p)
(dispatch window))
(:client-message
(format window type data event-key send-event-p)
(set-event format window type data)
(dispatch window))
(:mapping-notify
(request start count)
(mapping-notify display request start count)) ;; Special case
)))
(and result t)))))
(defun event-case-test (display)
;; Tests universality of display, event-key, event-code, send-event-p and event-window
(event-case (display)
((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)
(display event-key event-code send-event-p event-window)
(print (list display event-key event-code send-event-p event-window)))
(mapping-notify ;; mapping-notify doesn't have event-window
(display event-key event-code send-event-p)
(print (list display event-key event-code send-event-p)))
))

266
src/clx/debug/keytrans.lisp
View file

@ -1,266 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX keysym-translation test programs
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(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))))
(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)))
(format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym))))))
(defun check-lowercase-keysyms ()
;; Checks for keysyms with incorrect :lowercase parameters
(maphash #'(lambda (key mapping)
(let* ((value (car mapping))
(char (keysym-mapping-object value)))
(if (and (characterp char) (both-case-p char)
(= (char-int char) (char-int (char-upcase char))))
;; uppercase alphabetic character
(unless (eq (keysym-mapping-lowercase value)
(char-int (char-downcase char)))
(let ((lowercase (keysym-mapping-lowercase value))
(should-be (char-downcase char)))
(format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)"
(ldb (byte 8 8) key)
(ldb (byte 8 0) key)
char
(and lowercase (ldb (byte 8 8) lowercase))
(and lowercase (ldb (byte 8 0) lowercase))
(int-char lowercase)
(ldb (byte 8 8) (char-int should-be))
(ldb (byte 8 0) (char-int should-be))
should-be)))
(when (keysym-mapping-lowercase value)
(let ((lowercase (keysym-mapping-lowercase value)))
(format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't"
(ldb (byte 8 8) key)
(ldb (byte 8 0) key)
char
(and lowercase (ldb (byte 8 8) (char-int lowercase)))
(and lowercase (ldb (byte 8 0) (char-int lowercase)))
lowercase
))))))
*keysym->character-map*))
(defun print-all-keysyms ()
(let ((all nil))
(maphash #'(lambda (key value) (push (cons key value) all)) *keysym->character-map*)
(setq all (sort all #'< :key #'car))
(format t "~%~d keysyms:" (length all))
(dolist (keysym all)
(format t "~%~3d ~3d~{ ~s~}"
(ldb (byte 8 8) (car keysym))
(ldb (byte 8 0) (car keysym))
(cadr keysym))
(dolist (mapping (cddr keysym))
(format t "~%~7@t~{ ~s~}" mapping)))))
(defun keysym-mappings (keysym &key display (mask-format #'identity))
;; Return all the keysym mappings for keysym.
;; Returns a list of argument lists that are argument-lists to define-keysym.
;; The following will re-create the mappings for KEYSYM:
;; (dolist (mapping (keysym-mappings) keysym)
;; (apply #'define-keysym mapping))
(let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display))))
(gethash keysym *keysym->character-map*)))
(result nil))
(dolist (mapping mappings)
(let ((object (keysym-mapping-object mapping))
(translate (keysym-mapping-translate mapping))
(lowercase (keysym-mapping-lowercase mapping))
(modifiers (keysym-mapping-modifiers mapping))
(mask (keysym-mapping-mask mapping)))
(push (append (list object keysym)
(when translate (list :translate translate))
(when lowercase (list :lowercase lowercase))
(when modifiers (list :modifiers (funcall mask-format modifiers)))
(when mask (list :mask (funcall mask-format mask))))
result)))
(nreverse result)))
#+comment
(defun print-keysym-mappings (keysym &optional display)
(format t "~%(keysym ~d ~3d) "
(ldb (byte 8 8) keysym)
(ldb (byte 8 0) keysym))
(dolist (mapping (keysym-mappings keysym :display display))
(format t "~16t~{ ~s~}~%" mapping)))
(defun print-keysym-mappings (keysym &optional display)
(flet ((format-mask (mask)
(cond ((numberp mask)
`(make-state-mask ,@(make-state-keys mask)))
((atom mask) mask)
(t `(list ,@(mapcar
#'(lambda (item)
(if (numberp item)
`(keysym ,(keysym-mapping-object
(car (gethash item *keysym->character-map*))))
item))
mask))))))
(dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask))
(format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})"
(car mapping)
(ldb (byte 8 8) keysym)
(ldb (byte 8 0) keysym)
(cdr mapping)))))
(defun keysym-test (host)
;; Server key-press Loop-back test
(let* ((display (open-display host))
(width 400)
(height 400)
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(win (create-window
:parent (screen-root screen)
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :key-press)
:x 20 :y 20
:width width :height height))
#+comment
(gc (create-gcontext
:drawable win
:background black
:foreground white)))
(initialize-extensions display)
(map-window win) ; Map the window
;; Handle events
(unwind-protect
(dotimes (state 64)
(do ((code (display-min-keycode display) (1+ code)))
((> code (display-max-keycode display)))
(send-event win :key-press '(:key-press) :code code :state state
:window win :root (screen-root screen) :time 0
:x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t)
(event-case (display :force-output-p t :discard-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(clear-area window))
nil)
(key-press (display code state)
(princ (keycode->character display code state))
t))))
(close-display display))))
(defun keysym-echo (host &optional keymap-p)
;; Echo characters typed to a window
(let* ((display (open-display host))
(width 400)
(height 400)
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(win (create-window
:parent (screen-root screen)
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :key-press :keymap-state :enter-window)
:x 20 :y 20
:width width :height height))
(gc (create-gcontext
:drawable win
:background black
:foreground white)))
(initialize-extensions display)
(map-window win) ; Map the window
;; Handle events
(unwind-protect
(event-case (display :force-output-p t :discard-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(clear-area window)
(draw-glyphs window gc 10 10 "Press <escape> to exit"))
nil)
(key-press (display code state)
(let ((char (keycode->character display code state)))
(format t "~%Code: ~s State: ~s Char: ~s" code state char)
;; (PRINC char) (PRINC " ")
(when keymap-p
(let ((keymap (query-keymap display)))
(unless (character-in-map-p display char keymap)
(print "character-in-map-p failed")
(print-keymap keymap))))
;; (when (eql char #\0) (setq disp display) (break))
(eql char #\escape)))
(keymap-notify (keymap)
(print "Keymap-notify") ;; we never get here. Server bug?
(when (keysym-in-map-p display 65 keymap)
(print "Found A"))
(when (character-in-map-p display #\b keymap)
(print "Found B")))
(enter-notify (event-window) (format t "~%Enter ~s" event-window)))
(close-display display))))
(defun print-keymap (keymap)
(do ((j 32 (+ j 32))) ;; first 32 bits is for window
((>= j 256))
(format t "~% ~3d: " j)
(do ((i j (1+ i)))
((>= i (+ j 32)))
(when (zerop (logand i 7))
(princ " "))
(princ (aref keymap i)))))
(defun define-keysym-test (&key display printp
(modifiers (list (keysym :left-meta))) (mask :modifiers))
(let* ((keysym 067)
(args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask))))
(original (copy-tree (keysym-mappings keysym :display display))))
(when printp (print-keysym-mappings 67) (terpri))
(apply #'define-keysym args)
(when printp (print-keysym-mappings 67) (terpri))
(let ((is (keysym-mappings keysym :display display))
(should-be (append original (list args))))
(unless (equal is should-be)
(cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be)))
(apply #'undefine-keysym args)
(when printp (print-keysym-mappings 67) (terpri))
(let ((is (keysym-mappings keysym :display display)))
(unless (equal is original)
(cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original)))))
(define-keysym-test)
(define-keysym-test :modifiers (make-state-mask :shift :lock))
(define-keysym-test :modifiers (list :shift (keysym :left-meta) :control))
(define-keysym-test :modifiers (make-state-mask :shift :lock) :mask nil)

456
src/clx/debug/trace.lisp
View file

@ -1,456 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;;
;;; 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.
;;;
;; Trace works by substituting trace functions for the display-write/input functions.
;; The trace functions maintain a database of requests sent to the server in the
;; trace-history display property. This is an alist of (id . byte-vector) where
;; id is the request number for writes, :reply for replies, :event for events and
;; :error for errors. The alist is kept in reverse order (most recent first)
;; In a multiprocessing system is it very helpful to know what process wrote or
;; read certain requests. Thus I have modified the format of the trace-history
;; list. It is now an alist of: ((id . more-info) . byte-vector).
;; (more-info is a list returned by the trace-more-info function).
;; Also added the ability to suspend and resume tracing without destroying the
;; trace history. Renamed 'display-trace' to 'show-trace' to avoid confusion.
;; 7feb91 -- jdi
;;; Created 09/14/87 by LaMott G. OREN
(in-package :xlib)
(eval-when (load eval)
(export '(trace-display
suspend-display-tracing
resume-display-tracing
untrace-display
show-trace
display-trace ; for backwards compatibility
describe-request
describe-event
describe-reply
describe-error
describe-trace)))
(defun trace-display (display)
"Start a trace on DISPLAY.
If display is already being traced, this discards previous history.
See show-trace and describe-trace."
(declare (type display display))
(unless (getf (display-plist display) 'write-function)
(bind-io-hooks display))
(setf (display-trace-history display) nil)
t)
(defun suspend-display-tracing (display)
"Tracing is suspended, but history is not cleared."
(if (getf (display-plist display) 'suspend-display-tracing)
(warn "Tracing is already suspend for ~s" display)
(progn
(unbind-io-hooks display)
(setf (getf (display-plist display) 'suspend-display-tracing) t))))
(defun resume-display-tracing (display)
"Used to resume tracing after suspending"
(if (getf (display-plist display) 'suspend-display-tracing)
(progn
(bind-io-hooks display)
(remf (display-plist display) 'suspend-display-tracing))
(warn "Tracing was not suspended for ~s" display)))
(defun untrace-display (display)
"Stop tracing DISPLAY."
(declare (type display display))
(if (not (getf (display-plist display) 'suspend-display-tracing))
(unbind-io-hooks display)
(remf (display-plist display) 'suspend-display-tracing))
(setf (display-trace-history display) nil))
;; Assumes tracing is not already on.
(defun bind-io-hooks (display)
(let ((write-function (display-write-function display))
(input-function (display-input-function display)))
;; Save origional write/input functions so we can untrace
(setf (getf (display-plist display) 'write-function) write-function)
(setf (getf (display-plist display) 'input-function) input-function)
;; Set new write/input functions that will record what's sent to the server
(setf (display-write-function display)
#'(lambda (vector display start end)
(trace-write-hook vector display start end)
(funcall write-function vector display start end)))
(setf (display-input-function display)
#'(lambda (display vector start end timeout)
(let ((result (funcall input-function
display vector start end timeout)))
(unless result
(trace-read-hook display vector start end))
result)))))
(defun unbind-io-hooks (display)
(let ((write-function (getf (display-plist display) 'write-function))
(input-function (getf (display-plist display) 'input-function)))
(when write-function
(setf (display-write-function display) write-function))
(when input-function
(setf (display-input-function display) input-function))
(remf (display-plist display) 'write-function)
(remf (display-plist display) 'input-function)))
(defun byte-ref16 (vector index)
#+clx-little-endian
(logior (the card16
(ash (the card8 (aref vector (index+ index 1))) 8))
(the card8
(aref vector index)))
#-clx-little-endian
(logior (the card16
(ash (the card8 (aref vector index)) 8))
(the card8
(aref vector (index+ index 1)))))
(defun byte-ref32 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (values card32))
(declare-buffun)
#+clx-little-endian
(the card32
(logior (the card32
(ash (the card8 (aref a (index+ i 3))) 24))
(the card29
(ash (the card8 (aref a (index+ i 2))) 16))
(the card16
(ash (the card8 (aref a (index+ i 1))) 8))
(the card8
(aref a i))))
#-clx-little-endian
(the card32
(logior (the card32
(ash (the card8 (aref a i)) 24))
(the card29
(ash (the card8 (aref a (index+ i 1))) 16))
(the card16
(ash (the card8 (aref a (index+ i 2))) 8))
(the card8
(aref a (index+ i 3))))))
(defun trace-write-hook (vector display start end)
;; Called only by buffer-flush. Start should always be 0
(unless (zerop start)
(format *debug-io* "write-called with non-zero start: ~d" start))
(let* ((history (display-trace-history display))
(request-number (display-request-number display))
(last-history (car history)))
;; There may be several requests in the buffer, and the last one may be
;; incomplete. The first one may be the completion of a previous request.
;; We can detect incomplete requests by comparing the expected length of
;; the last request with the actual length.
(when (and last-history (numberp (caar last-history)))
(let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2)))
(append-length (min (- last-length (length (cdr last-history)))
(- end start))))
(when (plusp append-length)
;; Last history incomplete - append to last
(setf (cdr last-history)
(concatenate '(vector card8) (cdr last-history)
(subseq vector start (+ start append-length))))
(index-incf start append-length))))
;; Copy new requests into the history
(do* ((new-history nil)
(i start (+ i length))
request
length)
((>= i end)
;; add in sequence numbers
(dolist (entry new-history)
(setf (caar entry) request-number)
(decf request-number))
(setf (display-trace-history display)
(nconc new-history history)))
(setq request (aref vector i))
(setq length (index* 4 (byte-ref16 vector (+ i 2))))
(when (zerop length)
(warn "Zero length in buffer")
(return nil))
(push (cons (cons 0 (trace-more-info display request vector
i (min (+ i length) end)))
(subseq vector i (min (+ i length) end))) new-history)
(when (zerop request)
(warn "Zero length in buffer")
(return nil)))))
(defun trace-read-hook (display vector start end)
;; Reading is done with an initial length of 32 (with start = 0)
;; This may be followed by several other reads for long replies.
(let* ((history (display-trace-history display))
(last-history (car history))
(length (- end start)))
(when (and history (eq (caar last-history) :reply))
(let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4))))
(append-length (min (- last-length (length (cdr last-history)))
(- end start))))
(when (plusp append-length)
(setf (cdr last-history)
(concatenate '(vector card8) (cdr last-history)
(subseq vector start (+ start append-length))))
(index-incf start append-length)
(index-decf length append-length))))
;; Copy new requests into the history
(when (plusp length)
(let ((reply-type (case (aref vector start) (0 :error) (1 :reply)
(otherwise :event))))
(push (cons (cons reply-type
(trace-more-info display reply-type vector start
(+ start length)))
(subseq vector start (+ start length)))
(display-trace-history display))))))
(defun trace-more-info (display request-id vector start end)
;; Currently only returns current process.
#+allegro
(list mp::*current-process*))
(defun show-trace (display &key length show-process)
"Display the trace history for DISPLAY.
The default is to show ALL history entries.
When the LENGTH parameter is used, only the last LENGTH entries are
displayed."
(declare (type display display))
(dolist (hist (reverse (subseq (display-trace-history display)
0 length)))
(let* ((id (caar hist))
(more-info (cdar hist))
(vector (cdr hist))
(length (length vector))
(request (aref vector 0)))
(format t "~%~5d " id)
(case id
(:error
(trace-error-print display more-info vector))
(:event
(format t "~a (~d) Sequence ~d"
(if (< request (length *event-key-vector*))
(aref *event-key-vector* request)
"Unknown")
request
(byte-ref16 vector 2))
(when show-process
#+allegro
(format t ", Proc ~a" (mp::process-name (car more-info)))))
(:reply
(format t "To ~d length ~d"
(byte-ref16 vector 2) length)
(let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
(unless (= length actual-length)
(format t " Should be ~d **************" actual-length)))
(when show-process
#+allegro
(format t ", Proc ~a" (mp::process-name (car more-info)))))
(otherwise
(format t "~a (~d) length ~d"
(request-name request) request length)
(when show-process
#+allegro
(format t ", Proc ~a" (mp::process-name (car more-info)))))))))
;; For backwards compatibility
(defun display-trace (&rest args)
(apply 'show-trace args))
(defun find-trace (display type sequence &optional (number 0))
(dolist (history (display-trace-history display))
(when (and (symbolp (caar history))
(= (logandc2 (aref (cdr history) 0) 128) type)
(= (byte-ref16 (cdr history) 2) sequence)
(minusp (decf number)))
(return (cdr history)))))
(defun describe-error (display sequence)
"Describe the error associated with request SEQUENCE."
(let ((vector (find-trace display 0 sequence)))
(if vector
(progn
(terpri)
(trace-error-print display nil vector))
(format t "Error with sequence ~d not found." sequence))))
(defun trace-error-print (display more-info vector
&optional (stream *standard-output*))
(let ((event (allocate-event)))
;; Copy into event from reply buffer
(buffer-replace (reply-ibuf8 event)
vector
0
*replysize*)
(reading-event (event)
(let* ((type (read-card8 0))
(error-code (read-card8 1))
(sequence (read-card16 2))
(resource-id (read-card32 4))
(minor-code (read-card16 8))
(major-code (read-card8 10))
(current-sequence (ldb (byte 16 0) (buffer-request-number display)))
(error-key
(if (< error-code (length *xerror-vector*))
(aref *xerror-vector* error-code)
'unknown-error))
(params
(case error-key
((colormap-error cursor-error drawable-error font-error gcontext-error
id-choice-error pixmap-error window-error)
(list :resource-id resource-id))
(atom-error
(list :atom-id resource-id))
(value-error
(list :value resource-id))
(unknown-error
;; Prevent errors when handler is a sequence
(setq error-code 0)
(list :error-code error-code)))))
type
(let ((condition
(apply #+lispm #'si:make-condition
#+allegro #'make-condition
#-(or lispm allegro) #'make-condition
error-key
:error-key error-key
:display display
:major major-code
:minor minor-code
:sequence sequence
:current-sequence current-sequence
params)))
(princ condition stream)
(deallocate-event event)
condition)))))
(defun describe-request (display sequence)
"Describe the request with sequence number SEQUENCE"
#+ti (si:load-if "clx:debug;describe")
(let ((request (assoc sequence (display-trace-history display)
:test #'(lambda (item key)
(eql item (car key))))))
(if (null request)
(format t "~%Request number ~d not found in trace history" sequence)
(let* ((vector (cdr request))
(len (length vector))
(hist (make-reply-buffer len)))
(buffer-replace (reply-ibuf8 hist) vector 0 len)
(print-history-description hist)))))
(defun describe-reply (display sequence)
"Print the reply to request SEQUENCE.
(The current implementation doesn't print very pretty)"
(let ((vector (find-trace display 1 sequence))
(*print-array* t))
(if vector
(print vector)
(format t "~%Reply not found"))))
(defun event-number (name)
(if (integerp name)
(let ((name (logandc2 name 128)))
(if (typep name '(integer 0 63))
(aref *event-key-vector* name))
name)
(position (string name) *event-key-vector* :test #'equalp :key #'string)))
(defun describe-event (display name sequence &optional (number 0))
"Describe the event with event-name NAME and sequence number SEQUENCE.
If there is more than one event, return NUMBER in the sequence."
(declare (type display display)
(type (or stringable (integer 0 63)) name)
(integer sequence))
(let* ((event (event-number name))
(vector (and event (find-trace display event sequence number))))
(if (not event)
(format t "~%~s isn't an event name" name)
(if (not vector)
(if (and (plusp number) (setq vector (find-trace display event sequence 0)))
(do ((i 1 (1+ i))
(last-vector))
(nil)
(if (setq vector (find-trace display event sequence i))
(setq last-vector vector)
(progn
(format t "~%Event number ~d not found, last event was ~d"
number (1- i))
(return (trace-event-print display last-vector)))))
(format t "~%Event ~s not found"
(aref *event-key-vector* event)))
(trace-event-print display vector)))))
(defun trace-event-print (display vector)
(let* ((event (allocate-event))
(event-code (ldb (byte 7 0) (aref vector 0)))
(event-decoder (aref *event-handler-vector* event-code)))
;; Copy into event from reply buffer
(setf (event-code event) event-code)
(buffer-replace (reply-ibuf8 event)
vector
0
*replysize*)
(prog1 (funcall event-decoder display event
#'(lambda (&rest args &key send-event-p &allow-other-keys)
(setq args (copy-list args))
(remf args :display)
(remf args :event-code)
(unless send-event-p (remf args :send-event-p))
args))
(deallocate-event event))))
(defun describe-trace (display &optional length)
"Display the trace history for DISPLAY.
The default is to show ALL history entries.
When the LENGTH parameter is used, only the last LENGTH entries are
displayed."
(declare (type display display))
#+ti (si:load-if "clx:debug;describe")
(dolist (hist (reverse (subseq (display-trace-history display)
0 length)))
(let* ((id (car hist))
(vector (cdr hist))
(length (length vector)))
(format t "~%~5d " id)
(case id
(:error
(trace-error-print display nil vector))
(:event
(let ((event (trace-event-print display vector)))
(when event (format t "from ~d ~{ ~s~}"
(byte-ref16 vector 2) event))))
(:reply
(format t "To ~d length ~d"
(byte-ref16 vector 2) length)
(let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
(unless (= length actual-length)
(format t " Should be ~d **************" actual-length)))
(let ((*print-array* t)
(*print-base* 16.))
(princ " ")
(princ vector)))
(otherwise
(let* ((len (length vector))
(hist (make-reply-buffer len)))
(buffer-replace (reply-ibuf8 hist) vector 0 len)
(print-history-description hist)))))))
;; End of file

167
src/clx/debug/util.lisp
View file

@ -1,167 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; -*-
;; CLX utilities
;;;
;;; 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.
;;;
;;; Created 04/09/87 14:30:41 by LaMott G. OREN
(in-package :xlib)
(export '(display-root
display-black
display-white
report-events
describe-window
describe-gc
degree
radian
display-refresh
root-tree
window-tree))
(defun display-root (display) (screen-root (display-default-screen display)))
(defun display-black (display) (screen-black-pixel (display-default-screen display)))
(defun display-white (display) (screen-white-pixel (display-default-screen display)))
(defun report-events (display)
(loop
(unless
(process-event display :handler #'(lambda (&rest args) (print args)) :discard-p t :timeout 0.001)
(return nil))))
(defun describe-window (window)
(macrolet ((da (attribute &key (transform 'progn) (format "~s"))
(let ((func (intern (concatenate 'string (string 'window-)
(string attribute)) 'xlib)))
`(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))
(dg (attribute &key (transform 'progn) (format "~s"))
(let ((func (intern (concatenate 'string (string 'drawable-)
(string attribute)) 'xlib)))
`(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))))
(with-state (window)
(when (window-p window)
(da visual :format "#x~x")
(da class)
(da gravity)
(da bit-gravity)
(da backing-store)
(da backing-planes :format "#x~x")
(da backing-pixel)
(da save-under)
(da colormap)
(da colormap-installed-p)
(da map-state)
(da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
(da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
(da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
(da override-redirect)
)
(dg root)
(dg depth)
(dg x)
(dg y)
(dg width)
(dg height)
(dg border-width)
)))
(defun describe-gc (gc)
(macrolet ((dgc (name &key (transform 'progn) (format "~s"))
(let ((func (intern (concatenate 'string (string 'gcontext-)
(string name)) 'xlib)))
`(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc)))))))
(dgc function)
(dgc plane-mask)
(dgc foreground)
(dgc background)
(dgc line-width)
(dgc line-style)
(dgc cap-style)
(dgc join-style)
(dgc fill-style)
(dgc fill-rule)
(dgc tile)
(dgc stipple)
(dgc ts-x)
(dgc ts-y)
(dgc font) ;; See below
(dgc subwindow-mode)
(dgc exposures)
(dgc clip-x)
(dgc clip-y)
;; (dgc clip-ordering)
(dgc clip-mask)
(dgc dash-offset)
(dgc dashes)
(dgc arc-mode)
))
(defun degree (degrees)
(* degrees (/ pi 180)))
(defun radian (radians)
(round (* radians (/ 180 pi))))
(defun display-refresh (host)
;; Useful for when the system writes to the screen (sometimes scrolling!)
(let ((display (open-display host)))
(unwind-protect
(let ((screen (display-default-screen display)))
(let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on
:width (screen-width screen) :height (screen-height screen)
:background (screen-black-pixel screen))))
(map-window win)
(display-finish-output display)
(unmap-window win)
(destroy-window win)
(display-finish-output display)))
(close-display display))))
(defun root-tree (host)
(let ((display (open-display host)))
(unwind-protect
(window-tree (screen-root (display-default-screen display)))
(close-display display)))
(values))
(defun window-tree (window &optional (depth 0))
;; Print the window tree and properties starting from WINDOW
;; Returns a list of windows in the order that they are printed.
(declare (arglist window)
(type window window)
(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))))
(list prop format type data)))
(list-properties window)))
(result (list window)))
(with-state (window)
(format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window)
(drawable-x window) (drawable-y window)
(drawable-width window) (drawable-height window)
(window-map-state window)))
(dolist (prop props)
(format t "~%~v@t~{~s ~}" (+ depth 2) prop))
(dolist (w (query-tree window))
(setq result (nconc result (window-tree w (+ depth 2)))))
result))

568
src/clx/defsystem.lisp
View file

@ -1,568 +0,0 @@
;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Portions Copyright (C) 1987 Texas Instruments Incorporated.
;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Franz Incorporated provides this software "as is" without express or
;;; implied warranty.
;;; #+ features used in this file
;;; clx-ansi-common-lisp
;;; lispm
;;; genera
;;; minima
;;; lucid
;;; lcl3.0
;;; apollo
;;; kcl
;;; ibcl
;;; excl
;;; CMU
;;; sbcl
#+(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*))
#-(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
;;; COMPILE-CLX compiles the lisp source files and loads the binaries.
;;; It goes to some trouble to let the source files be in one directory
;;; and the binary files in another. Thus the same set of sources can
;;; be used for different machines and/or lisp systems. It also allows
;;; you to supply explicit extensions, so source files do not have to
;;; be renamed to fit into the naming conventions of an implementation.
;;; For example,
;;; (compile-clx "*.lisp" "machine/")
;;; compiles source files from the connected directory and puts them
;;; into the "machine" subdirectory. You can then load CLX out of the
;;; machine directory.
;;; The code has no knowledge of the source file types (eg, ".l" or
;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin"). Calling
;;; compile-file and load with a file type of NIL usually sorts things
;;; 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 "")
&key
(compile-c t))
;; The pathname-defaults above might only be strings, so coerce them
;; to pathnames. Build a default binary path with every component
;; of the source except the file type. This should prevent
;; (compile-clx "*.lisp") from destroying source files.
(let* ((source-path (pathname source-pathname-defaults))
(path (make-pathname
:host (pathname-host source-path)
:device (pathname-device source-path)
:directory (pathname-directory source-path)
:name (pathname-name source-path)
:type nil
: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
;; we don't accidently overwrite the source files. NIL should be an
;; ok type, but anything else spells trouble.
(if (and (equal (pathname-type source-path)
(pathname-type binary-path))
(not (null (pathname-type binary-path))))
(error "Source and binary pathname defaults have same type ~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)
(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)))
#+(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.
(#+(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")
(compile-and-load "display")
(compile-and-load "gcontext")
(compile-and-load "input")
(compile-and-load "requests")
(compile-and-load "fonts")
(compile-and-load "graphics")
(compile-and-load "text")
(compile-and-load "attributes")
(compile-and-load "translate")
(compile-and-load "keysyms")
(compile-and-load "manager")
(compile-and-load "image")
(compile-and-load "resource")
))))
;;;; Load CLX
;;; This procedure loads the binaries for CLX. All of the binaries
;;; should be in the same directory, so setting the default pathname
;;; should point load to the right place.
;;; You should have a module definition somewhere so the require/provide
;;; mechanism can avoid reloading CLX. In an ideal world, somebody would
;;; just put
;;; (REQUIRE 'CLX)
;;; in their file (some implementations don't have a central registry for
;;; modules, so a pathname needs to be supplied).
;;; The REQUIRE should find a file that does
;;; (IN-PACKAGE 'XLIB :USE '(LISP))
;;; (PROVIDE 'CLX)
;;; (LOAD <clx-defsystem-file>)
;;; (LOAD-CLX <binary-specific-clx-directory>)
#-(or lispm allegro Minima)
(defun load-clx (&optional (binary-pathname-defaults "")
&key (macrosp nil))
(let* ((source-path (pathname ""))
(path (make-pathname
:host (pathname-host source-path)
:device (pathname-device source-path)
:directory (pathname-directory source-path)
:name (pathname-name source-path)
:type nil
:version (pathname-version source-path)))
(binary-path (merge-pathnames binary-pathname-defaults
path))
(*load-verbose* t))
(flet ((load-binary (filename)
(let ((binary (merge-pathnames filename binary-path)))
(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")
(load-binary "display")
(load-binary "gcontext")
(load-binary "input")
(load-binary "requests")
(load-binary "fonts")
(load-binary "graphics")
(load-binary "text")
(load-binary "attributes")
(load-binary "translate")
(load-binary "keysyms")
(load-binary "manager")
(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+)

1
src/clx/demo/.cvsignore
View file

@ -1 +0,0 @@
*.fasl

39
src/clx/demo/bezier.lisp
View file

@ -1,39 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX interface for Bezier Spline Extension.
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(export 'draw-curves)
(define-extension "bezier")
(defun draw-curves (drawable gcontext points)
;; Draw Bezier splines on drawable using gcontext.
;; Points are a list of (x0 y0 x1 y1 x2 y2 x3 y3)
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points))
(let* ((display (drawable-display drawable))
(opcode (extension-opcode display "bezier")))
(with-buffer-request (display opcode :gc-force gcontext)
((data card8) 1) ;; X_PolyBezier - The minor_opcode for PolyBezier
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) points))))

81
src/clx/demo/beziertest.lisp
View file

@ -1,81 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX Bezier Spline Extension demo program
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile"))
;; Display the part picture in /extensions/test/datafile
(let* ((display (open-display host))
(width 800)
(height 800)
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(win (create-window
:parent (screen-root screen)
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :key-press)
:x 20 :y 20
:width width :height height))
(gc (create-gcontext
:drawable win
:background black
:foreground white))
(lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16))
(curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16)))
;; Read the data
(with-open-file (stream pathname)
(loop
(case (read-char stream nil :eof)
(#\l (dotimes (i 4) (vector-push-extend (read stream) lines)))
(#\b (dotimes (i 8) (vector-push-extend (read stream) curves)))
((#\space #\newline #\tab))
(otherwise (return)))))
;; The data points were created to fit in a 2048x2048 square,
;; this means scale_factor will always be small enough so that
;; we don't need to worry about overflows.
(let ((factor (ash (min width height) 5)))
(dotimes (i (length lines))
(setf (aref lines i)
(ash (* (aref lines i) factor) -16)))
(dotimes (i (length curves))
(setf (aref curves i)
(ash (* (aref curves i) factor) -16))))
(map-window win) ; Map the window
;; Handle events
(unwind-protect
(loop
(event-case (display :force-output-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(clear-area window)
(draw-segments win gc lines)
(draw-curves win gc curves)
(draw-glyphs win gc 10 10 "Press any key to exit")
;; Returning non-nil causes event-case to exit
t))
(key-press () (return-from bezier-test t))))
(close-display display))))

78
src/clx/demo/clclock.lisp
View file

@ -1,78 +0,0 @@
(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)))

200
src/clx/demo/clipboard.lisp
View file

@ -1,200 +0,0 @@
;;; 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.
(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)))))

1051
src/clx/demo/clx-demos.lisp
View file

File diff suppressed because it is too large Load diff

477
src/clx/demo/gl-test.lisp
View file

@ -1,477 +0,0 @@
(defpackage :gl-test
(:use :common-lisp :xlib)
(:export "TEST" "CLX-TEST"))
(in-package :gl-test)
(defun test (function &key (host "localhost") (display 1) (width 200) (height 200))
(let* ((display (open-display host :display display))
(screen (display-default-screen display))
(root (screen-root screen))
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
)))

65
src/clx/demo/hello.lisp
View file

@ -1,65 +0,0 @@
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
(in-package :xlib)
(defun hello-world (host &rest args &key (string "Hello World") (font "fixed"))
;; CLX demo, says STRING using FONT in its own window on HOST
(let ((display nil)
(abort t))
(unwind-protect
(progn
(setq display (open-display host))
(multiple-value-prog1
(let* ((screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(font (open-font display font))
(border 1) ; Minimum margin around the text
(width (+ (text-width font string) (* 2 border)))
(height (+ (max-char-ascent font) (max-char-descent font) (* 2 border)))
(x (truncate (- (screen-width screen) width) 2))
(y (truncate (- (screen-height screen) height) 2))
(window (create-window :parent (screen-root screen)
:x x :y y :width width :height height
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :button-press)))
(gcontext (create-gcontext :drawable window
:background black
:foreground white
:font font)))
;; Set window manager hints
(set-wm-properties window
:name 'hello-world
:icon-name string
:resource-name string
:resource-class 'hello-world
:command (list* 'hello-world host args)
:x x :y y :width width :height height
:min-width width :min-height height
:input :off :initial-state :normal)
(map-window window) ; Map the window
;; Handle events
(event-case (display :discard-p t :force-output-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(with-state (window)
(let ((x (truncate (- (drawable-width window) width) 2))
(y (truncate (- (+ (drawable-height window)
(max-char-ascent font))
(max-char-descent font))
2)))
;; Draw text centered in widnow
(clear-area window)
(draw-glyphs window gcontext x y string)))
;; Returning non-nil causes event-case to exit
nil))
(button-press () t))) ;; Pressing any mouse-button exits
(setq abort nil)))
;; Ensure display is closed when done
(when display
(close-display display :abort abort)))))

558
src/clx/demo/mandel.lisp
View file

@ -1,558 +0,0 @@
(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))))))

382
src/clx/demo/menu.lisp
View file

@ -1,382 +0,0 @@
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1988 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;;;----------------------------------------------------------------------------------+
;;; |
;;; These functions demonstrate a simple menu implementation described in |
;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. |
;;; See functions JUST-SAY-LISP and POP-UP for demonstrations. |
;;; |
;;;----------------------------------------------------------------------------------+
(defstruct (menu)
"A simple menu of text strings."
(title "choose an item:")
item-alist ;((item-window item-string))
window
gcontext
width
title-width
item-width
item-height
(geometry-changed-p t)) ;nil iff unchanged since displayed
(defun create-menu (parent-window text-color background-color text-font)
(make-menu
;; Create menu graphics context
:gcontext (CREATE-GCONTEXT :drawable parent-window
:foreground text-color
:background background-color
:font text-font)
;; Create menu window
:window (CREATE-WINDOW
:parent parent-window
:class :input-output
:x 0 ;temporary value
:y 0 ;temporary value
:width 16 ;temporary value
:height 16 ;temporary value
:border-width 2
:border text-color
:background background-color
:save-under :on
:override-redirect :on ;override window mgr when positioning
:event-mask (MAKE-EVENT-MASK :leave-window
:exposure))))
(defun menu-set-item-list (menu &rest item-strings)
;; Assume the new items will change the menu's width and height
(setf (menu-geometry-changed-p menu) t)
;; Destroy any existing item windows
(dolist (item (menu-item-alist menu))
(DESTROY-WINDOW (first item)))
;; Add (item-window item-string) elements to item-alist
(setf (menu-item-alist menu)
(let (alist)
(dolist (item item-strings (nreverse alist))
(push (list (CREATE-WINDOW
:parent (menu-window menu)
:x 0 ;temporary value
:y 0 ;temporary value
:width 16 ;temporary value
:height 16 ;temporary value
:background (GCONTEXT-BACKGROUND (menu-gcontext menu))
:event-mask (MAKE-EVENT-MASK :enter-window
:leave-window
:button-press
:button-release))
item)
alist)))))
(defparameter *menu-item-margin* 4
"Minimum number of pixels surrounding menu items.")
(defun menu-recompute-geometry (menu)
(when (menu-geometry-changed-p menu)
(let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu)))
(title-width (TEXT-EXTENTS menu-font (menu-title menu)))
(item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font)))
(item-width 0)
(items (menu-item-alist menu))
menu-width)
;; Find max item string width
(dolist (next-item items)
(setf item-width (max item-width
(TEXT-EXTENTS menu-font (second next-item)))))
;; Compute final menu width, taking margins into account
(setf menu-width (max title-width
(+ item-width *menu-item-margin* *menu-item-margin*)))
(let ((window (menu-window menu))
(delta-y (+ item-height *menu-item-margin*)))
;; Update width and height of menu window
(WITH-STATE (window)
(setf (DRAWABLE-WIDTH window) menu-width
(DRAWABLE-HEIGHT window) (+ *menu-item-margin*
(* (1+ (length items))
delta-y))))
;; Update width, height, position of item windows
(let ((item-left (round (- menu-width item-width) 2))
(next-item-top delta-y))
(dolist (next-item items)
(let ((window (first next-item)))
(WITH-STATE (window)
(setf (DRAWABLE-HEIGHT window) item-height
(DRAWABLE-WIDTH window) item-width
(DRAWABLE-X window) item-left
(DRAWABLE-Y window) next-item-top)))
(incf next-item-top delta-y))))
;; Map all item windows
(MAP-SUBWINDOWS (menu-window menu))
;; Save item geometry
(setf (menu-item-width menu) item-width
(menu-item-height menu) item-height
(menu-width menu) menu-width
(menu-title-width menu) title-width
(menu-geometry-changed-p menu) nil))))
(defun menu-refresh (menu)
(let* ((gcontext (menu-gcontext menu))
(baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext))))
;; Show title centered in "reverse-video"
(let ((fg (GCONTEXT-BACKGROUND gcontext))
(bg (GCONTEXT-FOREGROUND gcontext)))
(WITH-GCONTEXT (gcontext :foreground fg :background bg)
(DRAW-IMAGE-GLYPHS
(menu-window menu)
gcontext
(round (- (menu-width menu)
(menu-title-width menu)) 2) ;start x
baseline-y ;start y
(menu-title menu))))
;; Show each menu item (position is relative to item window)
(dolist (item (menu-item-alist menu))
(DRAW-IMAGE-GLYPHS
(first item) gcontext
0 ;start x
baseline-y ;start y
(second item)))))
(defun menu-choose (menu x y)
;; Display the menu so that first item is at x,y.
(menu-present menu x y)
(let ((items (menu-item-alist menu))
(mw (menu-window menu))
selected-item)
;; Event processing loop
(do () (selected-item)
(EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t)
(:exposure (count)
;; Discard all but final :exposure then display the menu
(when (zerop count) (menu-refresh menu))
t)
(:button-release (event-window)
;;Select an item
(setf selected-item (second (assoc event-window items)))
t)
(:enter-notify (window)
;;Highlight an item
(let ((position (position window items :key #'first)))
(when position
(menu-highlight-item menu position)))
t)
(:leave-notify (window kind)
(if (eql mw window)
;; Quit if pointer moved out of main menu window
(setf selected-item (when (eq kind :ancestor) :none))
;; Otherwise, unhighlight the item window left
(let ((position (position window items :key #'first)))
(when position
(menu-unhighlight-item menu position))))
t)
(otherwise ()
;;Ignore and discard any other event
t)))
;; Erase the menu
(UNMAP-WINDOW mw)
;; Return selected item string, if any
(unless (eq selected-item :none) selected-item)))
(defun menu-highlight-item (menu position)
(let* ((box-margin (round *menu-item-margin* 2))
(left (- (round (- (menu-width menu) (menu-item-width menu)) 2)
box-margin))
(top (- (* (+ *menu-item-margin* (menu-item-height menu))
(1+ position))
box-margin))
(width (+ (menu-item-width menu) box-margin box-margin))
(height (+ (menu-item-height menu) box-margin box-margin)))
;; Draw a box in menu window around the given item.
(DRAW-RECTANGLE (menu-window menu)
(menu-gcontext menu)
left top
width height)))
(defun menu-unhighlight-item (menu position)
;; Draw a box in the menu background color
(let ((gcontext (menu-gcontext menu)))
(WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext))
(menu-highlight-item menu position))))
(defun menu-present (menu x y)
;; Make sure menu geometry is up-to-date
(menu-recompute-geometry menu)
;; Try to center first item at the given location, but
;; make sure menu is completely visible in its parent
(let ((menu-window (menu-window menu)))
(multiple-value-bind (tree parent) (QUERY-TREE menu-window)
(declare (ignore tree))
(WITH-STATE (parent)
(let* ((parent-width (DRAWABLE-WIDTH parent))
(parent-height (DRAWABLE-HEIGHT parent))
(menu-height (+ *menu-item-margin*
(* (1+ (length (menu-item-alist menu)))
(+ (menu-item-height menu) *menu-item-margin*))))
(menu-x (max 0 (min (- parent-width (menu-width menu))
(- x (round (menu-width menu) 2)))))
(menu-y (max 0 (min (- parent-height menu-height)
(- y (round (menu-item-height menu) 2/3)
*menu-item-margin*)))))
(WITH-STATE (menu-window)
(setf (DRAWABLE-X menu-window) menu-x
(DRAWABLE-Y menu-window) menu-y)))))
;; Make menu visible
(MAP-WINDOW menu-window)))
(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))
(nice-font (OPEN-FONT display font-name))
(a-menu (create-menu (screen-root screen) ;the menu's parent
fg-color bg-color nice-font)))
(setf (menu-title a-menu) "Please pick your favorite language:")
(menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp")
;; Bedevil the user until he picks a nice programming language
(unwind-protect
(do (choice)
((and (setf choice (menu-choose a-menu 100 100))
(string-equal "Lisp" choice))))
(CLOSE-DISPLAY display))))
(defun pop-up (host strings &key (title "Pick one:") (font "fixed"))
(let* ((display (OPEN-DISPLAY host))
(screen (first (DISPLAY-ROOTS display)))
(fg-color (SCREEN-BLACK-PIXEL screen))
(bg-color (SCREEN-WHITE-PIXEL screen))
(font (OPEN-FONT display font))
(parent-width 400)
(parent-height 400)
(parent (CREATE-WINDOW :parent (SCREEN-ROOT screen)
:override-redirect :on
:x 100 :y 100
:width parent-width :height parent-height
:background bg-color
:event-mask (MAKE-EVENT-MASK :button-press
:exposure)))
(a-menu (create-menu parent fg-color bg-color font))
(prompt "Press a button...")
(prompt-gc (CREATE-GCONTEXT :drawable parent
:foreground fg-color
:background bg-color
:font font))
(prompt-y (FONT-ASCENT font))
(ack-y (- parent-height (FONT-DESCENT font))))
(setf (menu-title a-menu) title)
(apply #'menu-set-item-list a-menu strings)
;; Present main window
(MAP-WINDOW parent)
(flet ((display-centered-text
(window string gcontext height width)
(multiple-value-bind (w a d l r fa fd) (text-extents gcontext string)
(declare (ignore a d l r))
(let ((box-height (+ fa fd)))
;; Clear previous text
(CLEAR-AREA window
:x 0 :y (- height fa)
:width width :height box-height)
;; Draw new text
(DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string)))))
(unwind-protect
(loop
(EVENT-CASE (display :force-output-p t)
(:exposure (count)
;; Display prompt
(when (zerop count)
(display-centered-text
parent
prompt
prompt-gc
prompt-y
parent-width))
t)
(:button-press (x y)
;; Pop up the menu
(let ((choice (menu-choose a-menu x y)))
(if choice
(display-centered-text
parent
(format nil "You have selected ~a." choice)
prompt-gc
ack-y
parent-width)
(display-centered-text
parent
"No selection...try again."
prompt-gc
ack-y
parent-width)))
t)
(otherwise ()
;;Ignore and discard any other event
t)))
(CLOSE-DISPLAY display)))))

58
src/clx/demo/zoid.lisp
View file

@ -1,58 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX interface for Trapezoid Extension.
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(export '(draw-filled-trapezoids
gcontext-trapezoid-alignment ;; Setf'able
))
(define-extension "ZoidExtension")
(defun draw-filled-trapezoids (drawable gcontext points)
;; Draw trapezoids on drawable using gcontext.
;; Points are a list of either (y1 y2 y3 y4 x1 x2) ;; x-aligned
;; or (x1 x2 x3 x4 y1 y2) ;; y-aligned
;; Alignment is determined by the GCONTEXT [see gcontext-trapezoid-alignment]
;; Alignment is set with the ALIGNMENT keyword argument, which may be
;; :X, :Y, or NIL (use previous alignment)
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points))
(let* ((display (drawable-display drawable))
(opcode (extension-opcode display "ZoidExtension")))
(with-buffer-request (display opcode :gc-force gcontext)
((data card8) 1) ;; X_PolyFillZoid
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) points))))
(define-gcontext-accessor trapezoid-alignment :default :x
:set-function set-trapezoid-alignment)
(defun set-trapezoid-alignment (gcontext alignment)
(declare (type (member :x :y) alignment))
(let* ((display (gcontext-display gcontext))
(opcode (extension-opcode display "ZoidExtension")))
(with-buffer-request (display opcode)
((data card8) 2) ;; X_SetZoidAlignment
(gcontext gcontext)
((member8 %error :x :y) alignment))))

2210
src/clx/dep-allegro.lisp
View file

File diff suppressed because it is too large Load diff

1123
src/clx/dep-openmcl.lisp
View file

File diff suppressed because it is too large Load diff

693
src/clx/depdefs.lisp
View file

@ -1,693 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;; This file contains some of the system dependent code for CLX
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;;;-------------------------------------------------------------------------
;;; 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))
;;;-------------------------------------------------------------------------
;;; Declaration macros
;;;-------------------------------------------------------------------------
;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
;;; and then does a type declaration and array register declaration
(defmacro with-vector ((var type) &body body)
`(let ((,var ,var))
(declare (type ,type ,var))
,@body))
;;; 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))
;;;-------------------------------------------------------------------------
;;; CLX can maintain a mapping from X server ID's to local data types. If
;;; one takes the view that CLX objects will be instance variables of
;;; objects at the next higher level, then PROCESS-EVENT will typically map
;;; from resource-id to higher-level object. In that case, the lower-level
;;; CLX mapping will almost never be used (except in rare cases like
;;; query-tree), and only serve to consume space (which is difficult to
;;; GC), in which case always-consing versions of the make-<mumble>s will
;;; be better. Even when maps are maintained, it isn't clear they are
;;; 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))
(defmacro resource-id-map-test ()
#+excl '#'equal
#-excl '#'eql)
; (eq fixnum fixnum) is not guaranteed.
(defmacro atom-cache-map-test ()
#+excl '#'equal
#-excl '#'eq)
(defmacro keysym->character-map-test ()
#+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.
;;; This is inclusive because start/end can be 1 past the end.
(deftype array-index () `(integer 0 ,array-dimension-limit))
;; this is the best place to define these?
#-Genera
(progn
(defun make-index-typed (form)
(if (constantp form) form `(the array-index ,form)))
(defun make-index-op (operator args)
`(the array-index
(values
,(case (length args)
(0 `(,operator))
(1 `(,operator
,(make-index-typed (first args))))
(2 `(,operator
,(make-index-typed (first args))
,(make-index-typed (second args))))
(otherwise
`(,operator
,(make-index-op operator (subseq args 0 (1- (length args))))
,(make-index-typed (first (last args)))))))))
(defmacro index+ (&rest numbers) (make-index-op '+ numbers))
(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
(defmacro index- (&rest numbers) (make-index-op '- numbers))
(defmacro index* (&rest numbers) (make-index-op '* numbers))
(defmacro index1+ (number) (make-index-op '1+ (list number)))
(defmacro index1- (number) (make-index-op '1- (list number)))
(defmacro index-incf (place &optional (delta 1))
(make-index-op 'incf (list place delta)))
(defmacro index-decf (place &optional (delta 1))
(make-index-op 'decf (list place delta)))
(defmacro index-min (&rest numbers) (make-index-op 'min numbers))
(defmacro index-max (&rest numbers) (make-index-op 'max numbers))
(defmacro index-floor (number divisor)
(make-index-op 'floor (list number divisor)))
(defmacro index-ceiling (number divisor)
(make-index-op 'ceiling (list number divisor)))
(defmacro index-truncate (number divisor)
(make-index-op 'truncate (list number divisor)))
(defmacro index-mod (number divisor)
(make-index-op 'mod (list number divisor)))
(defmacro index-ash (number count)
(make-index-op 'ash (list number count)))
(defmacro index-plusp (number) `(plusp (the array-index ,number)))
(defmacro index-zerop (number) `(zerop (the array-index ,number)))
(defmacro index-evenp (number) `(evenp (the array-index ,number)))
(defmacro index-oddp (number) `(oddp (the array-index ,number)))
(defmacro index> (&rest numbers)
`(> ,@(mapcar #'make-index-typed numbers)))
(defmacro index= (&rest numbers)
`(= ,@(mapcar #'make-index-typed numbers)))
(defmacro index< (&rest numbers)
`(< ,@(mapcar #'make-index-typed numbers)))
(defmacro index>= (&rest numbers)
`(>= ,@(mapcar #'make-index-typed numbers)))
(defmacro index<= (&rest numbers)
`(<= ,@(mapcar #'make-index-typed numbers)))
)
#+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.)
;; 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))
(size 0 :type array-index) ;Buffer size
;; Byte (8 bit) input buffer
(ibuf8 *empty-bytes* :type buffer-bytes)
;; Word (16bit) input 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+)))
;; These are here because.
(defparameter *xlib-package* (find-package :xlib))
(defun xintern (&rest parts)
(intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
(defparameter *keyword-package* (find-package :keyword))
(defun kintern (name)
(intern (string name) *keyword-package*))
;;; Pseudo-class mechanism.
(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 #+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)
(print-function nil)
(copier t)
(predicate t))
(dolist (option options)
(ecase (pop option)
(:constructor
(setf constructor (pop option))
(setf constructor-args (if (null option) t (pop option))))
(:include
(setf include (pop option)))
(:print-function
(setf print-function (pop option)))
(:copier
(setf copier (pop option)))
(:predicate
(setf predicate (pop option)))))
(flet ((cintern (&rest symbols)
(intern (apply #'concatenate 'simple-string
(mapcar #'symbol-name symbols))
*package*))
(kintern (symbol)
(intern (symbol-name symbol) (find-package :keyword)))
(closintern (symbol)
(intern (symbol-name symbol) clos-package)))
(when (eq constructor t)
(setf constructor (cintern 'make- name)))
(when (eq copier t)
(setf copier (cintern 'copy- name)))
(when (eq predicate t)
(setf predicate (cintern name '-p)))
(when include
(setf slots (append (get include 'def-clx-class) slots)))
(let* ((n-slots (length slots))
(slot-names (make-list n-slots))
(slot-initforms (make-list n-slots))
(slot-types (make-list n-slots)))
(dotimes (i n-slots)
(let ((slot (elt slots i)))
(setf (elt slot-names i) (pop slot))
(setf (elt slot-initforms i) (pop slot))
(setf (elt slot-types i) (getf slot :type t))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name 'def-clx-class) ',slots))
;; From here down are the system-specific expansions:
(within-definition (,name def-clx-class)
(,(closintern 'defclass)
,name ,(and include `(,include))
(,@(map 'list
#'(lambda (slot-name slot-initform slot-type)
`(,slot-name
:initform ,slot-initform :type ,slot-type
:accessor ,(cintern name '- slot-name)
,@(when (and constructor
(or (eq constructor-args t)
(member slot-name
constructor-args)))
`(:initarg ,(kintern slot-name)))
))
slot-names slot-initforms slot-types)))
,(when constructor
(if (eq constructor-args t)
`(defun ,constructor (&rest args)
(apply #',(closintern 'make-instance)
',name args))
`(defun ,constructor ,constructor-args
(,(closintern 'make-instance) ',name
,@(mapcan #'(lambda (slot-name)
(and (member slot-name slot-names)
`(,(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
`(,(closintern 'defmethod) ,copier ((.object. ,name))
(,(closintern 'with-slots) ,slot-names .object.
(,(closintern 'make-instance) ',name
,@(mapcan #'(lambda (slot-name)
`(,(kintern slot-name) ,slot-name))
slot-names)))))
,(when print-function
`(,(closintern 'defmethod)
,(closintern 'print-object)
((object ,name) stream)
(,print-function object stream 0))))))))
`(within-definition (,name def-clx-class)
(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.
;; Overlapping (displaced) arrays are provided for byte
;; half-word and word access on both input and output.
;;
(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
;; Lock for multi-processing systems
(lock (make-process-lock "CLX Buffer Lock"))
#-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))
;; Byte position of start of last request
;; used for appending requests and error recovery
(last-request nil :type (or null array-index))
;; Byte position of start of last flushed request
(last-flushed-request nil :type (or null array-index))
;; Current byte offset
(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))
;; Probably EQ to Output-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.
(flush-inhibit nil :type (or null (not null)))
;; Change these functions when using shared memory buffers to the server
;; Function to call when writing the buffer
(write-function 'buffer-write-default)
;; Function to call when flushing the buffer
(force-output-function 'buffer-force-output-default)
;; Function to call when closing a connection
(close-function 'buffer-close-default)
;; Function to call when reading the buffer
(input-function 'buffer-read-default)
;; Function to call to wait for data to be input
(input-wait-function 'buffer-input-wait-default)
;; 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+
#+clx-little-endian t
#-clx-little-endian nil)
(defconstant +image-byte-lsb-first-p+
#+clx-little-endian t
#-clx-little-endian nil)
(defconstant +image-unit+ 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))
;;-----------------------------------------------------------------------------
;; Finding the server socket
;;-----------------------------------------------------------------------------
;; These are here because dep-openmcl.lisp and dependent.lisp both need them
(defconstant +X-unix-socket-path+
"/tmp/.X11-unix/X"
"The location of the X socket")
(defun unix-socket-path-from-host (host display)
"Return the name of the unix domain socket for host and display, or
nil if a network socket should be opened."
(cond ((or (string= host "") (string= host "unix"))
(format nil "~A~D" +X-unix-socket-path+ display))
#+darwin
((and (> (length host) 10) (string= host "tmp/launch" :end1 10))
(format nil "/~A:~D" host display))
(t nil)))

4097
src/clx/dependent.lisp
View file

File diff suppressed because it is too large Load diff

680
src/clx/display.lisp
View file

@ -1,680 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;;; 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 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.
;;; Stolen from the cmucl sources, with patches by Hannu Rummukainen and
;;; Scott Fahlman.
(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 ((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 "" "")))
(defmacro with-display ((display &key timeout inline)
&body body)
;; This macro is for use in a multi-process environment. It
;; provides exclusive access to the local display object for
;; multiple request generation. It need not provide immediate
;; exclusive access for replies; that is, if another process is
;; waiting for a reply (while not in a with-display), then
;; synchronization need not (but can) occur immediately. Except
;; where noted, all routines effectively contain an implicit
;; with-display where needed, so that correct synchronization is
;; always provided at the interface level on a per-call basis.
;; Nested uses of this macro will work correctly. This macro does
;; not prevent concurrent event processing; see with-event-queue.
`(with-buffer (,display
,@(and timeout `(:timeout ,timeout))
,@(and inline `(:inline ,inline)))
,@body))
;;
;; Resource id management
;;
(defun initialize-resource-allocator (display)
;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask
(let ((id-mask (display-resource-id-mask display)))
(unless (zerop id-mask) ;; zero mask is an error
(do ((first 0 (index1+ first))
(mask id-mask (the mask32 (ash mask -1))))
((oddp mask)
(setf (display-resource-id-byte display)
(byte (integer-length mask) first)))
(declare (type array-index first)
(type mask32 mask))))))
(defun resourcealloc (display)
;; Allocate a resource-id for use in DISPLAY
(declare (type display display))
(declare (clx-values resource-id))
(loop for next-count upfrom (1+ (display-resource-id-count display))
repeat (1+ (display-resource-id-mask display))
as id = (dpb next-count
(display-resource-id-byte display)
(display-resource-id-base display))
unless (nth-value 1 (gethash id (display-resource-id-map display)))
do (setf (display-resource-id-count display) next-count)
(setf (gethash id (display-resource-id-map display)) t)
(return-from resourcealloc id))
;; internal consistency check
(assert (= (hash-table-count (display-resource-id-map display))
(1+ (display-resource-id-mask display))))
;; tell the user what's gone wrong
(error 'resource-ids-exhausted))
(defmacro allocate-resource-id (display object type)
;; Allocate a resource-id for OBJECT in DISPLAY
`(with-display (,display)
,(if (member (eval type) +clx-cached-types+)
`(let ((id (funcall (display-xid ,display) ,display)))
(save-id ,display id ,object)
id)
`(funcall (display-xid ,display) ,display))))
(defmacro deallocate-resource-id (display id type)
(declare (ignore type))
;; Deallocate a resource-id for OBJECT in DISPLAY
`(deallocate-resource-id-internal ,display ,id))
(defun deallocate-resource-id-internal (display id)
(with-display (display)
(remhash id (display-resource-id-map display))))
(defun lookup-resource-id (display id)
;; Find the object associated with resource ID
(gethash id (display-resource-id-map display)))
(defun save-id (display id object)
;; cache the object associated with ID for this display.
(declare (type display display)
(type integer id)
(type t object))
(declare (clx-values object))
;; we can't cache objects from other clients, because they may
;; become invalid without us being told about that.
(let ((base (display-resource-id-base display))
(mask (display-resource-id-mask display)))
(when (= (logandc2 id mask) base)
(setf (gethash id (display-resource-id-map display)) object))
object))
;; Define functions to find the CLX data types given a display and resource-id
;; If the data type is being cached, look there first.
(macrolet ((generate-lookup-functions (useless-name &body types)
`(within-definition (,useless-name generate-lookup-functions)
,@(mapcar
#'(lambda (type)
`(defun ,(xintern 'lookup- type)
(display id)
(declare (type display display)
(type resource-id id))
(declare (clx-values ,type))
,(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?+)
`(t ,type))
((member type '(window pixmap))
`((type? ,type 'drawable) ,type))
(t `((type? ,type ',type) ,type)))
,@(when +type-check?+
`((t (x-error 'lookup-error
:id id
:display display
:type ',type
:object ,type))))))
;; Not being cached. Create a new one each time.
`(,(xintern 'make- type)
:display display :id id))))
types))))
(generate-lookup-functions ignore
drawable
window
pixmap
gcontext
cursor
colormap
font))
(defun id-atom (id display)
;; Return the cached atom for an atom ID
(declare (type resource-id id)
(type display display))
(declare (clx-values (or null keyword)))
(gethash id (display-atom-id-map display)))
(defun atom-id (atom display)
;; Return the ID for an atom in DISPLAY
(declare (type xatom atom)
(type display display))
(declare (clx-values (or null resource-id)))
(gethash (if (or (null atom) (keywordp atom)) atom (kintern atom))
(display-atom-cache display)))
(defun set-atom-id (atom display id)
;; Set the ID for an atom in DISPLAY
(declare (type xatom atom)
(type display display)
(type resource-id id))
(declare (clx-values resource-id))
(let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom))))
(setf (gethash id (display-atom-id-map display)) atom)
(setf (gethash atom (display-atom-cache display)) id)
id))
(defsetf atom-id set-atom-id)
(defun initialize-predefined-atoms (display)
(dotimes (i (length +predefined-atoms+))
(declare (type resource-id i))
(setf (atom-id (svref +predefined-atoms+ i) display) i)))
(defun visual-info (display visual-id)
(declare (type display display)
(type resource-id visual-id)
(clx-values visual-info))
(when (zerop visual-id)
(return-from visual-info nil))
(dolist (screen (display-roots display))
(declare (type screen screen))
(dolist (depth (screen-depths screen))
(declare (type cons depth))
(dolist (visual-info (rest depth))
(declare (type visual-info visual-info))
(when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info))
(return-from visual-info visual-info)))))
(error "Visual info not found for id #x~x in display ~s." visual-id display))
;;
;; Display functions
;;
(defmacro with-event-queue ((display &key timeout inline)
&body body &environment env)
;; exclusive access to event queue
`(macrolet ((with-event-queue ((display &key timeout) &body body)
;; Speedup hack for lexically nested with-event-queues
`(progn
(progn ,display ,@(and timeout `(,timeout)) nil)
,@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.))
(let ((disp (if (or (symbolp display) (constantp display))
display
'.display.)))
`(let (,@(unless (eq disp display) `((,disp ,display))))
(holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock"
,@(and timeout `(:timeout ,timeout)))
,@body))))))
(defun with-event-queue-function (display timeout function)
(declare (type display display)
(type (or null number) timeout)
(type function function)
#+clx-ansi-common-lisp
(dynamic-extent function)
;; FIXME: see SBCL bug #243
(ignorable display timeout)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg function))
(with-event-queue (display :timeout timeout :inline t)
(funcall function)))
(defmacro with-event-queue-internal ((display &key timeout) &body body)
;; exclusive access to the internal event queues
(let ((disp (if (or (symbolp display) (constantp display)) display '.display.)))
`(let (,@(unless (eq disp display) `((,disp ,display))))
(holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock"
,@(and timeout `(:timeout ,timeout)))
,@body))))
(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. Authorization,
;; if any, is assumed to come from the environment somehow.
(declare (type integer display))
(declare (clx-values display))
;; Get the authorization mechanism from the environment. Handle the
;; special case of a host name of "" and "unix" which means the
;; protocol is :local
(when (null authorization-name)
(multiple-value-setq (authorization-name authorization-data)
(get-best-authorization host
display
(if (member host '("" "unix") :test #'equal)
:local
protocol))))
;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
(let* ((stream (open-x-stream host display protocol))
(disp (make-buffer *output-buffer-size* #'make-display-internal
:host host :display display
:output-stream stream :input-stream stream))
(ok-p nil))
(unwind-protect
(progn
(display-connect disp
:authorization-name authorization-name
:authorization-data authorization-data)
(setf (display-authorization-name disp) authorization-name)
(setf (display-authorization-data disp) authorization-data)
(initialize-resource-allocator disp)
(initialize-predefined-atoms disp)
(initialize-extensions disp)
(when (assoc "BIG-REQUESTS" (display-extension-alist disp)
:test #'string=)
(enable-big-requests disp))
(setq ok-p t))
(unless ok-p (close-display disp :abort t)))
disp))
(defun display-force-output (display)
; Output is normally buffered, this forces any buffered output to the server.
(declare (type display display))
(with-display (display)
(buffer-force-output display)))
(defun close-display (display &key abort)
;; Close the host connection in DISPLAY
(declare (type display display))
(close-buffer display :abort abort))
(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
(card16-put 2 *protocol-major-version*)
(card16-put 4 *protocol-minor-version*)
(card16-put 6 (length authorization-name))
(card16-put 8 (length authorization-data))
(write-sequence-char display 12 authorization-name)
(if (stringp authorization-data)
(write-sequence-char display (lround (+ 12 (length authorization-name)))
authorization-data)
(write-sequence-card8 display (lround (+ 12 (length authorization-name)))
authorization-data)))
(buffer-force-output display)
(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
(make-colormap :id default-colormap-id :display display))
(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
:id visual
:display display
:class (member8-get 4 :static-gray :gray-scale
:static-color :pseudo-color
:true-color :direct-color)
:bits-per-rgb (card8-get 5)
:colormap-entries (card16-get 6)
:red-mask (card32-get 8)
:green-mask (card32-get 12)
: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))))))
(when reply-buffer
(deallocate-reply-buffer reply-buffer))))
display)
(defun display-protocol-version (display)
(declare (type display display))
(declare (clx-values major minor))
(values (display-protocol-major-version display)
(display-protocol-minor-version display)))
(defun display-vendor (display)
(declare (type display display))
(declare (clx-values name release))
(values (display-vendor-name display)
(display-release-number display)))
(defun display-nscreens (display)
(declare (type display display))
(length (display-roots display)))
#+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:
;; :display display
;; :error-key error-key
;; :major integer
;; :minor integer
;; :sequence integer
;; :current-sequence integer
;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
;; :window errors another pair is:
;; :resource-id integer
;; For :atom errors, another pair is:
;; :atom-id integer
;; For :value errors, another pair is:
;; :value integer
)
;; 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.
(defvar *inside-display-after-function* nil)
(defun display-invoke-after-function (display)
; Called after every protocal request is generated
(declare (type display display))
(when (and (display-after-function display)
(not *inside-display-after-function*))
(let ((*inside-display-after-function* t)) ;; Ensure no recursive calls
(funcall (display-after-function display) display))))
(defun display-finish-output (display)
;; 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))
()
)
;; Report asynchronous errors here if the user wants us to.
(report-asynchronous-errors display :after-finish-output))
(defparameter
*request-names*
'#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes"
"DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow"
"MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows"
"ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree"
"InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty"
"GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner"
"ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer"
"GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard"
"UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents"
"GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents"
"TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus"
"QueryKeymap" "OpenFont" "CloseFont" "QueryFont"
"QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath"
"GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC"
"ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles"
"FreeGC" "ClearToBackground" "CopyArea" "CopyPlane"
"PolyPoint" "PolyLine" "PolySegment" "PolyRectangle"
"PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc"
"PutImage" "GetImage" "PolyText8" "PolyText16"
"ImageText8" "ImageText16" "CreateColormap" "FreeColormap"
"CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps"
"AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes"
"FreeColors" "StoreColors" "StoreNamedColor" "QueryColors"
"LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor"
"RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions"
"SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl"
"Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver"
"GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl"
"ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver"
"SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping"))

168
src/clx/dpms.lisp
View file

@ -1,168 +0,0 @@
;;;; 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.
(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:

168
src/clx/exclMakefile
View file

@ -1,168 +0,0 @@
#
# Makefile for CLX
# (X11 R4.4 release, Franz Allegro Common Lisp version)
#
# *************************************************************************
# * 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)

56
src/clx/exclREADME
View file

@ -1,56 +0,0 @@
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

260
src/clx/exclcmac.lisp
View file

@ -1,260 +0,0 @@
;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
;;;
;;; CLX -- exclcmac.cl
;;; This file provides for inline expansion of some functions.
;;;
;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca.
;;;
;;; Permission is granted to any individual or institution to use, copy,
;;; modify, and distribute this software, provided that this complete
;;; copyright and permission notice is maintained, intact, in all copies and
;;; supporting documentation.
;;;
;;; Franz Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;;
;; Type predicates
;;
(excl:defcmacro card8p (x)
(let ((xx (gensym)))
`(let ((,xx ,x))
(declare (optimize (speed 3) (safety 0))
(fixnum ,xx))
(and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0)))))
(excl:defcmacro card16p (x)
(let ((xx (gensym)))
`(let ((,xx ,x))
(declare (optimize (speed 3) (safety 0))
(fixnum ,xx))
(and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0)))))
(excl:defcmacro int8p (x)
(let ((xx (gensym)))
`(let ((,xx ,x))
(declare (optimize (speed 3) (safety 0))
(fixnum ,xx))
(and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7))))))
(excl:defcmacro int16p (x)
(let ((xx (gensym)))
`(let ((,xx ,x))
(declare (optimize (speed 3) (safety 0))
(fixnum ,xx))
(and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15))))))
;; Card29p, card32p, int32p are too large to expand inline
;;
;; Type transformers
;;
(excl:defcmacro card8->int8 (x)
(let ((xx (gensym)))
`(let ((,xx ,x))
,(declare-bufmac)
(declare (type card8 ,xx))
(the int8 (if (logbitp 7 ,xx)
(the int8 (- ,xx #x100))
,xx)))))
(excl:defcmacro int8->card8 (x)
`(locally ,(declare-bufmac)
(the card8 (ldb (byte 8 0) (the int8 ,x)))))
(excl:defcmacro card16->int16 (x)
(let ((xx (gensym)))
`(let ((,xx ,x))
,(declare-bufmac)
(declare (type card16 ,xx))
(the int16 (if (logbitp 15 ,xx)
(the int16 (- ,xx #x10000))
,xx)))))
(excl:defcmacro int16->card16 (x)
`(locally ,(declare-bufmac)
(the card16 (ldb (byte 16 0) (the int16 ,x)))))
(excl:defcmacro card32->int32 (x)
(let ((xx (gensym)))
`(let ((,xx ,x))
,(declare-bufmac)
(declare (type card32 ,xx))
(the int32 (if (logbitp 31 ,xx)
(the int32 (- ,xx #x100000000))
,xx)))))
(excl:defcmacro int32->card32 (x)
`(locally ,(declare-bufmac)
(the card32 (ldb (byte 32 0) (the int32 ,x)))))
(excl:defcmacro char->card8 (char)
`(locally ,(declare-bufmac)
(the card8 (char-code (the string-char ,char)))))
(excl:defcmacro card8->char (card8)
`(locally ,(declare-bufmac)
(the string-char (code-char (the card8 ,card8)))))
;;
;; Array accessors and setters
;;
(excl:defcmacro aref-card8 (a i)
`(locally ,(declare-bufmac)
(the card8 (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:unsigned-byte))))
(excl:defcmacro aset-card8 (v a i)
`(locally ,(declare-bufmac)
(setf (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:unsigned-byte)
(the card8 ,v))))
(excl:defcmacro aref-int8 (a i)
`(locally ,(declare-bufmac)
(the int8 (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:signed-byte))))
(excl:defcmacro aset-int8 (v a i)
`(locally ,(declare-bufmac)
(setf (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:signed-byte)
(the int8 ,v))))
(excl:defcmacro aref-card16 (a i)
`(locally ,(declare-bufmac)
(the card16 (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:unsigned-word))))
(excl:defcmacro aset-card16 (v a i)
`(locally ,(declare-bufmac)
(setf (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:unsigned-word)
(the card16 ,v))))
(excl:defcmacro aref-int16 (a i)
`(locally ,(declare-bufmac)
(the int16 (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:signed-word))))
(excl:defcmacro aset-int16 (v a i)
`(locally ,(declare-bufmac)
(setf (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:signed-word)
(the int16 ,v))))
(excl:defcmacro aref-card32 (a i)
`(locally ,(declare-bufmac)
(the card32 (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:unsigned-long))))
(excl:defcmacro aset-card32 (v a i)
`(locally ,(declare-bufmac)
(setf (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:unsigned-long)
(the card32 ,v))))
(excl:defcmacro aref-int32 (a i)
`(locally ,(declare-bufmac)
(the int32 (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:signed-long))))
(excl:defcmacro aset-int32 (v a i)
`(locally ,(declare-bufmac)
(setf (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:signed-long)
(the int32 ,v))))
(excl:defcmacro aref-card29 (a i)
;; Don't need to mask bits here since X protocol guarantees top bits zero
`(locally ,(declare-bufmac)
(the card29 (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:unsigned-long))))
(excl:defcmacro aset-card29 (v a i)
;; I also assume here Lisp is passing a number that fits in 29 bits.
`(locally ,(declare-bufmac)
(setf (sys:memref (the buffer-bytes ,a)
#.(comp::mdparam 'comp::md-svector-data0-adj)
(the array-index ,i)
:unsigned-long)
(the card29 ,v))))
;;
;; Font accessors
;;
(excl:defcmacro font-id (font)
;; Get font-id, opening font if needed
(let ((f (gensym)))
`(let ((,f ,font))
(or (font-id-internal ,f)
(open-font-internal ,f)))))
(excl:defcmacro font-font-info (font)
(let ((f (gensym)))
`(let ((,f ,font))
(or (font-font-info-internal ,f)
(query-font ,f)))))
(excl:defcmacro font-char-infos (font)
(let ((f (gensym)))
`(let ((,f ,font))
(or (font-char-infos-internal ,f)
(progn (query-font ,f)
(font-char-infos-internal ,f))))))
;;
;; Miscellaneous
;;
(excl:defcmacro current-process ()
`(the (or mp::process null) (and mp::*scheduler-stack-group*
mp::*current-process*)))
(excl:defcmacro process-wakeup (process)
(let ((proc (gensym)))
`(let ((.pw-curproc. mp::*current-process*)
(,proc ,process))
(when (and .pw-curproc. ,proc)
(if (> (mp::process-priority ,proc)
(mp::process-priority .pw-curproc.))
(mp::process-allow-schedule ,proc))))))
(excl:defcmacro buffer-new-request-number (buffer)
(let ((buf (gensym)))
`(let ((,buf ,buffer))
(declare (type buffer ,buf))
(setf (buffer-request-number ,buf)
(ldb (byte 16 0) (1+ (buffer-request-number ,buf)))))))

186
src/clx/excldefsys.lisp
View file

@ -1,186 +0,0 @@
;;; -*- 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.
;;;
(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")
))

76
src/clx/excldep.c
View file

@ -1,76 +0,0 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/*
* Allegro CL dependent C helper routines for CLX
*/
/*
* 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);
}

435
src/clx/excldep.lisp
View file

@ -1,435 +0,0 @@
;;; -*- 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.
;;;
(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))))

367
src/clx/fonts.lisp
View file

@ -1,367 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;; The char-info stuff is here instead of CLX because of uses of int16->card16.
; To allow efficient storage representations, the type char-info is not
; required to be a structure.
;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
;(defun char-<metric> (font index)
; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
; ;; (or an in-bounds index on a pseudo font), although returning zero or
; ;; signalling might be better.
; (declare (type font font)
; (type integer index)
; (clx-values (or null integer))))
;(defun max-char-<metric> (font)
; ;; Note: I have tentatively chosen separate accessors over allowing :min and
; ;; :max as an index above.
; (declare (type font font)
; (clx-values integer)))
;(defun min-char-<metric> (font)
; (declare (type font font)
; (clx-values integer)))
;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
(deftype char-info-vec () '(simple-array int16 (*)))
(macrolet ((def-char-info-accessors (useless-name &body fields)
`(within-definition (,useless-name def-char-info-accessors)
,@(do ((field fields (cdr field))
(n 0 (1+ n))
(name) (type)
(result nil))
((endp field) result)
(setq name (xintern 'char- (caar field)))
(setq type (cadar field))
(flet ((from (form)
(if (eq type 'int16)
form
`(,(xintern 'int16-> type) ,form))))
(push
`(defun ,name (font index)
(declare (type font font)
(type array-index index))
(declare (clx-values (or null ,type)))
(when (and (font-name font)
(index>= (font-max-char font) index (font-min-char font)))
(the ,type
,(from
`(the int16
(let ((char-info-vector (font-char-infos font)))
(declare (type char-info-vec char-info-vector))
(if (index-zerop (length char-info-vector))
;; Fixed width font
(aref (the char-info-vec
(font-max-bounds font))
,n)
;; Variable width font
(aref char-info-vector
(index+
(index*
6
(index-
index
(font-min-char font)))
,n)))))))))
result)
(setq name (xintern 'min-char- (caar field)))
(push
`(defun ,name (font)
(declare (type font font))
(declare (clx-values (or null ,type)))
(when (font-name font)
(the ,type
,(from
`(the int16
(aref (the char-info-vec (font-min-bounds font))
,n))))))
result)
(setq name (xintern 'max-char- (caar field)))
(push
`(defun ,name (font)
(declare (type font font))
(declare (clx-values (or null ,type)))
(when (font-name font)
(the ,type
,(from
`(the int16
(aref (the char-info-vec (font-max-bounds font))
,n))))))
result)))
(defun make-char-info
(&key ,@(mapcar
#'(lambda (field)
`(,(car field) (required-arg ,(car field))))
fields))
(declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
(let ((result (make-array ,(length fields) :element-type 'int16)))
(declare (type char-info-vec result))
,@(do* ((field fields (cdr field))
(var (caar field) (caar field))
(type (cadar field) (cadar field))
(n 0 (1+ n))
(result nil))
((endp field) (nreverse result))
(push `(setf (aref result ,n)
,(if (eq type 'int16)
var
`(,(xintern type '->int16) ,var)))
result))
result)))))
(def-char-info-accessors ignore
(left-bearing int16)
(right-bearing int16)
(width int16)
(ascent int16)
(descent int16)
(attributes card16)))
(defun open-font (display name)
;; Font objects may be cached and reference counted locally within the display
;; object. This function might not execute a with-display if the font is cached.
;; The protocol QueryFont request happens on-demand under the covers.
(declare (type display display)
(type stringable name))
(declare (clx-values font))
(let* ((name-string (string-downcase (string name)))
(font (car (member name-string (display-font-cache display)
:key 'font-name
:test 'equal)))
font-id)
(unless font
(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+)
(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)
;; Called "under the covers" to open a font object
(declare (type font font))
(declare (clx-values resource-id))
(let* ((name-string (font-name font))
(display (font-display font))
(id (allocate-resource-id display font 'font)))
(setf (font-id-internal font) id)
(with-buffer-request (display +x-openfont+)
(resource-id id)
(card16 (length name-string))
(pad16 nil)
(string name-string))
(push font (display-font-cache display))
(incf (font-reference-count font))
id))
(defun discard-font-info (font)
;; Discards any state that can be re-obtained with QueryFont. This is
;; simply a performance hint for memory-limited systems.
(declare (type font font))
(setf (font-font-info-internal font) nil
(font-char-infos-internal font) nil))
(defun query-font (font)
;; Internal function called by font and char info accessors
(declare (type font font))
(declare (clx-values font-info))
(let ((display (font-display font))
font-id
font-info
props)
(setq font-id (font-id font)) ;; May issue an open-font request
(with-buffer-request-and-reply (display +x-queryfont+ 60)
((resource-id font-id))
(let* ((min-byte2 (card16-get 40))
(max-byte2 (card16-get 42))
(min-byte1 (card8-get 49))
(max-byte1 (card8-get 50))
(min-char min-byte2)
(max-char (index+ (index-ash max-byte1 8) max-byte2))
(nfont-props (card16-get 46))
(nchar-infos (index* (card32-get 56) 6))
(char-info (make-array nchar-infos :element-type 'int16)))
(setq font-info
(make-font-info
:direction (member8-get 48 :left-to-right :right-to-left)
:min-char min-char
:max-char max-char
:min-byte1 min-byte1
:max-byte1 max-byte1
:min-byte2 min-byte2
:max-byte2 max-byte2
:all-chars-exist-p (boolean-get 51)
:default-char (card16-get 44)
:ascent (int16-get 52)
:descent (int16-get 54)
:min-bounds (char-info-get 8)
:max-bounds (char-info-get 24)))
(setq props (sequence-get :length (index* 2 nfont-props) :format int32
:result-type 'list :index 60))
(sequence-get :length nchar-infos :format int16 :data char-info
:index (index+ 60 (index* 2 nfont-props 4)))
(setf (font-char-infos-internal font) char-info)
(setf (font-font-info-internal font) font-info)))
;; Replace atom id's with keywords in the plist
(do ((p props (cddr p)))
((endp p))
(setf (car p) (atom-name display (car p))))
(setf (font-info-properties font-info) props)
font-info))
(defun close-font (font)
;; This might not generate a protocol request if the font is reference
;; counted locally.
(declare (type font font))
(when (and (not (plusp (decf (font-reference-count font))))
(font-id-internal font))
(let ((display (font-display font))
(id (font-id-internal font)))
(declare (type display display))
;; Remove font from cache
(setf (display-font-cache display) (delete font (display-font-cache display)))
;; Close the font
(with-buffer-request (display +x-closefont+)
(resource-id id)))))
(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
(declare (type display display)
(type string pattern)
(type card16 max-fonts)
(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))
((card16 max-fonts (length string))
(string string))
(values
(read-sequence-string
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.
;; Returns "pseudo" fonts that contain basic font metrics and properties, but
;; no per-character metrics and no resource-ids. These pseudo fonts will be
;; converted (internally) to real fonts dynamically as needed, by issuing an
;; OpenFont request. However, the OpenFont might fail, in which case the
;; invalid-font error can arise.
(declare (type display display)
(type string pattern)
(type card16 max-fonts)
(type t result-type)) ;; CL type
(declare (clx-values (clx-sequence font)))
(let ((string (string pattern))
(result nil))
(with-buffer-request-and-reply (display +x-listfontswithinfo+ 60
:sizes (8 16) :multiple-reply t)
((card16 max-fonts (length string))
(string string))
(cond ((zerop (card8-get 1)) t)
(t
(let* ((name-len (card8-get 1))
(min-byte2 (card16-get 40))
(max-byte2 (card16-get 42))
(min-byte1 (card8-get 49))
(max-byte1 (card8-get 50))
(min-char min-byte2)
(max-char (index+ (index-ash max-byte1 8) max-byte2))
(nfont-props (card16-get 46))
(font
(make-font
:display display
:name nil
:font-info-internal
(make-font-info
:direction (member8-get 48 :left-to-right :right-to-left)
:min-char min-char
:max-char max-char
:min-byte1 min-byte1
:max-byte1 max-byte1
:min-byte2 min-byte2
:max-byte2 max-byte2
:all-chars-exist-p (boolean-get 51)
:default-char (card16-get 44)
:ascent (int16-get 52)
:descent (int16-get 54)
:min-bounds (char-info-get 8)
:max-bounds (char-info-get 24)
:properties (sequence-get :length (index* 2 nfont-props)
:format int32
:result-type 'list
:index 60)))))
(setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
(push font result))
nil)))
;; Replace atom id's with keywords in the plist
(dolist (font result)
(do ((p (font-properties font) (cddr p)))
((endp p))
(setf (car p) (atom-name display (car p)))))
(coerce (nreverse result) result-type)))
(defun font-path (display &key (result-type 'list))
(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))
()
(values
(read-sequence-string
buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))
(defun set-font-path (display paths)
(declare (type display display)
(type (clx-sequence (or string pathname)) paths))
(let ((path-length (length paths))
(request-length 8))
;; Find the request length
(dotimes (i path-length)
(let* ((string (string (elt paths i)))
(len (length string)))
(incf request-length (1+ len))))
(with-buffer-request (display +x-setfontpath+ :length request-length)
(length (ceiling request-length 4))
(card16 path-length)
(pad16 nil)
(progn
(incf buffer-boffset 8)
(dotimes (i path-length)
(let* ((string (string (elt paths i)))
(len (length string)))
(card8-put 0 len)
(string-put 1 string :appending t :header-length 1)
(incf buffer-boffset (1+ len))))
(setf (buffer-boffset display) (lround buffer-boffset)))))
paths)
(defsetf font-path set-font-path)

972
src/clx/gcontext.lisp
View file

@ -1,972 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; GContext
;;;
;;; 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.
;;;
;;; GContext values are usually cached locally in the GContext object.
;;; This is required because the X.11 server doesn't have any requests
;;; for getting GContext values back.
;;;
;;; GContext changes are cached until force-GContext-changes is called.
;;; All the requests that use GContext (including the GContext accessors,
;;; but not the SETF's) call force-GContext-changes.
;;; In addition, the macro WITH-GCONTEXT may be used to provide a
;;; local view if a GContext.
;;;
;;; Each GContext keeps a copy of the values the server has seen, and
;;; a copy altered by SETF, called the LOCAL-STATE (bad name...).
;;; The SETF accessors increment a timestamp in the GContext.
;;; When the timestamp in a GContext isn't equal to the timestamp in
;;; the local-state, changes have been made, and force-GContext-changes
;;; loops through the GContext and local-state, sending differences to
;;; the server, and updating GContext.
;;;
;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to
;;; a private copy. This is easy (and fast) for lisp machines, but other
;;; lisps will have problems. Fortunately, most other lisps don't care,
;;; because they don't run in a multi-processing shared-address space
;;; environment.
(in-package :xlib)
;; GContext state accessors
;; The state vector contains all card32s to speed server updating
(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+)
(push `(defmacro ,(xintern 'gcontext-internal- name) (state)
`(svref ,state ,,index))
macros)
(setf (getf indexes name) index)
(push (ash 1 index) masks)
(incf index))
(dolist (extra extras)
(push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
`(svref ,state ,,index))
macros)
;; don't override already correct index entries
(unless (or (getf indexes (second extra)) (getf indexes (first extra)))
(setf (getf indexes (or (second extra) (first extra))) index))
(push (logior (ash 1 index)
(if (second extra)
(ash 1 (position (second extra) +gcontext-components+))
0))
masks)
(incf index))
`(within-definition (def-gc-internals ,name)
,@(nreverse macros)
(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 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 (or function symbol) :read-only t)
(copy-function #'(lambda (from-gc to-gc value)
(declare (ignore from-gc to-gc))
value)
:type (or function symbol) :read-only t))
(defvar *gcontext-extensions* nil) ;; list of gcontext-extension
;; Gcontext state Resource
(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states
(defmacro gcontext-state-next (state)
`(svref ,state 0))
(defun allocate-gcontext-state ()
;; Allocate a gcontext-state
;; Loop until a local state is found that's large enough to hold
;; any extensions that may exist.
(let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*))))
(declare (type array-index length))
(loop
(let ((state (or (threaded-atomic-pop *gcontext-local-state-cache*
gcontext-state-next gcontext-state)
(make-array length :initial-element nil))))
(declare (type gcontext-state state))
(when (index>= (length state) length)
(return state))))))
(defun deallocate-gcontext-state (state)
(declare (type gcontext-state state))
(fill state nil)
(threaded-atomic-push state *gcontext-local-state-cache*
gcontext-state-next gcontext-state))
;; Temp-Gcontext Resource
(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts
(defun allocate-temp-gcontext ()
(or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext)
(make-gcontext :local-state '#() :server-state '#())))
(defun deallocate-temp-gcontext (gc)
(declare (type gcontext gc))
(threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext))
;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
;; as (type <type> <name>), there is an accessor:
;(defun gcontext-<name> (gcontext)
; ;; The value will be nil if the last value stored is unknown (e.g., the cache was
; ;; off, or the component was copied from a gcontext with unknown state).
; (declare (type gcontext gcontext)
; (clx-values <type>)))
;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
;(defsetf gcontext-<name> (gcontext) (value)
; )
;; Generate all the accessors and defsetf's for GContext
(defmacro xgcmask->gcmask (mask)
`(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)))
(declare (type gcontext-state ,local-state))
,@body))
(defmacro modify-gcontext ((gcontext local-state) &body body)
;; The timestamp must be altered after the modification
`(let ((,local-state (gcontext-local-state ,gcontext)))
(declare (type gcontext-state ,local-state))
(prog1
(progn ,@body)
(setf (gcontext-internal-timestamp ,local-state) 0))))
(defmacro def-gc-accessor (name type)
(let* ((gcontext-name (xintern 'gcontext- name))
(internal-accessor (xintern 'gcontext-internal- name))
(internal-setfer (xintern 'set- gcontext-name)))
`(within-definition (,name def-gc-accessor)
(defun ,gcontext-name (gcontext)
(declare (type gcontext gcontext))
(declare (clx-values (or null ,type)))
(let ((value (,internal-accessor (gcontext-local-state gcontext))))
(declare (type (or null card32) value))
(when value ;; Don't do anything when value isn't known
(let ((%buffer (gcontext-display gcontext)))
(declare (type display %buffer))
%buffer
(decode-type ,type value)))))
(defun ,internal-setfer (gcontext value)
(declare (type gcontext gcontext)
(type ,type value))
(modify-gcontext (gcontext local-state)
(setf (,internal-accessor local-state) (encode-type ,type value))
,@(when (eq type 'pixmap)
;; write-through pixmaps, because the protocol allows
;; the server to copy the pixmap contents at the time
;; of the store, rather than continuing to share with
;; the pixmap.
`((let ((server-state (gcontext-server-state gcontext)))
(setf (,internal-accessor server-state) nil))))
value))
(defsetf ,gcontext-name ,internal-setfer))))
(defmacro incf-internal-timestamp (state)
(let ((ts (gensym)))
`(let ((,ts (the fixnum (gcontext-internal-timestamp ,state))))
(declare (type fixnum ,ts))
;; the probability seems low enough
(setq ,ts (if (= ,ts most-positive-fixnum)
1
(the fixnum (1+ ,ts))))
(setf (gcontext-internal-timestamp ,state) ,ts))))
(def-gc-accessor function boole-constant)
(def-gc-accessor plane-mask card32)
(def-gc-accessor foreground card32)
(def-gc-accessor background card32)
(def-gc-accessor line-width card16)
(def-gc-accessor line-style (member :solid :dash :double-dash))
(def-gc-accessor cap-style (member :not-last :butt :round :projecting))
(def-gc-accessor join-style (member :miter :round :bevel))
(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled))
(def-gc-accessor fill-rule (member :even-odd :winding))
(def-gc-accessor tile pixmap)
(def-gc-accessor stipple pixmap)
(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin
(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin
;; (def-GC-accessor font font) ;; See below
(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors))
(def-gc-accessor exposures (member :off :on))
(def-gc-accessor clip-x int16)
(def-gc-accessor clip-y int16)
;; (def-GC-accessor clip-mask) ;; see below
(def-gc-accessor dash-offset card16)
;; (def-GC-accessor dashes) ;; see below
(def-gc-accessor arc-mode (member :chord :pie-slice))
(defun gcontext-clip-mask (gcontext)
(declare (type gcontext gcontext))
(declare (clx-values (or null (member :none) pixmap rect-seq)
(or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))
(access-gcontext (gcontext local-state)
(multiple-value-bind (clip clip-mask)
(without-interrupts
(values (gcontext-internal-clip local-state)
(gcontext-internal-clip-mask local-state)))
(if (null clip)
(values (let ((%buffer (gcontext-display gcontext)))
(declare (type display %buffer))
(decode-type (or (member :none) pixmap) clip-mask))
nil)
(values (second clip)
(decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
(first clip)))))))
(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
;; A bit strange, but retains setf form.
;; a nil clip-mask is transformed to an empty vector
`(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask))
(defun set-gcontext-clip-mask (gcontext ordering clip-mask)
;; a nil clip-mask is transformed to an empty vector
(declare (type gcontext gcontext)
(type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
(type (or (member :none) pixmap rect-seq) clip-mask))
(unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
(multiple-value-bind (clip-mask clip)
(typecase clip-mask
(pixmap (values (pixmap-id clip-mask) nil))
((member :none) (values 0 nil))
(sequence
(values nil
(list (encode-type
(or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
ordering)
(copy-seq clip-mask))))
(otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq))))
(modify-gcontext (gcontext local-state)
(let ((server-state (gcontext-server-state gcontext)))
(declare (type gcontext-state server-state))
(without-interrupts
(setf (gcontext-internal-clip local-state) clip
(gcontext-internal-clip-mask local-state) clip-mask)
(if (null clip)
(setf (gcontext-internal-clip server-state) nil)
(setf (gcontext-internal-clip-mask server-state) nil))
(when (and clip-mask (not (zerop clip-mask)))
;; write-through clip-mask pixmap, because the protocol allows the
;; server to copy the pixmap contents at the time of the store,
;; rather than continuing to share with the pixmap.
(setf (gcontext-internal-clip-mask server-state) nil))))))
clip-mask)
(defun gcontext-dashes (gcontext)
(declare (type gcontext gcontext))
(declare (clx-values (or null card8 sequence)))
(access-gcontext (gcontext local-state)
(multiple-value-bind (dash dashes)
(without-interrupts
(values (gcontext-internal-dash local-state)
(gcontext-internal-dashes local-state)))
(if (null dash)
dashes
dash))))
(defsetf gcontext-dashes set-gcontext-dashes)
(defun set-gcontext-dashes (gcontext dashes)
(declare (type gcontext gcontext)
(type (or card8 sequence) dashes))
(multiple-value-bind (dashes dash)
(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
(setf (gcontext-internal-dash local-state) dash
(gcontext-internal-dashes local-state) dashes)
(if (null dash)
(setf (gcontext-internal-dash server-state) nil)
(setf (gcontext-internal-dashes server-state) nil))))))
dashes)
(defun gcontext-font (gcontext &optional metrics-p)
;; If the stored font is known, it is returned. If it is not known and
;; metrics-p is false, then nil is returned. If it is not known and
;; metrics-p is true, then a pseudo font is returned. Full metric and
;; property information can be obtained, but the font does not have a name or
;; a resource-id, and attempts to use it where a resource-id is required will
;; result in an invalid-font error.
(declare (type gcontext gcontext)
(type generalized-boolean metrics-p))
(declare (clx-values (or null font)))
(access-gcontext (gcontext local-state)
(let ((font (gcontext-internal-font-obj local-state)))
(or font
(when metrics-p
;; XXX this isn't correct
(make-font :display (gcontext-display gcontext)
:id (gcontext-id gcontext)
:name nil))))))
(defsetf gcontext-font set-gcontext-font)
(defun set-gcontext-font (gcontext font)
(declare (type gcontext gcontext)
(type fontable font))
(let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font)))
(font (and font-object (font-id font-object))))
;; XXX need to check font has id (and name?)
(modify-gcontext (gcontext local-state)
(let ((server-state (gcontext-server-state gcontext)))
(declare (type gcontext-state server-state))
(without-interrupts
(setf (gcontext-internal-font-obj local-state) font-object
(gcontext-internal-font local-state) font)
;; check against font, not against font-obj
(if (null font)
(setf (gcontext-internal-font server-state) nil)
(setf (gcontext-internal-font-obj server-state) font-object))))))
font)
(defun force-gcontext-changes-internal (gcontext)
;; Force any delayed changes.
(declare (type gcontext gcontext))
#.(declare-buffun)
(let ((display (gcontext-display gcontext))
(server-state (gcontext-server-state gcontext))
(local-state (gcontext-local-state gcontext)))
(declare (type display display)
(type gcontext-state server-state local-state))
;; Update server when timestamps don't match
(unless (= (the fixnum (gcontext-internal-timestamp local-state))
(the fixnum (gcontext-internal-timestamp server-state)))
;; The display is already locked.
(macrolet ((with-buffer ((buffer &key timeout) &body body)
`(progn (progn ,buffer ,@(and timeout `(,timeout)) nil)
,@body)))
;; Because there is no locking on the local state we have to
;; assume that state will change and set timestamps up front,
;; otherwise by the time we figured out there were no changes
;; and tried to store the server stamp as the local stamp, the
;; local stamp might have since been modified.
(setf (gcontext-internal-timestamp local-state)
(incf-internal-timestamp server-state))
(block no-changes
(let ((last-request (buffer-last-request display)))
(with-buffer-request (display +x-changegc+)
(gcontext gcontext)
(progn
(do ((i 0 (index+ i 1))
(bit 1 (the xgcmask (ash bit 1)))
(nbyte 12)
(mask 0)
(local 0))
((index>= i +gcontext-fast-change-length+)
(when (zerop mask)
;; If nothing changed, restore last-request and quit
(setf (buffer-last-request display)
(if (zerop (buffer-last-request display))
nil
last-request))
(return-from no-changes nil))
(card29-put 8 mask)
(card16-put 2 (index-ash nbyte -2))
(index-incf (buffer-boffset display) nbyte))
(declare (type array-index i nbyte)
(type xgcmask bit)
(type gcmask mask)
(type (or null card32) local))
(unless (eql (the (or null card32) (svref server-state i))
(setq local (the (or null card32) (svref local-state i))))
(setf (svref server-state i) local)
(card32-put nbyte local)
(setq mask (the gcmask (logior mask bit)))
(index-incf nbyte 4)))))))
;; Update GContext extensions
(do ((extension *gcontext-extensions* (cdr extension))
(i *gcontext-data-length* (index+ i 1))
(local))
((endp extension))
(unless (eql (svref server-state i)
(setq local (svref local-state i)))
(setf (svref server-state i) local)
(funcall (gcontext-extension-set-function (car extension)) gcontext local)))
;; Update clipping rectangles
(multiple-value-bind (local-clip server-clip)
(without-interrupts
(values (gcontext-internal-clip local-state)
(gcontext-internal-clip server-state)))
(unless (equalp local-clip server-clip)
(setf (gcontext-internal-clip server-state) nil)
(unless (null local-clip)
(with-buffer-request (display +x-setcliprectangles+)
(data (first local-clip))
(gcontext gcontext)
;; XXX treat nil correctly
(card16 (or (gcontext-internal-clip-x local-state) 0)
(or (gcontext-internal-clip-y local-state) 0))
;; XXX this has both int16 and card16 values
((sequence :format int16) (second local-clip)))
(setf (gcontext-internal-clip server-state) local-clip))))
;; Update dashes
(multiple-value-bind (local-dash server-dash)
(without-interrupts
(values (gcontext-internal-dash local-state)
(gcontext-internal-dash server-state)))
(unless (equalp local-dash server-dash)
(setf (gcontext-internal-dash server-state) nil)
(unless (null local-dash)
(with-buffer-request (display +x-setdashes+)
(gcontext gcontext)
;; XXX treat nil correctly
(card16 (or (gcontext-internal-dash-offset local-state) 0)
(length local-dash))
((sequence :format card8) local-dash))
(setf (gcontext-internal-dash server-state) local-dash))))))))
(defun force-gcontext-changes (gcontext)
;; Force any delayed changes.
(declare (type gcontext gcontext))
(let ((display (gcontext-display gcontext))
(server-state (gcontext-server-state gcontext))
(local-state (gcontext-local-state gcontext)))
(declare (type gcontext-state server-state local-state))
;; Update server when timestamps don't match
(unless (= (the fixnum (gcontext-internal-timestamp local-state))
(the fixnum (gcontext-internal-timestamp server-state)))
(with-display (display)
(force-gcontext-changes-internal gcontext)))))
;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN
;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN
;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS
;;; BACK.
(defmacro with-gcontext ((gcontext &rest options &key clip-ordering
&allow-other-keys)
&body body)
;; "Binds" the gcontext components specified by options within the
;; dynamic scope of the body (i.e., indefinite scope and dynamic
;; extent), on a per-process basis in a multi-process environment.
;; The body is not surrounded by a with-display. If cache-p is nil or
;; the some component states are unknown, this will implement
;; save/restore by creating a temporary gcontext and doing
;; copy-gcontext-components to and from it.
(declare (arglist (gcontext &rest options &key
function plane-mask foreground background
line-width line-style cap-style join-style
fill-style fill-rule arc-mode tile stipple ts-x
ts-y font subwindow-mode exposures clip-x clip-y
clip-mask clip-ordering dash-offset dashes
&allow-other-keys)
&body body))
(remf options :clip-ordering)
(let ((gc (gensym))
(saved-state (gensym))
(temp-gc (gensym))
(temp-mask (gensym))
(temp-vars nil)
(setfs nil)
(indexes nil) ; List of gcontext field indices
(extension-indexes nil) ; List of gcontext extension field indices
(ts-index (getf *gcontext-indexes* :timestamp)))
(do* ((option options (cddr option))
(name (car option) (car option))
(value (cadr option) (cadr option)))
((endp option) (setq setfs (nreverse setfs)))
(let ((index (getf *gcontext-indexes* name)))
(if index
(push index indexes)
(let ((extension (find name *gcontext-extensions*
:key #'gcontext-extension-name)))
(if extension
(progn
(push (xintern "Internal-" 'gcontext- name "-State-Index")
extension-indexes))
(x-type-error name 'gcontext-key)))))
(let ((accessor `(,(xintern 'gcontext- name) ,gc
,@(when (eq name :clip-mask) `(,clip-ordering))))
(temp-var (gensym)))
(when value
(push `(,temp-var ,value) temp-vars)
(push `(when ,temp-var (setf ,accessor ,temp-var)) setfs))))
(if setfs
`(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
(copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
(declare (type gcontext ,gc)
(type gcontext-state ,saved-state)
(type xgcmask ,temp-mask)
(type (or null gcontext) ,temp-gc))
(with-gcontext-bindings (,gc ,saved-state
,(append indexes extension-indexes)
,ts-index ,temp-mask ,temp-gc)
(let ,temp-vars
,@setfs)
,@body))
`(progn ,@body))))
(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices)
;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK
(declare (type gcontext gcontext)
(type list indexes)
(dynamic-extent extension-indices))
(let ((local-state (gcontext-local-state gcontext))
(saved-state (allocate-gcontext-state))
(cache-p (gcontext-cache-p gcontext)))
(declare (type gcontext-state local-state saved-state))
(setf (gcontext-internal-timestamp saved-state) 1)
(let ((temp-gc nil)
(temp-mask 0)
(extension-mask 0))
(declare (type xgcmask temp-mask)
(type integer extension-mask))
(dolist (i indexes)
(when (or (not (setf (svref saved-state i) (svref local-state i)))
(not cache-p))
(setq temp-mask
(the xgcmask (logior temp-mask
(the xgcmask (svref *gcontext-masks* i)))))))
(dolist (i extension-indices)
(when (or (not (setf (svref saved-state i) (svref local-state i)))
(not cache-p))
(setq extension-mask
(the xgcmask (logior extension-mask (ash 1 i))))))
(when (or (plusp temp-mask)
(plusp extension-mask))
;; Copy to temporary GC when field unknown or cache-p false
(let ((display (gcontext-display gcontext)))
(declare (type display display))
(with-display (display)
(setq temp-gc (allocate-temp-gcontext))
(setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext)
(gcontext-display temp-gc) display
(gcontext-drawable temp-gc) (gcontext-drawable gcontext)
(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+)
(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+)
(gcontext gcontext)
(gcontext temp-gc)
(card29 (xgcmask->gcmask temp-mask))))
;; Copy extension fields to the new gcontext
(when (plusp extension-mask)
;; Copy extension fields from temp back to gcontext
(do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1))
(i 0 (index+ i 1)))
((zerop bit))
(let ((copy-function (gcontext-extension-copy-function
(elt *gcontext-extensions* i))))
(funcall copy-function gcontext temp-gc
(svref local-state (index+ i *gcontext-data-length*))))))
)))
(values gcontext saved-state (logior temp-mask extension-mask) temp-gc))))
(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
(declare (type gcontext gcontext temp-gc)
(type xgcmask temp-mask))
(let ((display (gcontext-display gcontext)))
(declare (type display display))
(with-display (display)
(with-buffer-request (display +x-copygc+)
(gcontext temp-gc)
(gcontext gcontext)
(card29 (xgcmask->gcmask temp-mask)))
;; Copy extension fields from temp back to gcontext
(do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
(extensions *gcontext-extensions* (cdr extensions))
(i *gcontext-data-length* (index+ i 1))
(local-state (gcontext-local-state temp-gc)))
((zerop bit))
(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+)
(gcontext temp-gc))
(deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
(deallocate-temp-gcontext temp-gc)
;; Copy saved state back to server state
(do ((server-state (gcontext-server-state gcontext))
(bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1)))
(i 0 (index+ i 1)))
((zerop bit)
(incf-internal-timestamp server-state))
(declare (type gcontext-state server-state)
(type gcmask bit)
(type array-index i))
(when (oddp bit)
(setf (svref server-state i) nil))))))
(defun create-gcontext (&rest options &key (drawable (required-arg drawable))
function plane-mask foreground background
line-width line-style cap-style join-style fill-style fill-rule
arc-mode tile stipple ts-x ts-y font subwindow-mode
exposures clip-x clip-y clip-mask clip-ordering
dash-offset dashes
(cache-p t)
&allow-other-keys)
;; Only non-nil components are passed on in the request, but for effective caching
;; assumptions have to be made about what the actual protocol defaults are. For
;; all gcontext components, a value of nil causes the default gcontext value to be
;; used. For clip-mask, this implies that an empty rect-seq cannot be represented
;; as a list. Note: use of stringable as font will cause an implicit open-font.
;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If
;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
;; component will have no effect unless the new value differs from the cached
;; value. Component changes (setfs and with-gcontext) are always deferred
;; regardless of the cache mode, and sent over the protocol only when required by a
;; local operation or by an explicit call to force-gcontext-changes.
(declare (type drawable drawable) ; Required to be non-null
(type (or null boole-constant) function)
(type (or null pixel) plane-mask foreground background)
(type (or null card16) line-width dash-offset)
(type (or null int16) ts-x ts-y clip-x clip-y)
(type (or null (member :solid :dash :double-dash)) line-style)
(type (or null (member :not-last :butt :round :projecting)) cap-style)
(type (or null (member :miter :round :bevel)) join-style)
(type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
(type (or null (member :even-odd :winding)) fill-rule)
(type (or null (member :chord :pie-slice)) arc-mode)
(type (or null pixmap) tile stipple)
(type (or null fontable) font)
(type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
(type (or null (member :on :off)) exposures)
(type (or null (member :none) pixmap rect-seq) clip-mask)
(type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
(type (or null card8 sequence) dashes)
(dynamic-extent options)
(type generalized-boolean cache-p))
(declare (clx-values gcontext))
(let* ((display (drawable-display drawable))
(gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p))
(local-state (gcontext-local-state gcontext))
(server-state (gcontext-server-state gcontext))
(gcontextid (allocate-resource-id display gcontext 'gcontext)))
(declare (type display display)
(type gcontext gcontext)
(type resource-id gcontextid)
(type gcontext-state local-state server-state))
(setf (gcontext-id gcontext) gcontextid)
(unless function (setf (gcontext-function gcontext) boole-1))
;; using the depth of the drawable would be better, but ...
(unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff))
(unless foreground (setf (gcontext-foreground gcontext) 0))
(unless background (setf (gcontext-background gcontext) 1))
(unless line-width (setf (gcontext-line-width gcontext) 0))
(unless line-style (setf (gcontext-line-style gcontext) :solid))
(unless cap-style (setf (gcontext-cap-style gcontext) :butt))
(unless join-style (setf (gcontext-join-style gcontext) :miter))
(unless fill-style (setf (gcontext-fill-style gcontext) :solid))
(unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd))
(unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice))
(unless ts-x (setf (gcontext-ts-x gcontext) 0))
(unless ts-y (setf (gcontext-ts-y gcontext) 0))
(unless subwindow-mode (setf (gcontext-subwindow-mode gcontext)
:clip-by-children))
(unless exposures (setf (gcontext-exposures gcontext) :on))
(unless clip-mask (setf (gcontext-clip-mask gcontext) :none))
(unless clip-x (setf (gcontext-clip-x gcontext) 0))
(unless clip-y (setf (gcontext-clip-y gcontext) 0))
(unless dashes (setf (gcontext-dashes gcontext) 4))
(unless dash-offset (setf (gcontext-dash-offset gcontext) 0))
;; a bit kludgy, but ...
(replace server-state local-state)
(when function (setf (gcontext-function gcontext) function))
(when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask))
(when foreground (setf (gcontext-foreground gcontext) foreground))
(when background (setf (gcontext-background gcontext) background))
(when line-width (setf (gcontext-line-width gcontext) line-width))
(when line-style (setf (gcontext-line-style gcontext) line-style))
(when cap-style (setf (gcontext-cap-style gcontext) cap-style))
(when join-style (setf (gcontext-join-style gcontext) join-style))
(when fill-style (setf (gcontext-fill-style gcontext) fill-style))
(when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule))
(when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode))
(when tile (setf (gcontext-tile gcontext) tile))
(when stipple (setf (gcontext-stipple gcontext) stipple))
(when ts-x (setf (gcontext-ts-x gcontext) ts-x))
(when ts-y (setf (gcontext-ts-y gcontext) ts-y))
(when font (setf (gcontext-font gcontext) font))
(when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
(when exposures (setf (gcontext-exposures gcontext) exposures))
(when clip-x (setf (gcontext-clip-x gcontext) clip-x))
(when clip-y (setf (gcontext-clip-y gcontext) clip-y))
(when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
(when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
(when dashes (setf (gcontext-dashes gcontext) dashes))
(setf (gcontext-internal-timestamp server-state) 1)
(setf (gcontext-internal-timestamp local-state)
;; SetClipRectangles or SetDashes request need to be sent?
(if (or (gcontext-internal-clip local-state)
(gcontext-internal-dash local-state))
;; Yes, mark local state "modified" to ensure
;; force-gcontext-changes will occur.
0
;; No, mark local state "unmodified"
1))
(with-buffer-request (display +x-creategc+)
(resource-id gcontextid)
(drawable drawable)
(progn (do* ((i 0 (index+ i 1))
(bit 1 (the xgcmask (ash bit 1)))
(nbyte 16)
(mask 0)
(local (svref local-state i) (svref local-state i)))
((index>= i +gcontext-fast-change-length+)
(card29-put 12 mask)
(card16-put 2 (index-ash nbyte -2))
(index-incf (buffer-boffset display) nbyte))
(declare (type array-index i nbyte)
(type xgcmask bit)
(type gcmask mask)
(type (or null card32) local))
(unless (eql local (the (or null card32) (svref server-state i)))
(setf (svref server-state i) local)
(card32-put nbyte local)
(setq mask (the gcmask (logior mask bit)))
(index-incf nbyte 4)))))
;; Initialize extensions
(do ((extensions *gcontext-extensions* (cdr extensions))
(i *gcontext-data-length* (index+ i 1)))
((endp extensions))
(declare (type list extensions)
(type array-index i))
(setf (svref server-state i)
(setf (svref local-state i)
(gcontext-extension-default (car extensions)))))
;; Set extension values
(do* ((option-list options (cddr option-list))
(option (car option-list) (car option-list))
(extension))
((endp option-list))
(declare (type list option-list))
(cond ((getf *gcontext-indexes* option)) ; Gcontext field
((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter
((setq extension (find option *gcontext-extensions*
:key #'gcontext-extension-name))
(funcall (gcontext-extension-set-function extension)
gcontext (second option-list)))
(t (x-type-error option 'gcontext-key))))
gcontext))
(defun copy-gcontext-components (src dst &rest keys)
(declare (type gcontext src dst)
(dynamic-extent keys))
;; you might ask why this isn't just a bunch of
;; (setf (gcontext-<mumble> dst) (gcontext-<mumble> src))
;; the answer is that you can do that yourself if you want, what we are
;; providing here is access to the protocol request, which will generally
;; be more efficient (particularly for things like clip and dash lists).
(when keys
(let ((display (gcontext-display src))
(mask 0))
(declare (type xgcmask mask))
(with-display (display)
(force-gcontext-changes-internal src)
(force-gcontext-changes-internal dst)
;; collect entire mask and handle extensions
(dolist (key keys)
(let ((i (getf *gcontext-indexes* key)))
(declare (type (or null array-index) i))
(if i
(setq mask (the xgcmask (logior mask
(the xgcmask (svref *gcontext-masks* i)))))
(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+ (position extension *gcontext-extensions*) *gcontext-data-length*)))
(x-type-error key 'gcontext-key))))))
(when (plusp mask)
(do ((src-server-state (gcontext-server-state src))
(dst-server-state (gcontext-server-state dst))
(dst-local-state (gcontext-local-state dst))
(bit mask (the xgcmask (ash bit -1)))
(i 0 (index+ i 1)))
((zerop bit)
(incf-internal-timestamp dst-server-state)
(setf (gcontext-internal-timestamp dst-local-state) 0))
(declare (type gcontext-state src-server-state dst-server-state dst-local-state)
(type xgcmask bit)
(type array-index i))
(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+)
(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+)
(do ((extensions *gcontext-extensions* (cdr extensions))
(i *gcontext-data-length* (index+ i 1)))
((endp extensions))
(funcall (gcontext-extension-copy-function (car extensions))
src dst (svref (gcontext-local-state src) i))))
(defun free-gcontext (gcontext)
(declare (type gcontext gcontext))
(let ((display (gcontext-display gcontext)))
(with-buffer-request (display +x-freegc+)
(gcontext gcontext))
(deallocate-resource-id display (gcontext-id gcontext) 'gcontext)
(deallocate-gcontext-state (gcontext-server-state gcontext))
(deallocate-gcontext-state (gcontext-local-state gcontext))
nil))
(defmacro define-gcontext-accessor (name &key default set-function copy-function)
;; This will define a new gcontext accessor called NAME.
;; Defines the gcontext-NAME accessor function and its defsetf.
;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
;; gcontext-cache-p is true. The NAME keyword will be allowed in
;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
;; from create-gcontext, and force-gcontext-changes.
;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
;; from copy-gcontext and copy-gcontext-components.
;; The copy-function defaults to:
;; (lambda (ignore dst-gc value)
;; (if value
;; (,set-function dst-gc value)
;; (error "Can't copy unknown GContext component ~a" ',name)))
(declare (type symbol name)
(type t default)
(type symbol set-function) ;; required
(type (or symbol list) copy-function))
(let* ((gc-name (intern (concatenate 'string
(string 'gcontext-)
(string name)))) ;; in current package
(key-name (kintern name))
(setfer (xintern "Set-" gc-name))
(internal-set-function (xintern "Internal-Set-" gc-name))
(internal-copy-function (xintern "Internal-Copy-" gc-name))
(internal-state-index (xintern "Internal-" gc-name "-State-Index")))
(unless copy-function
(setq copy-function
`(lambda (src-gc dst-gc value)
(declare (ignore src-gc))
(if value
(,set-function dst-gc value)
(error "Can't copy unknown GContext component ~a" ',name)))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter ,internal-state-index
(add-gcontext-extension ',key-name ,default ',internal-set-function
',internal-copy-function))
) ;; end eval-when
(defun ,gc-name (gcontext)
(svref (gcontext-local-state gcontext) ,internal-state-index))
(defun ,setfer (gcontext new-value)
(let ((local-state (gcontext-local-state gcontext)))
(setf (gcontext-internal-timestamp local-state) 0)
(setf (svref local-state ,internal-state-index) new-value)))
(defsetf ,gc-name ,setfer)
(defun ,internal-set-function (gcontext new-value)
(,set-function gcontext new-value)
(setf (svref (gcontext-server-state gcontext) ,internal-state-index)
(setf (svref (gcontext-local-state gcontext) ,internal-state-index)
new-value)))
(defun ,internal-copy-function (src-gc dst-gc new-value)
(,copy-function src-gc dst-gc new-value)
(setf (svref (gcontext-local-state dst-gc) ,internal-state-index)
(setf (svref (gcontext-server-state dst-gc) ,internal-state-index)
new-value)))
',name)))
;; GContext extension fields are treated in much the same way as normal GContext
;; components. The current value is stored in a slot of the gcontext-local-state,
;; and the value known to the server is in a slot of the gcontext-server-state.
;; The slot-number is defined by its position in the *gcontext-extensions* list.
;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is
;; the extension component name) reflects this position. The position within
;; *gcontext-extensions* and the value of the special value are determined at
;; LOAD time to facilitate merging of seperately compiled extension files.
(defun add-gcontext-extension (name default-value set-function copy-function)
(declare (type symbol name)
(type t default-value)
(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*)))))
(setf (nth number *gcontext-extensions*)
(make-gcontext-extension :name name
:default default-value
:set-function set-function
:copy-function copy-function))
(+ number *gcontext-data-length*)))

Some files were not shown because too many files have changed in this diff Show more