From 895297634e2024d0c113f8114403efd16e664ba4 Mon Sep 17 00:00:00 2001 From: MatthewRock Date: Sat, 18 Jun 2016 14:11:21 +0200 Subject: [PATCH 01/92] Minor fixes in MAN, update timestamp --- src/doc/ecl.man.in | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/doc/ecl.man.in b/src/doc/ecl.man.in index 926a2e8d1..bff10ad95 100644 --- a/src/doc/ecl.man.in +++ b/src/doc/ecl.man.in @@ -1,4 +1,4 @@ -.TH ECL 1 2016-05-10 +.TH ECL 1 2016-06-18 .UC 4 .SH NAME ecl \- Embeddable Common Lisp @@ -91,7 +91,7 @@ Executes the given .I file and exits, without providing a read-eval-print loop. If you want to use lisp as a scripting language, you can write -.BR "#!usr/bin/env ecl -shell" +.BR "#!@bindir@/ecl -shell" on the first line of the file to be executed, and then ECL will be automatically invoked. .TP @@ -197,7 +197,7 @@ or standalone executable programs. The original version was developed by Giuseppe Attardi starting from the Kyoto Common Lisp implementation by Taiichi Yuasa, Masami Hagiya and Juan Jose Garcia -Ripoll.The current maintainer of ECL is Dawid Kochmański, +Ripoll. The current maintainer of ECL is Dawid Kochmański, who can be reached at the ECL mailing list. .SH FILES @@ -213,9 +213,9 @@ ANSI Common Lisp standard X3.226-1994 .IP "" The Common Lisp HyperSpec .SH "BUGS" -Unfortunately it is possible that there are some bugs in the program.In case you find any bug, -please report it as an issue(after making sure that it hasn't been reported or fixed) -to official gitlab repository: https://gitlab.com/embeddable-common-lisp/ecl/issues +Unfortunately it is possible that there are some bugs in the program. In case you find any bug, +please report it as an issue (after making sure that it hasn't been reported or fixed) +to official gitlab repository: https://gitlab.com/embeddable-common-lisp/ecl/issues . .SH "LICENSE" ECL is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published From 8cdadf02ad3204b2d835e4ffe68e5964e2ee3993 Mon Sep 17 00:00:00 2001 From: MatthewRock Date: Sat, 18 Jun 2016 14:11:21 +0200 Subject: [PATCH 02/92] Minor fixes in MAN, update timestamp --- src/doc/ecl.man.in | 51 +++++++++++++--------------------------------- 1 file changed, 14 insertions(+), 37 deletions(-) diff --git a/src/doc/ecl.man.in b/src/doc/ecl.man.in index bff10ad95..aae10c533 100644 --- a/src/doc/ecl.man.in +++ b/src/doc/ecl.man.in @@ -9,7 +9,7 @@ ecl \- Embeddable Common Lisp .br [\fB-dir\fP \fIdir\fP] [\fB-load\fP \fIfile\fP] [\fB-shell\fP \fIfile\fP] [\fB-eval\fP \fIexpr\fP] .br -[\fB-norc\fP] [\fB-hp\fP | \fB-nohp\fP] +[\fB-norc\fP] .br [\fB--c-stack\fP \fIsize\fP] [\fB--lisp-stack\fP \fIsize\fP] .br @@ -27,37 +27,23 @@ ecl \- Embeddable Common Lisp .SH DESCRIPTION .sp -ECL stands for Embeddable Common Lisp. -The ECL project is an effort to modernize -Giuseppe Attardi's ECL environment to -produce an implementation of the Common Lisp -language which complies to the ANSI X3J13 -definition of the language. +ECL (Embeddable Common-Lisp) is an interpreter of the Common-Lisp language as described in the X3J13 Ansi specification, featuring CLOS (Common-Lisp Object System), conditions, loops, etc, plus a translator to C, which can produce standalone executables. + +ECL supports the operating systems Linux, FreeBSD, NetBSD, OpenBSD, OS X, Solaris and Windows, running on top of the Intel, Sparc, Alpha, PowerPC and ARM processors. .PP The current ECL implementation features: .IP \(bu A bytecode compiler and interpreter. .IP \(bu -A translator to C. +Compiles Lisp also with any C/C++ compiler .IP \(bu -An interface to foreign functions. +Can build standalone executables and libraries .IP \(bu -A dynamic loader. +ASDF, Sockets, Gray streams, MOP, and other useful components .IP \(bu -The possibility to build standalone executables. +Extremely portable .IP \(bu -The Common Lisp Object System (CLOS). -.IP \(bu -Conditions and restarts for handling errors. -.IP \(bu -Sockets as ordinary streams. -.IP \(bu -The Gnu Multiprecision library for fast bignum operations. -.IP \(bu -A simple conservative mark & sweep garbage collector. -.IP \(bu -The Boehm-Weiser garbage collector. - +A reasonable license .PP \fBecl\fP without any argument gives you the interactive lisp. @@ -84,7 +70,7 @@ Run without debugging setup phase, meaning that errors prevent ECL from starting .BI \-eval " file" Evaluate the .I file -before starting the ECL, or loading the \.rc files. +before loading the .rc file and starting the Top Level .TP .BI \-shell " file" Executes the given @@ -123,7 +109,7 @@ in kilobytes. .BI \-\-c-stack " size" Specify stack .I size - in kilobytes for C compiler. +in kilobytes for C compiler. .TP .BI \-\-trap-fpe Make ECL debugger catch floating point exception. @@ -144,12 +130,12 @@ for standard input. .BI \-\-output-encoding " encoding" Specify the external .I encoding - for standard output. +for standard output. .TP .BI \-\-error-encoding " encoding" Specify the external .I encoding - for standard error. +for standard error. .TP .BI \-o " file" @@ -181,12 +167,6 @@ native code program. .BI \-q Short for quiet - produce less notes. .TP -.BI \-hp -This option is deprecated and doesn't do anything. -.TP -.BI \-nodp -This option is deprecated and doesn't do anything. -.TP .BI \-s Produce a linkable object file. It cannot be loaded with load, but it can be used to build libraries @@ -195,10 +175,7 @@ or standalone executable programs. .SH AUTHORS -The original version was developed by Giuseppe Attardi starting from the Kyoto -Common Lisp implementation by Taiichi Yuasa, Masami Hagiya and Juan Jose Garcia -Ripoll. The current maintainer of ECL is Dawid Kochmański, -who can be reached at the ECL mailing list. +The original version was developed by Giuseppe Attardi starting from the Kyoto Common Lisp implementation by Taiichi Yuasa, Masami Hagiya and Juan Jose Garcia Ripoll. The current maintainer of ECL is Daniel Kochmański, who can be reached at the ECL mailing list. .SH FILES .TP From 4553d5b351aaab59a3f1ff9e93081f9221baf674 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Jun 2016 16:47:13 +0200 Subject: [PATCH 03/92] new-doc: update new-doc --- src/doc/new-doc/.gitignore | 1 + src/doc/new-doc/Makefile | 1 + .../contributing-documentation.txi | 6 +++ src/doc/new-doc/developer-guide/objects.txi | 18 +++---- src/doc/new-doc/introduction/about_man.txi | 47 +++++++++++++++++++ src/doc/new-doc/introduction/history.txi | 2 +- src/doc/new-doc/introduction/index.txi | 2 + src/doc/new-doc/macros.txi | 2 +- src/doc/new-doc/new-doc.txi | 1 + src/doc/new-doc/standards/evaluation.txi | 4 +- src/doc/new-doc/standards/overview.txi | 2 +- src/doc/new-doc/user-guide/break-loop.txi | 2 + src/doc/new-doc/user-guide/building.txi | 21 +-------- src/doc/new-doc/user-guide/index.txi | 3 +- src/doc/new-doc/user-guide/invoking.txi | 27 +++++------ 15 files changed, 89 insertions(+), 50 deletions(-) create mode 100644 src/doc/new-doc/.gitignore create mode 100644 src/doc/new-doc/introduction/about_man.txi create mode 100644 src/doc/new-doc/user-guide/break-loop.txi diff --git a/src/doc/new-doc/.gitignore b/src/doc/new-doc/.gitignore new file mode 100644 index 000000000..0b84df0f0 --- /dev/null +++ b/src/doc/new-doc/.gitignore @@ -0,0 +1 @@ +*.html \ No newline at end of file diff --git a/src/doc/new-doc/Makefile b/src/doc/new-doc/Makefile index 3f6036310..cca572148 100644 --- a/src/doc/new-doc/Makefile +++ b/src/doc/new-doc/Makefile @@ -15,6 +15,7 @@ ecldoc.info: $(FILES) makeinfo new-doc.txi new-doc.html: $(FILES) + makeinfo --html --no-split new-doc.txi clean: rm -rf *.{aux,cf,cfs,cp,cpp,cpps,cps,ex,exs,fn,fns,ft,fts,log,lsp,lsps,toc,tp,tps,vr,vrs,pdf,info,html} diff --git a/src/doc/new-doc/developer-guide/contributing-documentation.txi b/src/doc/new-doc/developer-guide/contributing-documentation.txi index d5cac8cb2..817e09849 100644 --- a/src/doc/new-doc/developer-guide/contributing-documentation.txi +++ b/src/doc/new-doc/developer-guide/contributing-documentation.txi @@ -190,3 +190,9 @@ References should be added like as follows: @verbatim [@ref{Standards}] @end verbatim + +Links: +@verbatim +@uref{http://example.org} +@uref{http://example.org, Example website} +@end verbatim diff --git a/src/doc/new-doc/developer-guide/objects.txi b/src/doc/new-doc/developer-guide/objects.txi index d7dcae215..aa2de36ff 100644 --- a/src/doc/new-doc/developer-guide/objects.txi +++ b/src/doc/new-doc/developer-guide/objects.txi @@ -291,7 +291,7 @@ cl_object array2 = string_to_object(string); @end deftypefun @node Integers (dev) -@subsection Integers (dev) +@subsection Integers Common-Lisp distinguishes two types of integer types: @code{bignum}s and @code{fixnum}s. A fixnum is a small integer, which ideally occupies only a word of memory and which is between the values @@ -373,7 +373,7 @@ appropriate size. Signals an error if @var{o} is not of fixnum type. @end deftypefun @node Characters (dev) -@subsection Characters (dev) +@subsection Characters @cfindex --enable-unicode (YES|no|32) @@ -451,7 +451,7 @@ before comparing them. @end deftypefun @node Arrays (dev) -@subsection Arrays (dev) +@subsection Arrays An array is an aggregate of data of a common type, which can be accessed with one or more non-negative indices. ECL stores arrays as a C structure @@ -595,7 +595,7 @@ cl_print(1, array); /* Outputs #(1 2 3 5) */ @end deftypefun @node Strings (dev) -@subsection Strings (dev) +@subsection Strings A string, both in Common-Lisp and in ECL is nothing but a vector of characters. Therefore, almost everything mentioned in the section of @@ -633,7 +633,7 @@ supported, then @code{ECL_EXTENDED_STRING_P} always returns 0. @end deftypefun @node Bit-vectors (dev) -@subsection Bit-vectors (dev) +@subsection Bit-vectors Bit-vector operations are implemented in file @code{src/c/array.d}. Bit-vector shares the structure with a vector, @@ -641,7 +641,7 @@ therefore, almost everything mentioned in the section of arrays remains valid here. @node Streams (dev) -@subsection Streams (dev) +@subsection Streams Streams implementation is a broad topic. Most of the implementation is done in the file @code{src/c/file.d}. Stream handling may have different @@ -713,7 +713,7 @@ object of type @code{m}. @end deftypefun @node Structures (dev) -@subsection Structures (dev) +@subsection Structures Structures and instances share the same datatype @code{t_instance} ( with a few exceptions. Structure implementation details are the file @@ -733,7 +733,7 @@ Convenience functions for the structures. @end deftypefun @node Instances (dev) -@subsection Instances (dev) +@subsection Instances @cppindex ECL_CLASS_OF @cppindex ECL_SPEC_FLAG @@ -758,7 +758,7 @@ Convenience functions for the structures. @end deftypefun @node Bytecodes (dev) -@subsection Bytecodes (dev) +@subsection Bytecodes A bytecodes object is a lisp object with a piece of code that can be interpreted. The objects of type t_bytecode are implicitly constructed diff --git a/src/doc/new-doc/introduction/about_man.txi b/src/doc/new-doc/introduction/about_man.txi new file mode 100644 index 000000000..13e43754e --- /dev/null +++ b/src/doc/new-doc/introduction/about_man.txi @@ -0,0 +1,47 @@ +@node About this book +@section About this book + +This manual is part of the ECL software system. It documents deviations +of ECL from various standards (@bibcite{ANSI}, @bibcite{AMOP},...), +extensions, daily working process (compiling files, loading sources, +creating programs, etc) and the internals of this implementation. + +It is not intended as a source to learn Common Lisp. There are other +tutorials and textbooks available in the Net which serve this +purpose. The homepage of the +@uref{https://common-lisp.net,Common-Lisp.net} contains a good list of +links of such teaching and learning material. + +This book is structure into four parts: + +@subsection User's guide +We begin with [@ref{User's guide}] which provides introductory material +showing the user how to build and use ECL and some of its unique +features. This part assumes some basic Common Lisp knowledge and is +suggested as an entry point for a new users who want to start using +@ecl{}. + +@subsection Developer's guide +[@ref{Developer's guide}] documents @ecl{} implementation details. This +part isn not meant for normal users but rather for the ECL developers +and other people who want to contribute to @ecl{}. This section is prone +to change due to the dynamic nature of a software. Covered topics +include source code structure, contributing guide, internal +implementation details and many other topics relevant to the development +process. + +@subsection Standards +[@ref{Standards}] documents all parts of the standard which are left as +implementation specific or to which ECL doesn't adhere. For instance, +precision of floating point numbers, available character sets, actual +input/output protocols, etc. + +Section covers also @emph{C Reference} as a description of @ansi{} from +the C/C++ programmer perspective and @emph{ANSI Dictionary} for @clisp{} +constructs available from C/C++. + +@subsection Extensions +[@ref{Extensions}] introduces all features which are specific to ECL and +which lay outside the standard. This includes configuring, building and +installing ECL multiprocessing capabilities, graphics libraries, +interfacing with the operating system, etc. diff --git a/src/doc/new-doc/introduction/history.txi b/src/doc/new-doc/introduction/history.txi index 7846f5536..23045e818 100644 --- a/src/doc/new-doc/introduction/history.txi +++ b/src/doc/new-doc/introduction/history.txi @@ -49,7 +49,7 @@ with agreement of Prof. Attardi, took over the original ECL implementation and it became what it is nowadays, a community project. In 2013 once again project got unmaintained. In 2015 Daniel Kochmański -took position of maintainer with consent of Juanjo García-Ripoll. +took the position of a maintainer with consent of Juanjo García-Ripoll. The ECL project owes a lot to different people who have contributed in many different aspects, from pointing out bugs and incompatibilities of diff --git a/src/doc/new-doc/introduction/index.txi b/src/doc/new-doc/introduction/index.txi index 2c6fd4b9f..f80bc5c80 100644 --- a/src/doc/new-doc/introduction/index.txi +++ b/src/doc/new-doc/introduction/index.txi @@ -2,6 +2,7 @@ @unnumbered Introduction @menu +* About this book:: * What is ECL:: * History:: * Credits:: @@ -9,6 +10,7 @@ * Sandbox:: @end menu +@include introduction/about_man.txi @include introduction/about_ecl.txi @include introduction/history.txi @include introduction/credits.txi diff --git a/src/doc/new-doc/macros.txi b/src/doc/new-doc/macros.txi index 9e4dd6f8b..b0694a010 100644 --- a/src/doc/new-doc/macros.txi +++ b/src/doc/new-doc/macros.txi @@ -84,7 +84,7 @@ @r{ANSI Common-Lisp} @end macro @macro ecl -@b{@r{Embeddable Common-Lisp}} +@b{@r{Embeddable Common Lisp}} @end macro @macro clisp @r{Common-Lisp} diff --git a/src/doc/new-doc/new-doc.txi b/src/doc/new-doc/new-doc.txi index 0d8ae4fba..5feee92c6 100644 --- a/src/doc/new-doc/new-doc.txi +++ b/src/doc/new-doc/new-doc.txi @@ -9,6 +9,7 @@ @defcodeindex cf @defcodeindex ft @defindex ex +@documentencoding UTF-8 @c %**end of header @c Entries for @command{install-info} to use diff --git a/src/doc/new-doc/standards/evaluation.txi b/src/doc/new-doc/standards/evaluation.txi index 1af22824a..6f6117ecb 100644 --- a/src/doc/new-doc/standards/evaluation.txi +++ b/src/doc/new-doc/standards/evaluation.txi @@ -114,8 +114,7 @@ instance, if you compile with a low value of @code{SAFETY}, and invoke @end multitable @end float -@node C Reference (Evaluation and compilation) -@subsection C Reference (Evaluation and compilation) +@subsection C Reference @cppindex ecl_process_env @deftypefn {@cind{}} cl_object cl_env_ptr () @@ -126,7 +125,6 @@ variety of tasks, such as defining special variable bindings, controlling interrupts, retrieving function output values, etc. @end deftypefn -@node ANSI Dictionary (Evaluation and compilation) @subsection ANSI Dictionary @multitable @columnfractions 0.4 0.6 diff --git a/src/doc/new-doc/standards/overview.txi b/src/doc/new-doc/standards/overview.txi index d9766239e..e5ef890ab 100644 --- a/src/doc/new-doc/standards/overview.txi +++ b/src/doc/new-doc/standards/overview.txi @@ -56,7 +56,7 @@ concepts are explained in a different (@ref{Embedding ECL}) part of the book. @node C Reference (Overview) -@subsection C Reference (Overview) +@subsection C Reference @subsubsection One type for everything: @code{cl_object} @cindex One type for everything: @code{cl_object} diff --git a/src/doc/new-doc/user-guide/break-loop.txi b/src/doc/new-doc/user-guide/break-loop.txi new file mode 100644 index 000000000..b455a16cb --- /dev/null +++ b/src/doc/new-doc/user-guide/break-loop.txi @@ -0,0 +1,2 @@ +@node The break loop +@section The break loop diff --git a/src/doc/new-doc/user-guide/building.txi b/src/doc/new-doc/user-guide/building.txi index 58cbe0978..1bd0fedff 100644 --- a/src/doc/new-doc/user-guide/building.txi +++ b/src/doc/new-doc/user-guide/building.txi @@ -1,8 +1,8 @@ @node Building ECL @section Building ECL -Due to it's portable nature ECL works on every (at least) 32-bit -architecture which provides the proper C99 compliant compiler. +Due to its portable nature ECL works on every (at least) 32-bit +architecture which provides a proper C99 compliant compiler. Operating systems on which ECL is reported to work: Linux, Darwin (Mac OS X), Solaris, FreeBSD, NetBSD, OpenBSD, DragonFly BSD, Windows and @@ -15,14 +15,6 @@ however each release is tested by volunteers with an excellent package @uref{https://common-lisp.net/project/cl-test-grid,cl-test-grid} created and maintained by Anton Vodonosov. -@menu -@c * Supported platforms:: -* Autoconf based configuration:: -@c * Cross-compiling ECL:: -* Platform specific instructions:: -@end menu - -@node Autoconf based configuration @subsection Autoconf based configuration ECL, like many other FOSS programs, can be built and installed with a @@ -73,16 +65,7 @@ Top level in: #. @end example @end enumerate -@node Platform specific instructions @subsection Platform specific instructions - -@menu -* MSVC based configuration:: -@c * BSD systems:: -@c * Android:: -@end menu - -@node MSVC based configuration @subsubsection MSVC based configuration If you have a commercial version of Microsoft Visual Studio, the steps diff --git a/src/doc/new-doc/user-guide/index.txi b/src/doc/new-doc/user-guide/index.txi index 185a6ca18..f128fdc2e 100644 --- a/src/doc/new-doc/user-guide/index.txi +++ b/src/doc/new-doc/user-guide/index.txi @@ -8,7 +8,7 @@ @c * The tracer:: @c * The stepper:: @c * Errors:: -@c * The break loop:: +* The break loop:: @c * Describe and inspect:: @c * The profiler:: @c * Online help:: @@ -19,4 +19,5 @@ @include user-guide/building.txi @include user-guide/invoking.txi +@include user-guide/break-loop.txi @include user-guide/embedding.txi diff --git a/src/doc/new-doc/user-guide/invoking.txi b/src/doc/new-doc/user-guide/invoking.txi index b37f812bc..33e9ea72c 100644 --- a/src/doc/new-doc/user-guide/invoking.txi +++ b/src/doc/new-doc/user-guide/invoking.txi @@ -58,7 +58,7 @@ SI> To exit from @ecl{}, call the function @code{quit}. @example ->(quit) +> (quit) % @end example @@ -66,7 +66,8 @@ Alternatively, you may type @myctrl{D} , i.e. press the key @key{D} while pressing down the control key (@key{Ctrl}). @example ->@myctrl{D} +> @myctrl{D} + % @end example @@ -77,23 +78,23 @@ If more than one value is returned by the evaluation of the top-level form, the values will be printed successively. If no value is returned, then nothing will be printed. @example ->(values 1 2) +> (values 1 2) 1 2 ->(values) +> (values) > @end example When an error is signalled, control will enter the break loop. @example ->(defun foo (x) (bar x)) +> (defun foo (x) (bar x)) foo ->(defun bar (y) (bee y y)) +> (defun bar (y) (bee y y)) bar ->(foo 'lish) +> (foo 'lish) Condition of type: UNDEFINED-FUNCTION The function BAR is undefined. @@ -105,8 +106,6 @@ Broken at FOO. In: #. >> @end example -To pick the first restart user has too type - @c @vskip 1em `@code{>>}' in the last line is the prompt of the break loop. Like in @@ -126,20 +125,18 @@ If more restarts are present, user may invoke them with by typing @code{:rN}, where @key{N} is the restart number. For instance to pick the restart number two, type @code{:r2}. -@c @vskip 1em +See [@ref{The break loop}] for the details of the break loop. -See Section 5.4 for the details of the break loop. - -The terminal interrupt (usually caused by typing @myctrl{C} +The terminal interrupt (usually caused by typing @myctrl{C} (Control-@code{C})) is a kind of error. It breaks the running program and calls the break level loop. Example: @example ->(defun foo () (do () (nil))) +> (defun foo () (do () (nil))) foo ->(foo) +> (foo) @myctrl{C} Condition of type: INTERACTIVE-INTERRUPT From bb57174de05eccceb11fe293d0a7505077724a0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Jun 2016 17:00:02 +0200 Subject: [PATCH 04/92] new-doc: use css, add info --- src/doc/new-doc/Makefile | 2 +- src/doc/new-doc/ecl.css | 55 ++++++++++++++++++++++++ src/doc/new-doc/standards/evaluation.txi | 7 --- src/doc/new-doc/standards/overview.txi | 19 +++----- 4 files changed, 62 insertions(+), 21 deletions(-) create mode 100644 src/doc/new-doc/ecl.css diff --git a/src/doc/new-doc/Makefile b/src/doc/new-doc/Makefile index cca572148..45883ed20 100644 --- a/src/doc/new-doc/Makefile +++ b/src/doc/new-doc/Makefile @@ -15,7 +15,7 @@ ecldoc.info: $(FILES) makeinfo new-doc.txi new-doc.html: $(FILES) - makeinfo --html --no-split new-doc.txi + makeinfo --html --css-include=ecl.css --no-split new-doc.txi clean: rm -rf *.{aux,cf,cfs,cp,cpp,cpps,cps,ex,exs,fn,fns,ft,fts,log,lsp,lsps,toc,tp,tps,vr,vrs,pdf,info,html} diff --git a/src/doc/new-doc/ecl.css b/src/doc/new-doc/ecl.css new file mode 100644 index 000000000..e489d70fa --- /dev/null +++ b/src/doc/new-doc/ecl.css @@ -0,0 +1,55 @@ +html { background: #FFF; } +body { + margin: 1em 125px 0 10%; + line-height: 1.5em; + padding: 0 2em 1em 2em; + background: #FFF; + font: 12px Verdana,Arial, sans-serif +} +ul, dd, dl, dt { margin-top: 0; margin-bottom: 0; } +p, code, td, dl, dt { + line-height: 1.5em; +} +table { + font: inherit; +} +th, td { + vertical-align: top; +} +h1, h2, h3, h4, h5 { background: #EEE; } +code, pre { + font-size: 1em; + font-family: fixed; +} +pre { + line-height: 1em; + overflow: auto; +} +pre.screen { + font-weight: bold; + background: #EEE; + border: 1px solid black; + padding: 0.5em; +} +pre.programlisting { + background: #EEEEEE; + border-left: 1px solid black; + border-top: 1px solid black; + padding: 0.5em; +} +a { color: #000; font-weight: bold; } +div p { padding: 0 2em } +li p { padding: 0; margin: 0 } +hr { display: none; } +div.funcsynopsis p { + text-indent: -2em; +} +div.variablelist { + padding: 0 2em; +} +.type, .funcsynopsis, .symbol { + font-family: fixed; +} +.type, .symbol, .replaceable { + white-space: nowrap; +} diff --git a/src/doc/new-doc/standards/evaluation.txi b/src/doc/new-doc/standards/evaluation.txi index 6f6117ecb..f8e632112 100644 --- a/src/doc/new-doc/standards/evaluation.txi +++ b/src/doc/new-doc/standards/evaluation.txi @@ -1,13 +1,6 @@ @node Evaluation and compilation @section Evaluation and compilation -@menu -* Compiler declaration @code{OPTIMIZE}:: -* C Reference (Evaluation and compilation):: -* ANSI Dictionary (Evaluation and compilation):: -@end menu - -@node Compiler declaration @code{OPTIMIZE} @subsection Compiler declaration @code{OPTIMIZE} @cindex Compiler declarations @lspindex optimize diff --git a/src/doc/new-doc/standards/overview.txi b/src/doc/new-doc/standards/overview.txi index e5ef890ab..06dde8605 100644 --- a/src/doc/new-doc/standards/overview.txi +++ b/src/doc/new-doc/standards/overview.txi @@ -1,15 +1,9 @@ @node Overview @section Overview -@menu -* Reading this manual:: -* C Reference (Overview):: -@end menu - -@node Reading this manual @subsection Reading this manual -@subsubsection Common Lisp users +@subsubheading Common Lisp users @ecl{} supports all Common-Lisp data types exactly as defined in the @bibcite{ANSI}. All functions and macros are expected to behave as described in that document and in the HyperSpec @bibcite{HyperSpec} @@ -35,7 +29,7 @@ the manual copies the structure of the @ansi{} standard, having the same number of chapters, each one with a set of sections documenting the implementation-specific details. -@subsubsection C/C++ programmers +@subsubheading C/C++ programmers The second goal of this document is to provide a reference for C programmers that want to create, manipulate and operate with Common Lisp programs at a lower level, or simply embedding @ecl{} as a library. @@ -45,7 +39,7 @@ form of one section with the name "C Reference" for each chapter of the @ansi{} standard. Much of what is presented in those sections is redundant with the Common Lisp specification. In particular, there is a one-to-one mapping between types and functions which should be obvious -given the rules explained in C Reference (@ref{C Reference (Overview)}]). +given the rules explained in the next section @emph{C Reference}. We must remark that the reference in this part of the manual is not enough to know how to embed @ecl{} in a program. In practice the user or @@ -55,9 +49,8 @@ Interface}), manage memory (@ref{Memory Management}), etc. These concepts are explained in a different (@ref{Embedding ECL}) part of the book. -@node C Reference (Overview) @subsection C Reference -@subsubsection One type for everything: @code{cl_object} +@subsubheading One type for everything: @code{cl_object} @cindex One type for everything: @code{cl_object} ECL is designed around the basic principle that Common Lisp already @@ -106,7 +99,7 @@ collector. For memory allocation details @xref{Memory Management}. For object implementation details @xref{Manipulating Lisp objects}. -@subsubsection Naming conventions +@subsubheading Naming conventions As explained in the introduction, each of the chapters in the Common Lisp standard can also be implemented using C functions and types. The mapping between both languages is done using a small set of rules @@ -150,7 +143,7 @@ Most (if not all) Common Lisp functions and constructs available from C/C++ are available in ``ANSI Dictionary'' sections which are part of the [@ref{Standards}] entries. -@subsubsection Only in Common Lisp +@subsubheading Only in Common Lisp @cindex Only in Common Lisp Some parts of the language are not available as C functions, even though From b037f37d30f373f34906836bb9b358a8ba999f09 Mon Sep 17 00:00:00 2001 From: MatthewRock Date: Sat, 18 Jun 2016 18:39:26 +0200 Subject: [PATCH 05/92] Another minor fixes in MAN. --- src/doc/ecl.man.in | 73 +++++++++++++++++++++------------------------- 1 file changed, 34 insertions(+), 39 deletions(-) diff --git a/src/doc/ecl.man.in b/src/doc/ecl.man.in index aae10c533..3ba8206af 100644 --- a/src/doc/ecl.man.in +++ b/src/doc/ecl.man.in @@ -27,7 +27,9 @@ ecl \- Embeddable Common Lisp .SH DESCRIPTION .sp -ECL (Embeddable Common-Lisp) is an interpreter of the Common-Lisp language as described in the X3J13 Ansi specification, featuring CLOS (Common-Lisp Object System), conditions, loops, etc, plus a translator to C, which can produce standalone executables. +ECL (Embeddable Common-Lisp) is an interpreter of the Common-Lisp language as described in the X3J13 Ansi specification, +featuring CLOS (Common-Lisp Object System), conditions, loops, +etc. plus a translator to C, which can produce standalone executables. ECL supports the operating systems Linux, FreeBSD, NetBSD, OpenBSD, OS X, Solaris and Windows, running on top of the Intel, Sparc, Alpha, PowerPC and ARM processors. .PP @@ -45,8 +47,7 @@ Extremely portable .IP \(bu A reasonable license .PP -\fBecl\fP without any argument gives you the -interactive lisp. +\fBecl\fP without any argument starts the interactive lisp session. .SH OPTIONS .TP 1i @@ -70,7 +71,7 @@ Run without debugging setup phase, meaning that errors prevent ECL from starting .BI \-eval " file" Evaluate the .I file -before loading the .rc file and starting the Top Level +before loading the .rc file and starting the Top Level. .TP .BI \-shell " file" Executes the given @@ -84,7 +85,7 @@ automatically invoked. .BI \-load " file" Load source .I file -before starting ECL. +before loading the .rc file and starting the Top Level. .TP .BI \-dir " directory" Use @@ -175,63 +176,57 @@ or standalone executable programs. .SH AUTHORS -The original version was developed by Giuseppe Attardi starting from the Kyoto Common Lisp implementation by Taiichi Yuasa, Masami Hagiya and Juan Jose Garcia Ripoll. The current maintainer of ECL is Daniel Kochmański, who can be reached at the ECL mailing list. +The original version was developed by Giuseppe Attardi starting from the Kyoto Common Lisp implementation +by Taiichi Yuasa, Masami Hagiya and Juan Jose Garcia Ripoll. +The current maintainer of ECL is Daniel Kochmański, who can be reached at the ECL mailing list. .SH FILES .TP .BR "~/.ecl, ~/.eclrc" Default initialization files loaded at startup unless the option .BR \-norc -is provided. +is provided (if they exist). + .SH SEE ALSO -.IP "" -ANSI Common Lisp standard X3.226-1994 -.IP "" -The Common Lisp HyperSpec +.IP ANSI Common Lisp standard X3.226-1994 +.IP The Common Lisp HyperSpec + .SH "BUGS" -Unfortunately it is possible that there are some bugs in the program. In case you find any bug, -please report it as an issue (after making sure that it hasn't been reported or fixed) +Unfortunately it is possible that there are some bugs in the program. +In case you find any bug, please report it as an issue (after making sure that it hasn't been reported or fixed) to official gitlab repository: https://gitlab.com/embeddable-common-lisp/ecl/issues . + .SH "LICENSE" - ECL is free software; you can redistribute it and/or modify it - under the terms of the GNU Library General Public License as published - by the Free Software Foundation; either version 2 of the License, or - (at your option) any later version; see file 'Copying'. +ECL is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version; see file 'Copying'. +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. See the GNU Library General Public License for more details. - 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. See the - GNU Library General Public License for more details. +You should have received a copy of the GNU Library General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - You should have received a copy of the GNU Library General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +.B PLEASE NOTE THAT: - PLEASE NOTE THAT: - - This license covers all of the ECL program except for the files +This license covers all of the ECL program except for the files: .br - src/lsp/loop.lsp ; Symbolic's LOOP macro +src/lsp/loop.lsp ; Symbolic's LOOP macro .br - src/lsp/pprint.lsp ; CMUCL's pretty printer +src/lsp/pprint.lsp ; CMUCL's pretty printer .br - src/lsp/format.lsp ; CMUCL's format +src/lsp/format.lsp ; CMUCL's format .br - and the directories +and the directories: - contrib/ ; User contributed extensions +contrib/ ; User contributed extensions .br - examples/ ; Examples for the ECL usage +examples/ ; Examples for the ECL usage .br - src/clx/ ; portable CLX library from Telent +src/clx/ ; portable CLX library from Telent .br - Look the precise copyright of these extensions in the corresponding - files. +Look the precise copyright of these extensions in the corresponding files. - Examples are licensed under: (SPDX-License-Identifier) BSD-2-Clause +Examples are licensed under: (SPDX-License-Identifier) BSD-2-Clause - Report bugs, comments, suggestions to the ecl mailing list: - ecl-devel@common-lisp.net (or use gitlab). +Report bugs, comments, suggestions to the ecl mailing list: +.B ecl-devel@common-lisp.net +(or use gitlab). From 77dec0b96bfb518a2ed702ab9a7318753cab8e62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Jun 2016 21:14:04 +0200 Subject: [PATCH 06/92] new-doc: iteration --- src/doc/new-doc/Makefile | 2 +- src/doc/new-doc/developer-guide/objects.txi | 41 ++---- src/doc/new-doc/developer-guide/removed.txi | 14 +- src/doc/new-doc/extensions/ffi.txi | 6 +- src/doc/new-doc/introduction/index.txi | 24 +-- .../standards/data_and_control_flow.txi | 137 ++++++++++++++++++ src/doc/new-doc/standards/index.txi | 3 +- .../new-doc/standards/types_and_classes.txi | 45 +++++- 8 files changed, 205 insertions(+), 67 deletions(-) create mode 100644 src/doc/new-doc/standards/data_and_control_flow.txi diff --git a/src/doc/new-doc/Makefile b/src/doc/new-doc/Makefile index 45883ed20..1aae99aab 100644 --- a/src/doc/new-doc/Makefile +++ b/src/doc/new-doc/Makefile @@ -15,7 +15,7 @@ ecldoc.info: $(FILES) makeinfo new-doc.txi new-doc.html: $(FILES) - makeinfo --html --css-include=ecl.css --no-split new-doc.txi + makeinfo --html --css-include=ecl.css --split=chapter new-doc.txi clean: rm -rf *.{aux,cf,cfs,cp,cpp,cpps,cps,ex,exs,fn,fns,ft,fts,log,lsp,lsps,toc,tp,tps,vr,vrs,pdf,info,html} diff --git a/src/doc/new-doc/developer-guide/objects.txi b/src/doc/new-doc/developer-guide/objects.txi index aa2de36ff..ef8980c54 100644 --- a/src/doc/new-doc/developer-guide/objects.txi +++ b/src/doc/new-doc/developer-guide/objects.txi @@ -2,15 +2,8 @@ @section Manipulating Lisp objects @menu -* Integers (dev):: -* Characters (dev):: -* Arrays (dev):: -* Strings (dev):: -* Bit-vectors (dev):: -* Streams (dev):: -* Structures (dev):: -* Instances (dev):: -* Bytecodes (dev):: +* Objects representation:: +* Constructing objects:: @end menu If you want to extend, fix or simply customize ECL for your own needs, @@ -22,6 +15,7 @@ you should understand how the implementation works. Union containing all first-class ECL types. @end deftp +@node Objects representation @subsection Objects representation In ECL a lisp object is represented by a type called @code{cl_object}. This type is a word which is long enough to host both @@ -250,7 +244,7 @@ calls to @code{ecl_t_of}. Tells whether @var{x} is an immediate datatype. @end deftypefun - +@node Constructing objects @subsection Constructing objects On each of the following sections we will document the standard @@ -290,8 +284,7 @@ cl_object array2 = string_to_object(string); @end example @end deftypefun -@node Integers (dev) -@subsection Integers +@subheading Integers Common-Lisp distinguishes two types of integer types: @code{bignum}s and @code{fixnum}s. A fixnum is a small integer, which ideally occupies only a word of memory and which is between the values @@ -372,8 +365,7 @@ appropriate size. Signals an error if @var{o} is not of fixnum type. @code{fixnint} additionally ensure that @var{o} is not negative. @end deftypefun -@node Characters (dev) -@subsection Characters +@subheading Characters @cfindex --enable-unicode (YES|no|32) @@ -450,8 +442,7 @@ of case and @code{char_compare} converts all characters to uppercase before comparing them. @end deftypefun -@node Arrays (dev) -@subsection Arrays +@subheading Arrays An array is an aggregate of data of a common type, which can be accessed with one or more non-negative indices. ECL stores arrays as a C structure @@ -594,8 +585,7 @@ cl_print(1, array); /* Outputs #(1 2 3 5) */ @end example @end deftypefun -@node Strings (dev) -@subsection Strings +@subheading Strings A string, both in Common-Lisp and in ECL is nothing but a vector of characters. Therefore, almost everything mentioned in the section of @@ -632,16 +622,14 @@ Verifies if an objects is an extended or base string. If Unicode isn't supported, then @code{ECL_EXTENDED_STRING_P} always returns 0. @end deftypefun -@node Bit-vectors (dev) -@subsection Bit-vectors +@subheading Bit-vectors Bit-vector operations are implemented in file @code{src/c/array.d}. Bit-vector shares the structure with a vector, therefore, almost everything mentioned in the section of arrays remains valid here. -@node Streams (dev) -@subsection Streams +@subheading Streams Streams implementation is a broad topic. Most of the implementation is done in the file @code{src/c/file.d}. Stream handling may have different @@ -712,8 +700,7 @@ Predicate determining if @code{o} is a first-class stream object of type @code{m}. @end deftypefun -@node Structures (dev) -@subsection Structures +@subheading Structures Structures and instances share the same datatype @code{t_instance} ( with a few exceptions. Structure implementation details are the file @@ -732,8 +719,7 @@ with a few exceptions. Structure implementation details are the file Convenience functions for the structures. @end deftypefun -@node Instances (dev) -@subsection Instances +@subheading Instances @cppindex ECL_CLASS_OF @cppindex ECL_SPEC_FLAG @@ -757,8 +743,7 @@ Convenience functions for the structures. Convenience functions for the structures. @end deftypefun -@node Bytecodes (dev) -@subsection Bytecodes +@subheading Bytecodes A bytecodes object is a lisp object with a piece of code that can be interpreted. The objects of type t_bytecode are implicitly constructed diff --git a/src/doc/new-doc/developer-guide/removed.txi b/src/doc/new-doc/developer-guide/removed.txi index 160907df2..6955b2804 100644 --- a/src/doc/new-doc/developer-guide/removed.txi +++ b/src/doc/new-doc/developer-guide/removed.txi @@ -11,7 +11,7 @@ @c @end menu @c @node In-house DFFI -@subsection In-house DFFI +@subheading In-house DFFI Commit @code{10bd3b613fd389da7640902c2b88a6e36088c920}. Native DFFI was replaced by a @code{libffi} long time ago, but we have maintained the @@ -19,7 +19,7 @@ code as a fallback. Due to small number of supported platforms and no real use it has been removed in 2016. @c @node In-house GC -@subsection In-house GC +@subheading In-house GC Commit @code{61500316b7ea17d0e42f5ca127f2f9fa3e6596a8}. Broken GC is replaced by BoehmGC library. This may be added back as a fallback in the near future. @@ -28,30 +28,30 @@ the near future. (apparently gbc.d wasn't bdwgc glue). @c @node Green threads -@subsection Green threads +@subheading Green threads Commit @code{41923d5927f31f4dd702f546b9caee74e98a2080}. Green threads (aka light weight processes) has been replaced with native threads implementation. There is an ongoing effort to bring them back as an alternative interface. @c @node Compiler newcmp -@subsection Compiler newcmp +@subheading Compiler newcmp Commit @code{9b8258388487df8243e2ced9c784e569c0b34c4f} This was abandoned effort of changing the compiler architecture. Some clever ideas and a compiler package hierarchy. Some of these things should be incorporated during the evolution of the primary compiler. -@subsection Old MIT loop +@subheading Old MIT loop Commit @code{5042589043a7be853b7f85fd7a996747412de6b4}. This old loop implementation has got superseeded by the one incorporated from Symbolics LOOP in 2001. -@subsection Support for bignum arithmetic (earith.d) +@subheading Support for bignum arithmetic (earith.d) Commit @code{edfc2ba785d6a64667e89c869ef0a872d7b9704b}. Removes pre-gmp bignum code. Name comes probably from ``extended arithmetic'', contains multiplication and division routines (assembler and a portable implementation). -@subsection Unification module +@subheading Unification module Commit @code{6ff5d20417a21a76846c4b28e532aac097f03109}. Old unifiction module (logic programming) from EcoLisp times. diff --git a/src/doc/new-doc/extensions/ffi.txi b/src/doc/new-doc/extensions/ffi.txi index 78052b23a..e8d59409b 100644 --- a/src/doc/new-doc/extensions/ffi.txi +++ b/src/doc/new-doc/extensions/ffi.txi @@ -195,7 +195,7 @@ UFFI and the CFFI library. @c XXX: we should describe here, how to use SFFI for interactive C/C++ development @c @node Lower level interfaces -@subsubsection UFFI example +@subsubheading UFFI example @exindex UFFI usage The example below shows how to use UFFI in an application. There are several important @@ -235,7 +235,7 @@ Build and load this module with (compile-file "uffi.lsp" :load t) (sin 1.0d0) (c-sin 1.0d0) (- (sin 1.0d0) (c-sin 1.0d0))) @end lisp -@subsubsection CFFI example +@subsubheading CFFI example @exindex CFFI usage The CFFI library is an independent project and it is not shipped with @@ -275,7 +275,7 @@ Build and load this module with (compile-file "cffi.lsp" :load t) (cos 1.0d0) c-cos (- (cos 1.0d0) c-cos))) @end lisp -@subsubsection SFFI example (low level inlining) +@subsubheading SFFI example (low level inlining) @exindex SFFI usage To compare with the previous pieces of code, we show how the previous programs would be diff --git a/src/doc/new-doc/introduction/index.txi b/src/doc/new-doc/introduction/index.txi index f80bc5c80..d277fdba0 100644 --- a/src/doc/new-doc/introduction/index.txi +++ b/src/doc/new-doc/introduction/index.txi @@ -2,12 +2,11 @@ @unnumbered Introduction @menu -* About this book:: -* What is ECL:: -* History:: -* Credits:: -* Copyrights:: -* Sandbox:: +* About this book:: Information about the manual +* What is ECL:: Information about the implementation +* History:: ECL from the history perspective +* Credits:: Non-exhaustive list of contributors +* Copyrights:: Copyright of the manual and implementation @end menu @include introduction/about_man.txi @@ -15,16 +14,3 @@ @include introduction/history.txi @include introduction/credits.txi @include introduction/copyrights.txi - -@node Sandbox -@section Sandbox - -@defun funkcja arg1 arg2 arg3 -This is my defun -@end defun - -@lspindex *ignore-eof-on-terminal-io* -@defvr {System} {*ignore-eof-on-terminal-io*} -This variable controls whether an end of file character (normally -@myctrl{D}) should terminate the session. The default value is @nil{}. -@end defvr diff --git a/src/doc/new-doc/standards/data_and_control_flow.txi b/src/doc/new-doc/standards/data_and_control_flow.txi new file mode 100644 index 000000000..53d926377 --- /dev/null +++ b/src/doc/new-doc/standards/data_and_control_flow.txi @@ -0,0 +1,137 @@ +@node Data and control flow +@section Data and control flow + +@node Shadowed bindings +@cindex Shadowed bindings in LET, FLET, LABELS and lambda-list +@subsection Shadowed bindings +ANSI doesn't specify what should happen if any of the @code{LET}, +@code{FLET} and @code{LABELS} special operators contain many bindings +sharing the same name. Because the behavior varies between the +implementations and the programmer can't rely on the spec ECL signals an +error if such situation occur. + +Moreover, while ANSI defines lambda list parameters in the terms of +@code{LET*}, when used in function context programmer can't provide an +initialization forms for required parameters. If required parameters +share the same name the error is signalled. + +Described behavior is present in ECL since version 16.0.0. Previously +the @code{LET} operator were using first binding. Both @code{FLET} and +@code{LABELS} were signalling an error if C compiler was used and used +the last binding as a visible one when the byte compiler was used. + +@node Minimal compilation +@cindex Bytecodes eager compilation +@lspindex si::make-lambda +@subsection Minimal compilation +Former versions of ECL, as well as many other lisps, used linked lists +to represent code. Executing code thus meant traversing these lists and +performing code transformations, such as macro expansion, every time +that a statement was to be executed. The result was a slow and memory +hungry interpreter. + +Beginning with version 0.3, ECL was shipped with a bytecodes compiler +and interpreter which circumvent the limitations of linked lists. When +you enter code at the lisp prompt, or when you load a source file, ECL +begins a process known as minimal compilation. Barely this process +consists on parsing each form, macroexpanding it and translating it into +an intermediate language made of bytecodes. + +The bytecodes compiler is implemented in src/c/compiler.d. The main +entry point is the lisp function si::make-lambda, which takes a name for +the function and the body of the lambda lists, and produces a lisp +object that can be invoked. For instance, + +@exindex @code{si::make-lambda} usage (bytecodes compilation) +@lisp +> (defvar fun (si::make-lambda 'f '((x) (1+ x)))) +*FUN* +> (funcall fun 2) +3 +@end lisp + +ECL can only execute bytecodes. When a list is passed to EVAL it must be +first compiled to bytecodes and, if the process succeeds, the resulting +bytecodes are passed to the interpreter. Similarly, every time a +function object is created, such as in DEFUN or DEFMACRO, the compiler +processes the lambda form to produce a suitable bytecodes object. + +@cindex Eager compilation implications + +The fact that ECL performs this eager compilation means that changes on +a macro are not immediately seen in code which was already +compiled. This has subtle implications. Take the following code: + +@exindex Eager compilation impact on macros +@lisp +> (defmacro f (a b) `(+ ,a ,b)) +F +> (defun g (x y) (f x y)) +G +> (g 1 2) +3 +> (defmacro f (a b) `(- ,a ,b)) +F +> (g 1 2) +3 +@end lisp + +The last statement always outputs 3 while in former implementations +based on simple list traversal it would produce -1. + +@node Function types +@subsection Function types + +Functions in ECL can be of two types: they are either compiled to +bytecodes or they have been compiled to machine code using a lisp to C +translator and a C compiler. To the first category belong function +loaded from lisp source files or entered at the toplevel. To the second +category belong all functions in the ECL core environment and functions +in files processed by compile or compile-file. + +The output of (symbol-function fun) is one of the following: +@itemize +@item a function object denoting the definition of the function fun, +@item a list of the form (macro . function-object) when fun denotes a macro, +@item or simply 'special, when fun denotes a special form, such as block, if, etc. +@end itemize + +@cindex @code{disassemble} and @code{compile} on defined functions +@exindex Keeping lambda definitions with @code{si:*keep-definitions} + +ECL usually drops the source code of a function unless the global +variable si:*keep-definitions* was true when the function was translated +into bytecodes. Therefore, if you wish to use compile and disassemble on +defined functions, you should issue @code{(setq si:*keep-definitions* +t)} at the beginning of your session. + +@lspindex si:*keep-definitions* +@defvr {SI} {*keep-definitions*} +If set to @code{T} ECL will preserve the compiled function source code +for disassembly and recompilation. +@end defvr + +@cindex Common Lisp functions limits +@lspindex call-arguments-limit +@lspindex lambda-parameters-limit +@lspindex multiple-values-limit +@lspindex lambda-list-keywords + +In @ref{tab:fun-const} we list all Common Lisp values related to the limits of functions. +@float Table,tab:fun-const +@caption{Function related constants} +@multitable @columnfractions 0.3 0.7 +@item call-arguments-limit +@tab 65536 + +@item lambda-parameters-limit +@tab @code{call-arguments-limit} + +@item multiple-values-limit +@tab 64 + +@item lambda-list-keywords +@tab @code{(&optional &rest &key &allow-other-keys &aux &whole &environment &body)} +@end multitable +@end float + diff --git a/src/doc/new-doc/standards/index.txi b/src/doc/new-doc/standards/index.txi index 7f9175da0..26d6cfe6b 100644 --- a/src/doc/new-doc/standards/index.txi +++ b/src/doc/new-doc/standards/index.txi @@ -38,9 +38,8 @@ @include standards/evaluation.txi @include standards/types_and_classes.txi +@include standards/data_and_control_flow.txi -@node Data and control flow -@section Data and control flow @node Iteration @section Iteration @node Objects diff --git a/src/doc/new-doc/standards/types_and_classes.txi b/src/doc/new-doc/standards/types_and_classes.txi index d5ac8ca22..fd5071736 100644 --- a/src/doc/new-doc/standards/types_and_classes.txi +++ b/src/doc/new-doc/standards/types_and_classes.txi @@ -3,11 +3,42 @@ ECL defines the following additional built-in classes in the @code{CL} package: -@code{single-float}, @code{double-float} +@itemize +@item @code{single-float} +@item @code{double-float} +@end itemize -@c @code{ext:ansi-stream}, @code{ext:sequence-stream}, -@c @code{si::code-block}, @code{si::foreign-data}, @code{si::frame}, -@c @code{si::weak-pointer}, @code{mp::process}, @code{mp::lock}, -@c @code{mp::rwlock}, @code{mp::condition-variable}, -@c @code{mp::semaphore}, @code{mp::barrier}, @code{mp::mailbox}, -@c @code{ext::sse-pack}. +@subsection C Reference + +@subsection ANSI Dictionary +@multitable @columnfractions 0.3 0.7 +@headitem Lisp symbol +@tab C/C++ function + +@lspindex coerce +@cppindex cl_coerce +@ansidict{@clhs{f_coerce.htm,coerce}, +@code{cl_object cl_coerce (cl_object object, cl_object result-type)}} + +@lspindex subtypep +@cppindex cl_subtypep +@ansidict{@clhs{f_subtpp.htm,subtypep}, +@code{cl_object cl_subtypep (cl_narg narg, cl_object type1, cl_object type2, ...)}} + +@lspindex type-of +@cppindex cl_type-of +@ansidict{@clhs{f_tp_of.htm,type-of}, +@code{cl_object cl_type-of (cl_object object)}} + +@lspindex typep +@cppindex cl_typep +@ansidict{@clhs{f_typep.htm,typep}, +@code{cl_object cl_typep (cl_narg narg, cl_object object, cl_object type_specifier, ...)}} + +@lspindex type-error-datum +@ansidict{@clhs{f_tp_err.htm,type-error-datum}, @ocl{}} + +@lspindex type-error-expected-type +@ansidict{@clhs{f_tp_err.htm,type-error-expected-type}, @ocl{}} + +@end multitable From f00fa4159b0d45a6cc8ffe83037c3d31bf9e0f2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Jun 2016 14:27:27 +0200 Subject: [PATCH 07/92] man: remove unnecessary info --- src/doc/ecl.man.in | 26 +------------------------- 1 file changed, 1 insertion(+), 25 deletions(-) diff --git a/src/doc/ecl.man.in b/src/doc/ecl.man.in index 3ba8206af..47f8d6a7b 100644 --- a/src/doc/ecl.man.in +++ b/src/doc/ecl.man.in @@ -203,30 +203,6 @@ This program is distributed in the hope that it will be useful, but WITHOUT ANY You should have received a copy of the GNU Library General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -.B PLEASE NOTE THAT: - -This license covers all of the ECL program except for the files: -.br -src/lsp/loop.lsp ; Symbolic's LOOP macro -.br -src/lsp/pprint.lsp ; CMUCL's pretty printer -.br -src/lsp/format.lsp ; CMUCL's format -.br - -and the directories: - - -contrib/ ; User contributed extensions -.br -examples/ ; Examples for the ECL usage -.br -src/clx/ ; portable CLX library from Telent -.br -Look the precise copyright of these extensions in the corresponding files. - -Examples are licensed under: (SPDX-License-Identifier) BSD-2-Clause - -Report bugs, comments, suggestions to the ecl mailing list: +Please report bugs, comments, suggestions to the ecl mailing list: .B ecl-devel@common-lisp.net (or use gitlab). From f1857e0ed52428bfbc4c128acb33bc27a3743f4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Jun 2016 15:20:34 +0200 Subject: [PATCH 08/92] cmp: defcallback: accept ':default' calling convention Fixes #244. --- src/cmp/cmpcbk.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index c4e3d2042..41a428c94 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -96,7 +96,7 @@ return-type))) (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) (fmod (case call-type - (:cdecl "") + ((:cdecl :default) "") (:stdcall "__stdcall ") (t (cmperr "DEFCALLBACK does not support ~A as calling convention" call-type))))) From f54b0d9c78c58ff7232ea93d865748dcb1eeff25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Jun 2016 16:57:44 +0200 Subject: [PATCH 09/92] trace: print to *trace-output* Fixes #236. --- src/lsp/trace.lsp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/lsp/trace.lsp b/src/lsp/trace.lsp index 1b330ffea..09bfaf709 100644 --- a/src/lsp/trace.lsp +++ b/src/lsp/trace.lsp @@ -181,7 +181,8 @@ all functions." (format *trace-output* "~0,4@T\\\\ ~{ ~S~}~%" extras)) - *trace-output*)))) + *trace-output*) + *trace-output*))) (defun trace-record (fname) (declare (si::c-local)) From f66dd64e6f60e90ee7c5b1d81b7940012a8cdc72 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Jun 2016 17:20:41 +0200 Subject: [PATCH 10/92] tests: add regression test for *trace-output* --- src/tests/regressions/tests/mixed.lsp | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/tests/regressions/tests/mixed.lsp b/src/tests/regressions/tests/mixed.lsp index 7213f2099..209c3b7fb 100644 --- a/src/tests/regressions/tests/mixed.lsp +++ b/src/tests/regressions/tests/mixed.lsp @@ -123,3 +123,24 @@ (restart-case (signal 'x :y 1))) nil)) + + +;;; Date: 2016-04-21 (Juraj) +;;; Fixed: 2016-06-21 (Daniel Kochmański) +;;; Description: +;;; +;;; Trace did not respect *TRACE-OUTPUT*. +;;; +;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/236 +;;; +(ext:with-clean-symbols (fact) + (deftest mixed.0010.*trace-output* + (progn + (defun fact (n) (if (zerop n) :boom (fact (1- n)))) + (zerop (length + (with-output-to-string (*trace-output*) + (trace fact) + (fact 3) + (untrace fact) + *trace-output*)))) + nil)) From 1636b6110faf230a22b657598d3adec81a4211f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 3 Jul 2016 17:05:36 +0200 Subject: [PATCH 11/92] print-object: add default t-specialized printer Fixes #193. --- src/clos/print.lsp | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/clos/print.lsp b/src/clos/print.lsp index fb64afe07..3ea73e293 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -169,12 +169,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) From 6db5c3b6721063b7f02d31d777cf05b2fc914222 Mon Sep 17 00:00:00 2001 From: Diogo Franco Date: Wed, 6 Jul 2016 11:17:24 +0100 Subject: [PATCH 12/92] fix minor typo in pprint error message --- src/lsp/pprint.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lsp/pprint.lsp b/src/lsp/pprint.lsp index f4c302892..858942972 100644 --- a/src/lsp/pprint.lsp +++ b/src/lsp/pprint.lsp @@ -1169,7 +1169,7 @@ #.+ecl-safe-declarations+) (when (pprint-dispatch-table-read-only-p table) (cerror "Ignore and continue" - "Tried to modified a read-only pprint dispatch table: ~A" + "Tried to modify a read-only pprint dispatch table: ~A" table)) ;; FIXME! This check should be automatically generated when compiling ;; with high enough safety mode. From 60a864ce3bd92d630ac6fdbd022ceabd1f3e4f0b Mon Sep 17 00:00:00 2001 From: Diogo Franco Date: Wed, 20 Jul 2016 11:38:43 +0100 Subject: [PATCH 13/92] delete broken list case in profile module. warn and ignore invalid names. --- contrib/profile/profile.lisp | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/contrib/profile/profile.lisp b/contrib/profile/profile.lisp index 4c9df807e..153f52b0d 100644 --- a/contrib/profile/profile.lisp +++ b/contrib/profile/profile.lisp @@ -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 to PROFILE: ~S" name)))) (values)) ;;; Profile the named function, which should exist and not be profiled From 54a614bf3446e0385abc7829be41ec34de769192 Mon Sep 17 00:00:00 2001 From: Diogo Franco Date: Wed, 20 Jul 2016 11:54:06 +0100 Subject: [PATCH 14/92] do not warn about the PROFILE function, because this is also used in UNPROFILE --- contrib/profile/profile.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/contrib/profile/profile.lisp b/contrib/profile/profile.lisp index 153f52b0d..23d98054f 100644 --- a/contrib/profile/profile.lisp +++ b/contrib/profile/profile.lisp @@ -256,7 +256,7 @@ extern ECL_API size_t GC_get_total_bytes(); (let ((setf-name `(setf ,symbol))) (when (fboundp setf-name) (funcall function setf-name))))))) - (t (warn "ignoring invalid argument to PROFILE: ~S" name)))) + (t (warn "ignoring invalid argument: ~S" name)))) (values)) ;;; Profile the named function, which should exist and not be profiled From 8fed1fa97d9bf48c87f4a3610bd073ebf133936f Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Thu, 21 Jul 2016 04:45:28 -0400 Subject: [PATCH 15/92] Fixed VS2010/2015 build. - Fix #213 - Commit 10bd3b61 removed dffi code. Reflect that on nmake build. --- msvc/c/Makefile | 4 +--- msvc/ecl/config.h.msvc6 | 6 ++++-- src/c/compiler.d | 2 +- src/c/num_rand.d | 7 ++++--- src/h/ecl.h | 2 +- 5 files changed, 11 insertions(+), 10 deletions(-) diff --git a/msvc/c/Makefile b/msvc/c/Makefile index 656f2f210..28143bb5e 100755 --- a/msvc/c/Makefile +++ b/msvc/c/Makefile @@ -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 diff --git a/msvc/ecl/config.h.msvc6 b/msvc/ecl/config.h.msvc6 index 28b774747..cef0825ec 100755 --- a/msvc/ecl/config.h.msvc6 +++ b/msvc/ecl/config.h.msvc6 @@ -417,14 +417,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 +447,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 diff --git a/src/c/compiler.d b/src/c/compiler.d index 256da6547..9e26b6f00 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -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 diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 92bb45885..cefb267d2 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -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> 62)) + j); @@ -281,6 +281,9 @@ 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; @@ -294,8 +297,6 @@ ecl_make_random_state(cl_object rs) 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)); } diff --git a/src/h/ecl.h b/src/h/ecl.h index 6d3ce7800..cc7140e16 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -28,7 +28,7 @@ #include /* setjmp and buffers */ #include /* FILE */ /* Microsoft VC++ does not have va_copy() */ -#if defined(_MSC_VER) || !defined(va_copy) +#if ( defined(_MSC_VER) && (_MSC_VER < 1900) ) || !defined(va_copy) #define va_copy(dst, src) \ ((void) memcpy(&(dst), &(src), sizeof(va_list))) #endif From 000af1996d84a1f8ca7330f0623149d27e322fdf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 25 Jul 2016 16:33:30 +0200 Subject: [PATCH 16/92] cosmetic: make Makefile behaviour more intelligible Also fix ctags obsolete flag (-o -> -f) and correct some small things in ecl.man.in. Closes #263. --- src/Makefile.in | 9 +++++---- src/doc/ecl.man.in | 12 +++++++----- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Makefile.in b/src/Makefile.in index 6e60a5869..f6249a940 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -266,11 +266,12 @@ selfbuild: ./ecl compile -for i in lsp clos cmp clx tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done | less -# 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 + ( 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. TAGS: -if test "x$(ETAGS)" != "x"; then \ srcfiles=`find $(srcdir)/c $(srcdir)/h -name '*.[chd]'` && \ diff --git a/src/doc/ecl.man.in b/src/doc/ecl.man.in index 47f8d6a7b..a2c257c8e 100644 --- a/src/doc/ecl.man.in +++ b/src/doc/ecl.man.in @@ -62,8 +62,8 @@ Do not load configuration files at startup. Prints the current version of ECL, without running the ECL. .TP .BI \-debug -Turned on by default, this enables the debugging in the setup phase, so that you can debug your -\.rc files. +Turned on by default, this enables the debugging in the setup phase, +so that you can debug your files. .TP .BI \-nodebug Run without debugging setup phase, meaning that errors prevent ECL from starting up. @@ -176,9 +176,11 @@ or standalone executable programs. .SH AUTHORS -The original version was developed by Giuseppe Attardi starting from the Kyoto Common Lisp implementation -by Taiichi Yuasa, Masami Hagiya and Juan Jose Garcia Ripoll. -The current maintainer of ECL is Daniel Kochmański, who can be reached at the ECL mailing list. +The original version was developed by Giuseppe Attardi starting from +the Kyoto Common Lisp implementation by Taiichi Yuasa, Masami +Hagiya. Further development was lead by Juan Jose Garcia Ripoll. The +current maintainer of ECL is Daniel Kochmański, who can be reached at +the ECL mailing list. .SH FILES .TP From 8723d5f89572269efc3dc74ba16d2d55787b991d Mon Sep 17 00:00:00 2001 From: Diogo Franco Date: Tue, 26 Jul 2016 23:52:11 +0100 Subject: [PATCH 17/92] implement new inline stable sort for vectors, fixing avoiding the previous coercion to list and actually do it inline --- src/lsp/seqlib.lsp | 93 +++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 88 insertions(+), 5 deletions(-) diff --git a/src/lsp/seqlib.lsp b/src/lsp/seqlib.lsp index e817fbfe9..f82a8c9d5 100644 --- a/src/lsp/seqlib.lsp +++ b/src/lsp/seqlib.lsp @@ -1,6 +1,5 @@ ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*- ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - ;;;; ;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. ;;;; Copyright (c) 1990, Giuseppe Attardi. @@ -871,6 +870,93 @@ evaluates to NIL. See STABLE-SORT." seq)) +(defun stable-sort-merge-vectors (source target start-1 + end-1 end-2 pred key) + (let ((i start-1) + (j end-1) ; start-2 + (target-i start-1)) + (declare (fixnum i j target-i)) + (loop + (cond ((= i end-1) + (loop (if (= j end-2) (return)) + (setf (aref target target-i) + (aref source j)) + (incf target-i) + (incf j)) + (return)) + ((= j end-2) + (loop (if (= i end-1) (return)) + (setf (aref target target-i) + (aref source i)) + (incf target-i) + (incf i)) + (return)) + ((if key + (funcall pred (funcall key (aref source j)) + (funcall key (aref source i))) + (funcall pred (aref source j) (aref source i))) + (setf (aref target target-i) + (aref source j)) + (incf j)) + (t (setf (aref target target-i) + (aref source i)) + (incf i))) + (incf target-i)))) + + +(defun vector-merge-sort (vector pred key) + (let* ((vector-len (length (the vector vector))) + (n 1) ; bottom-up size of contiguous runs to be merged + (direction t) ; t vector --> temp nil temp --> vector + (temp (make-array vector-len)) + (unsorted 0) ; unsorted..vector-len are the elements that need + ; to be merged for a given n + (start-1 0)) ; one n-len subsequence to be merged with the next + (declare (fixnum vector-len n unsorted start-1)) + (loop + ;; for each n we start taking n-runs from the start of the vector + (setf unsorted 0) + (loop + (setf start-1 unsorted) + (let ((end-1 (+ start-1 n))) + (declare (fixnum end-1)) + (cond ((< end-1 vector-len) + ;; there are enough elements for a second run + (let ((end-2 (+ end-1 n))) + (declare (fixnum end-2)) + (if (> end-2 vector-len) (setf end-2 vector-len)) + (setf unsorted end-2) + (if direction + (stable-sort-merge-vectors + vector temp start-1 end-1 end-2 pred key) + (stable-sort-merge-vectors + temp vector start-1 end-1 end-2 pred key)) + (if (= unsorted vector-len) (return)))) + ;; if there is only one run copy those elements to the end + (t (if direction + (do ((i start-1 (1+ i))) + ((= i vector-len)) + (declare (fixnum i)) + (setf (aref temp i) (aref vector i))) + (do ((i start-1 (1+ i))) + ((= i vector-len)) + (declare (fixnum i)) + (setf (aref vector i) (aref temp i)))) + (return))))) + ;; If the inner loop only executed once then there were only enough + ;; elements for two subsequences given n so all the elements have + ;; been merged into one list. Start-1 will have remained 0 upon exit. + (when (zerop start-1) + (when direction + ;; if we just merged into the temporary copy it all back + ;; to the given vector. + (dotimes (i vector-len) + (setf (aref vector i) (aref temp i)))) + (return vector)) + (setf n (ash n 1)) ; (* 2 n) + (setf direction (not direction))))) + + (defun stable-sort (sequence predicate &key key) "Args: (sequence test &key key) Destructively sorts SEQUENCE and returns the result. TEST should return non- @@ -886,10 +972,7 @@ SEQUENCE. See SORT." (list-merge-sort sequence predicate key) (if (bit-vector-p sequence) (sort sequence predicate :key key) - (coerce (list-merge-sort (coerce sequence 'list) - predicate - key) - (seqtype sequence))))) + (vector-merge-sort sequence predicate key)))) (defun merge (result-type sequence1 sequence2 predicate &key key From 2062b8fce313044428eefd076f295b95acf2efc2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 28 Jul 2016 18:21:20 +0200 Subject: [PATCH 18/92] cosmetic: add c-local declarations --- src/lsp/seqlib.lsp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/lsp/seqlib.lsp b/src/lsp/seqlib.lsp index f82a8c9d5..73a4ff0b6 100644 --- a/src/lsp/seqlib.lsp +++ b/src/lsp/seqlib.lsp @@ -872,6 +872,7 @@ evaluates to NIL. See STABLE-SORT." (defun stable-sort-merge-vectors (source target start-1 end-1 end-2 pred key) + (declare (si::c-local)) (let ((i start-1) (j end-1) ; start-2 (target-i start-1)) @@ -905,6 +906,7 @@ evaluates to NIL. See STABLE-SORT." (defun vector-merge-sort (vector pred key) + (declare (si::c-local)) (let* ((vector-len (length (the vector vector))) (n 1) ; bottom-up size of contiguous runs to be merged (direction t) ; t vector --> temp nil temp --> vector From e010740f06eb9716e73930c08a16bf2f08d3cbda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 28 Jul 2016 18:30:33 +0200 Subject: [PATCH 19/92] changelog: update --- CHANGELOG | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGELOG b/CHANGELOG index d707549e0..355d5d7e3 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -57,6 +57,9 @@ appropraite documentation section (new-doc). Function was obfuscated with ifdefs with non-even pairs of =#\{= and =#\}=. ** Issues fixed +- 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. From 691e77c3bea053a3eba302809d14fb2caefdeed9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 28 Jul 2016 18:34:26 +0200 Subject: [PATCH 20/92] cmp/c++: fix inlined function calls We have 3 more regressions with CXX in comparison to pure C mode. Related to #241. --- src/cmp/cmpcbk.lsp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 41a428c94..5d031da75 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -43,7 +43,7 @@ (si::put-sysprop ',name :callback (list (ffi:c-inline () () :object - ,(format nil "ecl_make_foreign_data(@':pointer-void,0,~a)" c-name) + ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) :one-liner t))))) ))) @@ -126,7 +126,7 @@ (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" n "," ct "));") (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" - n "," ct "," (ffi:size-of-foreign-type type) "));"))) + n "," ct ", (void*)" (ffi:size-of-foreign-type type) "));"))) (wt-nl "aux = ecl_apply_from_stack_frame(frame," "ecl_fdefinition(" c-name-constant "));") (wt-nl "ecl_stack_frame_close(frame);") From 86a591461c80bbbaa46617ecdf05ba1890b3bf8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 4 Aug 2016 10:32:18 +0200 Subject: [PATCH 21/92] make-random-state: allow fixnum as the argument --- CHANGELOG | 6 +++--- src/c/num_rand.d | 21 ++++++++++++++------- src/c/read.d | 4 ---- 3 files changed, 17 insertions(+), 14 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 355d5d7e3..d0a80933f 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -32,15 +32,15 @@ - 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) is now possible only with the #$ reader macro. ** Enhancements - 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. diff --git a/src/c/num_rand.d b/src/c/num_rand.d index cefb267d2..44958b658 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -287,18 +287,25 @@ ecl_make_random_state(cl_object rs) 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; } - 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; + 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*'))) diff --git a/src/c/read.d b/src/c/read.d index ad1e5e013..c5f5388f1 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1399,10 +1399,6 @@ sharp_dollar_reader(cl_object in, cl_object c, cl_object d) 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; From af65969c0b013ab16f24fee6ee1500274a9bcc47 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 4 Aug 2016 14:51:43 +0200 Subject: [PATCH 22/92] file-stream-fd: don't cause internal error If the argument isn't a file-stream rise a SIMPLE-TYPE-ERROR condition. Fixes #271. --- CHANGELOG | 4 ++++ src/c/file.d | 7 ++++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index d0a80933f..63fd88a38 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -57,6 +57,10 @@ appropraite documentation section (new-doc). Function was obfuscated with ifdefs with non-even pairs of =#\{= and =#\}=. ** Issues fixed +- 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. diff --git a/src/c/file.d b/src/c/file.d index 7e9fd652e..fca767c34 100755 --- a/src/c/file.d +++ b/src/c/file.d @@ -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); } /********************************************************************** From 2733aa379c701028c6f0ade921ae8114e6ce5759 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 5 Aug 2016 15:59:11 +0200 Subject: [PATCH 23/92] old-doc: fix Makefile --- .gitignore | 2 +- doc/Makefile | 64 ++++++++ doc/tmp/COPYING.GFDL.xml | 332 --------------------------------------- 3 files changed, 65 insertions(+), 333 deletions(-) create mode 100644 doc/Makefile delete mode 100644 doc/tmp/COPYING.GFDL.xml diff --git a/.gitignore b/.gitignore index 754943f07..366e31e87 100644 --- a/.gitignore +++ b/.gitignore @@ -39,7 +39,7 @@ msvc/lsp/*.[ch] BUILD-STAMP MODULES -Makefile +/Makefile src/autom4te.cache src/config.log diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 000000000..65a067a72 --- /dev/null +++ b/doc/Makefile @@ -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,—,,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 ' $@ + 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 diff --git a/doc/tmp/COPYING.GFDL.xml b/doc/tmp/COPYING.GFDL.xml deleted file mode 100644 index f35d0509b..000000000 --- a/doc/tmp/COPYING.GFDL.xml +++ /dev/null @@ -1,332 +0,0 @@ - From be3b6ba9eab0ccadbffe8710342770874968f1bd Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Tue, 9 Aug 2016 04:23:58 +0200 Subject: [PATCH 24/92] fix build when msvc support bool type on c99 and stdbool.h --- src/c/dpp.c | 7 +++++++ src/c/file.d | 4 ++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/src/c/dpp.c b/src/c/dpp.c index 3b4d9b1df..169c9da73 100755 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -74,6 +74,10 @@ #include #include +#if defined(_MSC_VER) && (_MSC_VER >= 1800) +#include +#endif + #define DPP #include #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; diff --git a/src/c/file.d b/src/c/file.d index fca767c34..e00830fee 100755 --- a/src/c/file.d +++ b/src/c/file.d @@ -4593,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); @@ -4665,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); From cd9f75a5812e095090361d86fe3378648d13a0b9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 7 Aug 2016 15:48:31 +0200 Subject: [PATCH 25/92] tests: reorganize ecl-tests (use 2am) --- src/tests/2am.lisp | 211 +++ src/tests/ecl-tests.asd | 31 + src/tests/ecl-tests.lisp | 129 ++ .../eformat-tests/hebrew_latin8_cr.txt | 0 .../eformat-tests/hebrew_latin8_crlf.txt | 0 .../eformat-tests/hebrew_latin8_lf.txt | 0 .../eformat-tests/hebrew_utf8_cr.txt | 0 .../eformat-tests/hebrew_utf8_crlf.txt | 0 .../eformat-tests/hebrew_utf8_lf.txt | 0 .../eformat-tests/kafka_cp1252_cr.txt | 0 .../eformat-tests/kafka_cp1252_crlf.txt | 0 .../eformat-tests/kafka_cp1252_lf.txt | 0 .../eformat-tests/kafka_latin1_cr.txt | 0 .../eformat-tests/kafka_latin1_crlf.txt | 0 .../eformat-tests/kafka_latin1_lf.txt | 0 .../eformat-tests/kafka_utf8_cr.txt | 0 .../eformat-tests/kafka_utf8_crlf.txt | 0 .../eformat-tests/kafka_utf8_lf.txt | 0 .../eformat-tests/russian_koi8r_cr.txt | 0 .../eformat-tests/russian_koi8r_crlf.txt | 0 .../eformat-tests/russian_koi8r_lf.txt | 0 .../eformat-tests/russian_utf8_cr.txt | 0 .../eformat-tests/russian_utf8_crlf.txt | 0 .../eformat-tests/russian_utf8_lf.txt | 0 .../eformat-tests/tilton_ascii_cr.txt | 0 .../eformat-tests/tilton_ascii_crlf.txt | 0 .../eformat-tests/tilton_ascii_lf.txt | 0 .../eformat-tests/tilton_utf8_cr.txt | 0 .../eformat-tests/tilton_utf8_crlf.txt | 0 .../eformat-tests/tilton_utf8_lf.txt | 0 .../eformat-tests/unicode_demo_ucs2_cr_be.txt | Bin .../eformat-tests/unicode_demo_ucs2_cr_le.txt | Bin .../unicode_demo_ucs2_crlf_be.txt | Bin .../unicode_demo_ucs2_crlf_le.txt | Bin .../eformat-tests/unicode_demo_ucs2_lf_be.txt | Bin .../eformat-tests/unicode_demo_ucs2_lf_le.txt | Bin .../eformat-tests/unicode_demo_ucs4_cr_be.txt | Bin .../eformat-tests/unicode_demo_ucs4_cr_le.txt | Bin .../unicode_demo_ucs4_crlf_be.txt | Bin .../unicode_demo_ucs4_crlf_le.txt | Bin .../eformat-tests/unicode_demo_ucs4_lf_be.txt | Bin .../eformat-tests/unicode_demo_ucs4_lf_le.txt | Bin .../eformat-tests/unicode_demo_utf8_cr.txt | 0 .../eformat-tests/unicode_demo_utf8_crlf.txt | 0 .../eformat-tests/unicode_demo_utf8_lf.txt | 0 src/tests/features/external-formats.lsp | 339 +++++ src/tests/regressions/.#compiler.lsp | 1 + src/tests/regressions/ansi-aux.lsp | 1189 ----------------- src/tests/regressions/ansi.lsp | 75 ++ src/tests/regressions/compiler.lsp | 1152 ++++++++++++++++ src/tests/regressions/doit.lsp | 58 - .../regressions/{tests => }/embedding.lsp | 25 +- .../{tests => }/external-formats.lsp | 77 +- src/tests/regressions/foreign-interface.lsp | 114 ++ src/tests/regressions/metaobject-protocol.lsp | 620 +++++++++ src/tests/regressions/mixed.lsp | 178 +++ .../{tests => }/multiprocessing.lsp | 382 +++--- src/tests/regressions/tests/compiler.lsp | 1183 ---------------- .../regressions/tests/foreign-interface.lsp | 119 -- .../regressions/tests/metaobject-protocol.lsp | 638 --------- src/tests/regressions/tests/mixed.lsp | 146 -- src/tests/regressions/tests/random-states.lsp | 55 - src/tests/regressions/tests/test-ansi.lsp | 126 -- src/tests/regressions/tools.lsp | 43 - .../stress/{tests => }/multiprocessing.lsp | 0 .../universe.lsp => universe.lisp} | 0 66 files changed, 3087 insertions(+), 3804 deletions(-) create mode 100644 src/tests/2am.lisp create mode 100644 src/tests/ecl-tests.asd create mode 100644 src/tests/ecl-tests.lisp rename src/tests/{regressions => features}/eformat-tests/hebrew_latin8_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/hebrew_latin8_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/hebrew_latin8_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/hebrew_utf8_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/hebrew_utf8_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/hebrew_utf8_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_cp1252_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_cp1252_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_cp1252_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_latin1_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_latin1_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_latin1_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_utf8_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_utf8_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/kafka_utf8_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/russian_koi8r_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/russian_koi8r_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/russian_koi8r_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/russian_utf8_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/russian_utf8_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/russian_utf8_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/tilton_ascii_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/tilton_ascii_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/tilton_ascii_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/tilton_utf8_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/tilton_utf8_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/tilton_utf8_lf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs2_cr_be.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs2_cr_le.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs2_crlf_be.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs2_crlf_le.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs2_lf_be.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs2_lf_le.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs4_cr_be.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs4_cr_le.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs4_crlf_be.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs4_crlf_le.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs4_lf_be.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_ucs4_lf_le.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_utf8_cr.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_utf8_crlf.txt (100%) rename src/tests/{regressions => features}/eformat-tests/unicode_demo_utf8_lf.txt (100%) create mode 100644 src/tests/features/external-formats.lsp create mode 120000 src/tests/regressions/.#compiler.lsp delete mode 100644 src/tests/regressions/ansi-aux.lsp create mode 100644 src/tests/regressions/ansi.lsp create mode 100644 src/tests/regressions/compiler.lsp delete mode 100644 src/tests/regressions/doit.lsp rename src/tests/regressions/{tests => }/embedding.lsp (87%) rename src/tests/regressions/{tests => }/external-formats.lsp (86%) create mode 100644 src/tests/regressions/foreign-interface.lsp create mode 100644 src/tests/regressions/metaobject-protocol.lsp create mode 100644 src/tests/regressions/mixed.lsp rename src/tests/regressions/{tests => }/multiprocessing.lsp (62%) delete mode 100644 src/tests/regressions/tests/compiler.lsp delete mode 100644 src/tests/regressions/tests/foreign-interface.lsp delete mode 100644 src/tests/regressions/tests/metaobject-protocol.lsp delete mode 100644 src/tests/regressions/tests/mixed.lsp delete mode 100644 src/tests/regressions/tests/random-states.lsp delete mode 100644 src/tests/regressions/tests/test-ansi.lsp delete mode 100644 src/tests/regressions/tools.lsp rename src/tests/stress/{tests => }/multiprocessing.lsp (100%) rename src/tests/{regressions/universe.lsp => universe.lisp} (100%) diff --git a/src/tests/2am.lisp b/src/tests/2am.lisp new file mode 100644 index 000000000..7ed7db8f8 --- /dev/null +++ b/src/tests/2am.lisp @@ -0,0 +1,211 @@ +;;; Copyright (c) 2014 James M. Lawrence +;;; Copyright (c) 2016 Daniel Kochmański +;;; +;;; 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. + +#| to avoid conflict with the library name package 2am-ecl |# +(defpackage #:2am-ecl + (:use #:cl) + (:export #:test #:is #:signals #:finishes #:run #:suite)) + +(in-package #:2am-ecl) + +(defvar *tests* nil "A name of the default tests suite.") +(defvar *suites* (make-hash-table) "A collection of test suites.") +(defvar *hierarchy* (make-hash-table) "A hierarchy of test suites.") +(defvar *failures* nil) +(defvar *crashes* nil) +(defvar *test-name* nil) +(defvar *test-count* nil) +(defvar *pass-count* nil) +(defvar *fail-count* nil) +(defvar *running* nil) + +(define-condition test-failure (simple-condition) + ((test-name :initarg :name + :accessor test-name))) + +(defun suite (&optional (name *tests* name-p) (sub nil sub-p)) + "Sets the current suite to the `name'." + (assert (symbolp name)) + (assert (typep sub 'sequence)) + (when name-p + (setf *tests* name)) + (when sub-p + (setf (gethash *tests* *hierarchy*) sub)) + *tests*) + +(defsetf suite (name) (tests suites) + "Resets the suite to contain the provided tests and suites" + `(progn + (assert (typep ,tests 'sequence)) + (assert (typep ,suites 'sequence)) + (setf (gethash ,name *suites*) ,tests + (gethash ,name *hierarchy*) ,suites) + tests)) + +(defun %shuffle (vector) + (loop for i downfrom (- (length vector) 1) to 1 + do (rotatef (aref vector i) (aref vector (random (1+ i))))) + vector) + +(defun shuffle (sequence) + (%shuffle (map 'vector #'identity sequence))) + +(defun report (test-count pass-count fail-count crashes) + (let ((num-check (+ pass-count fail-count))) + (if *running* + (format t "~&Did ~s test~:p (~s crashed), ~s check~:p.~%" test-count crashes num-check) + (format t "~&Test ~s: ~s check~:p.~%" *test-name* num-check)) + (unless (zerop num-check) + (let ((passed% (round (* 100 (/ pass-count num-check)))) + (failed% (round (* 100 (/ fail-count num-check))))) + (format t " Pass: ~s (~2D%)~%" pass-count passed%) + (format t " Fail: ~s (~2D%)~%" fail-count failed%)))) + (unless (= fail-count crashes 0) + (format t "~%Failure details:~%") + (format t "--------------------------------~%") + (maphash (lambda (test fails) + (format t " ~A:~%" test) + (dolist (fail (reverse fails)) + (if (typep fail 'test-failure) + (format t " FAIL: ") + (format t " CRASH [~A]: " (type-of fail))) + (format t "~A~%" fail)) + (format t "~&--------------------------------~%")) + *failures*))) + +(defun %run (fn) + (let ((*test-count* 0) + (*pass-count* 0) + (*fail-count* 0) + (*failures* (make-hash-table)) + (*crashes* 0)) + (multiple-value-prog1 (funcall fn) + (report *test-count* *pass-count* *fail-count* *crashes*)))) + +(defun %run-suite (name) + (let ((visited nil) + (functions nil)) + (labels ((traverse (name) + (unless (member name visited) + (push name visited) + (push (lambda () + (format t "~&--- Running test suite ~s~%" name) + (map nil #'funcall (shuffle + (gethash name *suites*)))) + functions) + (map nil #'traverse (shuffle + (gethash name *hierarchy*)))))) + (traverse name)) + (nreverse functions))) + +(defun run (&optional (tests (gethash nil *suites*))) + "Run each test in the sequence `tests'. Default is `*tests*'." + (let ((*running* t)) + (etypecase tests + (symbol + (%run (lambda () + (map nil #'funcall (%run-suite tests))))) + (list + (%run (lambda () + (map nil #'funcall (shuffle tests))))))) + (values)) + +(defun call-test (fn) + (format t "~&Running test ~s " *test-name*) + (finish-output) + (if *running* + (handler-case + (progn (incf *test-count*) + (funcall fn)) + (serious-condition (c) + (write-char #\X) + (incf *crashes*) + (push c (gethash *test-name* *failures*)))) + (%run fn)) + (values)) + +(defmacro test (name &body body) + "Define a test function and add it to `*tests*'." + `(progn + (defun ,name () + (let ((*test-name* ',name)) + (call-test (lambda () ,@body)))) + (pushnew ',name (gethash *tests* *suites*)) + ',name)) + +(defun passed () + (write-char #\.) + (when *pass-count* + (incf *pass-count*)) + T) + +(defun failed (c) + (write-char #\f) + (when *fail-count* + (incf *fail-count*)) + (when *failures* + (push c (gethash *test-name* *failures*))) + NIL) + +(defmacro is (form &rest args + &aux + (fmt-ctrl (format nil "~s~@[~%~A~]" form (car args))) + (fmt-args (cdr args))) + "Assert that `form' evaluates to non-nil." + `(if ,form + (passed) + (failed (make-condition 'test-failure + :name *test-name* + :format-control ,fmt-ctrl + :format-arguments (list ,@fmt-args))))) + +(defun %signals (expected fn) + (flet ((handler (condition) + (cond ((typep condition expected) + (return-from %signals (passed))) + (t + (return-from %signals + (failed (make-condition 'test-failure + :name *test-name* + :format-control "Expected to signal ~s, but got ~s:~%~a" + :format-arguments (list expected (type-of condition) condition)))))))) + (handler-bind ((condition #'handler)) + (funcall fn))) + (failed (make-condition 'test-failure + :name *test-name* + :format-control "Expected to signal ~s, but got nothing" + :format-arguments `(,expected)))) + +(defmacro signals (condition &body body) + "Assert that `body' signals a condition of type `condition'." + `(%signals ',condition (lambda () ,@body))) + +(defmacro finishes (form) + `(handler-case (progn + ,form + (passed)) + (serious-condition (c) + (failed (make-condition 'test-failure + :name *test-name* + :format-control "Expected to finish, but got ~s" + :format-arguments (list (type-of c))))))) diff --git a/src/tests/ecl-tests.asd b/src/tests/ecl-tests.asd new file mode 100644 index 000000000..423fc781b --- /dev/null +++ b/src/tests/ecl-tests.asd @@ -0,0 +1,31 @@ +;;;; ecl-tests.asd + +(asdf:defsystem #:ecl-tests + :description "Various tests for ECL" + :author "Daniel Kochmański " + :license "LGPL-2.1+" + :serial t + :components ((:file "2am") + (:file "ecl-tests") + (:file "universe") + (:module regressions + :default-component-class asdf:cl-source-file.lsp + :components + ((:file "ansi") + (:file "mixed") + (:file "compiler") + (:file "embedding" :if-feature (:not :ecl-bytecmp)) + (:file "foreign-interface" :if-feature :ffi) + (:file "metaobject-protocol" :if-feature :clos) + (:file "multiprocessing" :if-feature :threads))) + (:module features + :default-component-class asdf:cl-source-file.lsp + :components + ((:file "external-formats" :if-feature :unicode))) + (:module stress + :default-component-class asdf:cl-source-file.lsp + :components ()))) + +;;; General tests +(asdf:defsystem #:ecl-tests/ansi) +(asdf:defsystem #:ecl-tests/benchmark) diff --git a/src/tests/ecl-tests.lisp b/src/tests/ecl-tests.lisp new file mode 100644 index 000000000..e49a9640f --- /dev/null +++ b/src/tests/ecl-tests.lisp @@ -0,0 +1,129 @@ +;;;; ecl-tests.lisp + +(defpackage #:cl-test + (:use #:cl #:2am-ecl)) + +(in-package #:cl-test) + + +(suite 'ecl '(regressions features)) + +;;;; Declare top-level suite +(suite 'regressions '(regressions/ansi+ + regressions/mixed + regressions/cmp + regressions/emb + regressions/ffi + regressions/mop + regressions/mp)) + +(suite 'features '(features/eformat)) + + +#+asdf +(setf *default-pathname-defaults* + #+asdf + (asdf:system-source-directory 'ecl-tests) + #-asdf + *load-pathname*) + +(ext:chdir *default-pathname-defaults*) + + +;;; Some syntactic sugar for 2am +(defmacro once-only (specs &body body) + "Once-Only ({(Var Value-Expression)}*) Form* + + Create a Let* which evaluates each Value-Expression, binding a + temporary variable to the result, and wrapping the Let* around the + result of the evaluation of Body. Within the body, each Var is + bound to the corresponding temporary variable." + (labels ((frob (specs body) + (if (null specs) + `(progn ,@body) + (let ((spec (first specs))) + (when (/= (length spec) 2) + (error "Malformed Once-Only binding spec: ~S." spec)) + (let ((name (first spec)) + (exp-temp (gensym))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym "OO-"))) + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) + (frob specs body))) + +(defmacro is-true (form) + (once-only ((result form)) + `(is (eql ,result t) "Expected T, but got ~s" ,result))) + +(defmacro is-false (form) + (once-only ((result form)) + `(is (null ,result) "Expected NIL, but got ~s" ,result))) + +(defmacro is-equal (what form) + (once-only ((what what) + (form form)) + `(is (equal ,what ,form) "EQUAL: ~s to ~s" ',form ,what ,form))) + +(defmacro is-eql (what form) + (once-only ((what what) + (form form)) + `(is (eql ,what ,form) "EQL: ~s to ~s" ,what ,form))) + +(defmacro pass (form &rest args) + (declare (ignore form args)) + `(passed)) + +(defmacro fail (form &rest args + &aux + (fmt-ctrl (or (car args) "")) + (fmt-args (cdr args))) + (declare (ignore form)) + `(failed (make-condition 'test-failure + :name *test-name* + :format-control ,fmt-ctrl + :format-arguments (list ,@fmt-args)))) + + +;;;; Author: Juan Jose Garcia-Ripoll +;;;; Created: Fri Apr 14 11:13:17 CEST 2006 +;;;; Contains: Tools for doing tests, intercepting functions, etc. + +(defmacro with-dflet (functions &body body) + "Syntax: + (with-dflet ((fname form*)*) body) +Evaluate BODY in an environment in which the function FNAME has been +redefined to evaluate the given forms _before_ executing the orginal +code." + (let ((vars '()) (in-forms '()) (out-forms '())) + (loop for (name . forms) in functions + do (let ((var (gensym))) + (push `(,var #',name) vars) + (push `(setf (fdefinition ',name) + #'(lambda (&rest args) ,@forms (apply ,var args))) + in-forms) + (push `(setf (fdefinition ',name) ,var) out-forms))) + `(let ,vars + (unwind-protect + (progn ,@in-forms ,@body) + (progn ,@out-forms))))) + +(defmacro with-compiler ((filename &rest compiler-args) &body forms) + "Create a lisp file with the given forms and compile it. The forms +are evaluated unless they are strings. Strings are simply inlined to +allow using reader macros. The output is stored in a string and output +as a second value." + `(progn + (with-open-file (s ,filename :direction :output :if-exists :supersede + :if-does-not-exist :create) + ,@(loop for f in forms collect (if (stringp f) + `(format s "~A" ,f) + `(print ,f s)))) + (let* ((compiled-file t) + (output + (with-output-to-string (*standard-output*) + (let ((*error-output* *standard-output*) + (*compile-verbose* t) + (*compile-print* t)) + (setf compiled-file (compile-file ,filename ,@compiler-args)))))) + (values compiled-file output)))) diff --git a/src/tests/regressions/eformat-tests/hebrew_latin8_cr.txt b/src/tests/features/eformat-tests/hebrew_latin8_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/hebrew_latin8_cr.txt rename to src/tests/features/eformat-tests/hebrew_latin8_cr.txt diff --git a/src/tests/regressions/eformat-tests/hebrew_latin8_crlf.txt b/src/tests/features/eformat-tests/hebrew_latin8_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/hebrew_latin8_crlf.txt rename to src/tests/features/eformat-tests/hebrew_latin8_crlf.txt diff --git a/src/tests/regressions/eformat-tests/hebrew_latin8_lf.txt b/src/tests/features/eformat-tests/hebrew_latin8_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/hebrew_latin8_lf.txt rename to src/tests/features/eformat-tests/hebrew_latin8_lf.txt diff --git a/src/tests/regressions/eformat-tests/hebrew_utf8_cr.txt b/src/tests/features/eformat-tests/hebrew_utf8_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/hebrew_utf8_cr.txt rename to src/tests/features/eformat-tests/hebrew_utf8_cr.txt diff --git a/src/tests/regressions/eformat-tests/hebrew_utf8_crlf.txt b/src/tests/features/eformat-tests/hebrew_utf8_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/hebrew_utf8_crlf.txt rename to src/tests/features/eformat-tests/hebrew_utf8_crlf.txt diff --git a/src/tests/regressions/eformat-tests/hebrew_utf8_lf.txt b/src/tests/features/eformat-tests/hebrew_utf8_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/hebrew_utf8_lf.txt rename to src/tests/features/eformat-tests/hebrew_utf8_lf.txt diff --git a/src/tests/regressions/eformat-tests/kafka_cp1252_cr.txt b/src/tests/features/eformat-tests/kafka_cp1252_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_cp1252_cr.txt rename to src/tests/features/eformat-tests/kafka_cp1252_cr.txt diff --git a/src/tests/regressions/eformat-tests/kafka_cp1252_crlf.txt b/src/tests/features/eformat-tests/kafka_cp1252_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_cp1252_crlf.txt rename to src/tests/features/eformat-tests/kafka_cp1252_crlf.txt diff --git a/src/tests/regressions/eformat-tests/kafka_cp1252_lf.txt b/src/tests/features/eformat-tests/kafka_cp1252_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_cp1252_lf.txt rename to src/tests/features/eformat-tests/kafka_cp1252_lf.txt diff --git a/src/tests/regressions/eformat-tests/kafka_latin1_cr.txt b/src/tests/features/eformat-tests/kafka_latin1_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_latin1_cr.txt rename to src/tests/features/eformat-tests/kafka_latin1_cr.txt diff --git a/src/tests/regressions/eformat-tests/kafka_latin1_crlf.txt b/src/tests/features/eformat-tests/kafka_latin1_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_latin1_crlf.txt rename to src/tests/features/eformat-tests/kafka_latin1_crlf.txt diff --git a/src/tests/regressions/eformat-tests/kafka_latin1_lf.txt b/src/tests/features/eformat-tests/kafka_latin1_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_latin1_lf.txt rename to src/tests/features/eformat-tests/kafka_latin1_lf.txt diff --git a/src/tests/regressions/eformat-tests/kafka_utf8_cr.txt b/src/tests/features/eformat-tests/kafka_utf8_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_utf8_cr.txt rename to src/tests/features/eformat-tests/kafka_utf8_cr.txt diff --git a/src/tests/regressions/eformat-tests/kafka_utf8_crlf.txt b/src/tests/features/eformat-tests/kafka_utf8_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_utf8_crlf.txt rename to src/tests/features/eformat-tests/kafka_utf8_crlf.txt diff --git a/src/tests/regressions/eformat-tests/kafka_utf8_lf.txt b/src/tests/features/eformat-tests/kafka_utf8_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/kafka_utf8_lf.txt rename to src/tests/features/eformat-tests/kafka_utf8_lf.txt diff --git a/src/tests/regressions/eformat-tests/russian_koi8r_cr.txt b/src/tests/features/eformat-tests/russian_koi8r_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/russian_koi8r_cr.txt rename to src/tests/features/eformat-tests/russian_koi8r_cr.txt diff --git a/src/tests/regressions/eformat-tests/russian_koi8r_crlf.txt b/src/tests/features/eformat-tests/russian_koi8r_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/russian_koi8r_crlf.txt rename to src/tests/features/eformat-tests/russian_koi8r_crlf.txt diff --git a/src/tests/regressions/eformat-tests/russian_koi8r_lf.txt b/src/tests/features/eformat-tests/russian_koi8r_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/russian_koi8r_lf.txt rename to src/tests/features/eformat-tests/russian_koi8r_lf.txt diff --git a/src/tests/regressions/eformat-tests/russian_utf8_cr.txt b/src/tests/features/eformat-tests/russian_utf8_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/russian_utf8_cr.txt rename to src/tests/features/eformat-tests/russian_utf8_cr.txt diff --git a/src/tests/regressions/eformat-tests/russian_utf8_crlf.txt b/src/tests/features/eformat-tests/russian_utf8_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/russian_utf8_crlf.txt rename to src/tests/features/eformat-tests/russian_utf8_crlf.txt diff --git a/src/tests/regressions/eformat-tests/russian_utf8_lf.txt b/src/tests/features/eformat-tests/russian_utf8_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/russian_utf8_lf.txt rename to src/tests/features/eformat-tests/russian_utf8_lf.txt diff --git a/src/tests/regressions/eformat-tests/tilton_ascii_cr.txt b/src/tests/features/eformat-tests/tilton_ascii_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/tilton_ascii_cr.txt rename to src/tests/features/eformat-tests/tilton_ascii_cr.txt diff --git a/src/tests/regressions/eformat-tests/tilton_ascii_crlf.txt b/src/tests/features/eformat-tests/tilton_ascii_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/tilton_ascii_crlf.txt rename to src/tests/features/eformat-tests/tilton_ascii_crlf.txt diff --git a/src/tests/regressions/eformat-tests/tilton_ascii_lf.txt b/src/tests/features/eformat-tests/tilton_ascii_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/tilton_ascii_lf.txt rename to src/tests/features/eformat-tests/tilton_ascii_lf.txt diff --git a/src/tests/regressions/eformat-tests/tilton_utf8_cr.txt b/src/tests/features/eformat-tests/tilton_utf8_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/tilton_utf8_cr.txt rename to src/tests/features/eformat-tests/tilton_utf8_cr.txt diff --git a/src/tests/regressions/eformat-tests/tilton_utf8_crlf.txt b/src/tests/features/eformat-tests/tilton_utf8_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/tilton_utf8_crlf.txt rename to src/tests/features/eformat-tests/tilton_utf8_crlf.txt diff --git a/src/tests/regressions/eformat-tests/tilton_utf8_lf.txt b/src/tests/features/eformat-tests/tilton_utf8_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/tilton_utf8_lf.txt rename to src/tests/features/eformat-tests/tilton_utf8_lf.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_be.txt b/src/tests/features/eformat-tests/unicode_demo_ucs2_cr_be.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_be.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs2_cr_be.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_le.txt b/src/tests/features/eformat-tests/unicode_demo_ucs2_cr_le.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs2_cr_le.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs2_cr_le.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_be.txt b/src/tests/features/eformat-tests/unicode_demo_ucs2_crlf_be.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_be.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs2_crlf_be.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_le.txt b/src/tests/features/eformat-tests/unicode_demo_ucs2_crlf_le.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs2_crlf_le.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs2_crlf_le.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_be.txt b/src/tests/features/eformat-tests/unicode_demo_ucs2_lf_be.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_be.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs2_lf_be.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_le.txt b/src/tests/features/eformat-tests/unicode_demo_ucs2_lf_le.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs2_lf_le.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs2_lf_le.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_be.txt b/src/tests/features/eformat-tests/unicode_demo_ucs4_cr_be.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_be.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs4_cr_be.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_le.txt b/src/tests/features/eformat-tests/unicode_demo_ucs4_cr_le.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs4_cr_le.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs4_cr_le.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_be.txt b/src/tests/features/eformat-tests/unicode_demo_ucs4_crlf_be.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_be.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs4_crlf_be.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_le.txt b/src/tests/features/eformat-tests/unicode_demo_ucs4_crlf_le.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs4_crlf_le.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs4_crlf_le.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_be.txt b/src/tests/features/eformat-tests/unicode_demo_ucs4_lf_be.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_be.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs4_lf_be.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_le.txt b/src/tests/features/eformat-tests/unicode_demo_ucs4_lf_le.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_ucs4_lf_le.txt rename to src/tests/features/eformat-tests/unicode_demo_ucs4_lf_le.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_utf8_cr.txt b/src/tests/features/eformat-tests/unicode_demo_utf8_cr.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_utf8_cr.txt rename to src/tests/features/eformat-tests/unicode_demo_utf8_cr.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_utf8_crlf.txt b/src/tests/features/eformat-tests/unicode_demo_utf8_crlf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_utf8_crlf.txt rename to src/tests/features/eformat-tests/unicode_demo_utf8_crlf.txt diff --git a/src/tests/regressions/eformat-tests/unicode_demo_utf8_lf.txt b/src/tests/features/eformat-tests/unicode_demo_utf8_lf.txt similarity index 100% rename from src/tests/regressions/eformat-tests/unicode_demo_utf8_lf.txt rename to src/tests/features/eformat-tests/unicode_demo_utf8_lf.txt diff --git a/src/tests/features/external-formats.lsp b/src/tests/features/external-formats.lsp new file mode 100644 index 000000000..25848c219 --- /dev/null +++ b/src/tests/features/external-formats.lsp @@ -0,0 +1,339 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Author: Juan Jose Garcia-Ripoll +;;;; Created: Sat Jan 03 2:56:03 CEST 2007 +;;;; Contains: External format tests +;;;; +;;;; Based on the code and files from FLEXI-STREAMS 1.0.7 +;;;; + +(in-package :cl-test) + +(suite 'features/eformat) + + +;;; eformat-001 + +(defconstant +buffer-size+ 8192 + "Size of buffers for COPY-STREAM* below.") + +(defparameter *copy-function* 'copy-stream + "Which function to use when copying from one stream to the other - +see for example COPY-FILE below.") + +(defparameter *eformat-test-files* + '(("unicode_demo" (:utf8 :ucs2 :ucs4)) + ("kafka" (:utf8 :latin1 :cp1252)) + ("hebrew" (:utf8 :latin8)) + ("russian" (:utf8 :koi8r)) + ("tilton" (:utf8 :ascii)) + ) + "A list of test files where each entry consists of the name +prefix and a list of encodings.") + +(defun create-file-variants (file-name symbol) + "For a name suffix FILE-NAME and a symbol SYMBOL denoting an +encoding returns a list of pairs where the car is a full file +name and the cdr is the corresponding external format. This list +contains all possible variants w.r.t. to line-end conversion and +endianness." + (let ((variants (ecase symbol + (:ascii '(:us-ascii)) + (:latin1 '(:latin-1)) + (:latin8 '(:iso-8859-8)) + (:cp1252 '(:windows-cp1252)) + (:koi8r '(:koi8-r)) + (:utf8 '(:utf-8)) + (:ucs2 '(:ucs-2be :ucs-2le)) + (:ucs4 '(:ucs-4be :ucs-4le))))) + (loop for arg in variants + nconc (let* ((endian-suffix (case arg + ((:ucs-2be :ucs-4be) "_be") + ((:ucs-2le :ucs-4le) "_le") + (t "")))) + (loop for eol-style in '(:lf :cr :crlf) + collect (cons (format nil "~A_~(~A~)_~(~A~)~A.txt" + file-name symbol eol-style endian-suffix) + (list eol-style arg))))))) + +(defun create-test-combinations (file-name symbols &optional simplep) + "For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting +different encodings of the corresponding file returns a list of lists +which can be used as arglists by DO-EFORMAT-TEST-001. If SIMPLEP is true, a +list which can be used for the string and sequence tests below is +returned." + (let ((file-variants (loop for symbol in symbols + nconc (create-file-variants file-name symbol)))) + (loop for (name-in . external-format-in) in file-variants + when simplep + collect (list name-in external-format-in) + else + nconc (loop for (name-out . external-format-out) in file-variants + collect (list name-in external-format-in name-out external-format-out))))) + +(defun file-equal (file1 file2) + "Returns a true value iff FILE1 and FILE2 have the same +contents \(viewed as binary files)." + (with-open-file (stream1 file1 :element-type '(unsigned-byte 8)) + (with-open-file (stream2 file2 :element-type '(unsigned-byte 8)) + (if (= (file-length stream1) (file-length stream2)) + (loop for p1 = (file-position stream1) + for byte1 = (read-byte stream1 nil nil) + for byte2 = (read-byte stream2 nil nil) + while (and byte1 byte2) + unless (= byte1 byte2) + do (return (values nil p1)) + finally (return (values t 0))) + (values nil -1))))) + +(defun copy-stream (in out) + "Copies the contents of the binary stream STREAM-IN to the +binary stream STREAM-OUT using flexi streams - STREAM-IN is read +with the external format EXTERNAL-FORMAT-IN and STREAM-OUT is +written with EXTERNAL-FORMAT-OUT." + (loop for line = (read-line in nil nil) + while line + do (write-line line out))) + +(defun copy-stream* (in out) + "Like COPY-STREAM, but uses READ-SEQUENCE and WRITE-SEQUENCE instead +of READ-LINE and WRITE-LINE." + (let ((buffer (make-array +buffer-size+ :element-type 'char*))) + (loop + (let ((position (read-sequence buffer in))) + (when (zerop position) (return)) + (write-sequence buffer out :end position))))) + +(defun do-eformat-test-001 (*copy-function*) + "Each test in this suite copies the contents of one file \(in the +`test' directory) to another file \(in a temporary directory) using +flexi streams with different external formats. The resulting file is +compared with an existing file in the `test' directory to check if the +outcome is as expected. Uses various variants of the :DIRECTION +keyword when opening the files. + +Returns a true value iff all tests succeeded. Prints information +about each individual comparison if VERBOSE is true." + (labels + ((copy-file (path-in external-format-in path-out external-format-out + direction-out direction-in) + (with-open-file (in path-in + :element-type 'character + :direction direction-in + :if-does-not-exist :error + :if-exists :overwrite + :external-format external-format-in) + (with-open-file (out path-out + :element-type 'character + :direction direction-out + :if-does-not-exist :create + :if-exists :supersede + :external-format external-format-out) + (funcall *copy-function* in out)))) + (one-comparison (path-in external-format-in path-out external-format-out) + (loop with full-path-in = (merge-pathnames path-in "features/eformat-tests/") + and full-path-out = (ensure-directories-exist + (merge-pathnames path-out "sandbox/eformat-tmp/")) + and full-path-orig = (merge-pathnames path-out "features/eformat-tests/") + for direction-out in '(:output :io) + nconc (loop for direction-in in '(:input :io) + for args = (list path-in external-format-in direction-in + path-out external-format-out direction-out) + with ok = nil + with pos = 0 + unless (progn + (copy-file full-path-in external-format-in + full-path-out external-format-out + direction-out direction-in) + (is (multiple-value-setq (ok pos) + (file-equal full-path-out full-path-orig)) + "~%~A -> ~A" path-in path-out)) + collect (progn + (format t "~%;;; Discordance at pos ~D~%between ~A~% and ~A~%" + pos full-path-out full-path-orig) + args))))) + (loop with do-eformat-test-001-args-list = + (loop for (file-name symbols) in *eformat-test-files* + nconc (create-test-combinations file-name symbols)) + for (path-in external-format-in path-out external-format-out) in do-eformat-test-001-args-list + nconc (one-comparison path-in external-format-in path-out external-format-out)))) + +;;; Date: 02/01/2007 +;;; From: Juanjo +;;; Fixed: Not a bug +;;; Description: +;;; +;;; Test external formats by transcoding several files into all possible +;;; supported formats and checking against the expected results. This +;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. +;;; +(test external-format.0001-transcode-read-char + (is-false (do-eformat-test-001 'copy-stream))) + +;;; Date: 02/01/2007 +;;; From: Juanjo +;;; Fixed: Not a bug +;;; Description: +;;; +;;; Test external formats by transcoding several files into all possible +;;; supported formats and checking against the expected results. This +;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. +;;; +(test external-format.0002-transcode-read-char + (is-false (do-eformat-test-001 'copy-stream*))) + + +;;; eformat-002 + +(load "sys:encodings;tools") + +(setf *print-circle* t) ; some mappings contain circular structures + +(defun binary-dump (filename &optional (position 0) (limit nil)) + (format t "~%FILE: ~A from ~D, ~D bytes" filename position limit) + (with-open-file (file filename :element-type '(unsigned-byte 8)) + (file-position file position) + (loop for i from 0 + for byte = (read-byte file nil nil) + for c = (and byte (code-char byte)) + while (and byte (or (null limit) (< i limit))) + do (progn (when (zerop (mod i 8)) (terpri)) + (format t "~5X ~3A" byte + (cond ((and (< 31 byte 127) (standard-char-p c)) + c) + ((eql c #\Esc) "ESC") + (t " "))) + ))) + (terpri) + (force-output)) + +(defun random-strings (char-bag n) + (if (consp char-bag) + (apply #'concatenate 'string + (loop for i from 0 below 2 + for actual-bag = (elt char-bag (random (length char-bag))) + collect (random-strings actual-bag (random n)))) + (concatenate 'string + (loop for i from 0 to n + for c = (char char-bag (random (length char-bag))) + unless (eql c #\Newline) + collect c)))) + +(defun compare-files (a b &optional all-chars) + (with-open-file (sa a :direction :input :element-type '(unsigned-byte 8)) + (with-open-file (sb b :direction :input :element-type '(unsigned-byte 8)) + (loop for b1 = (read-byte sa nil nil) + for b2 = (read-byte sb nil nil) + while (or b1 b2) + do (unless (eql b1 b2) + (let* ((position (1- (file-position sa))) + (start-dump (max 0 (- position 8)))) + (setf position (logandc2 position 3)) + (binary-dump a start-dump 32) + (binary-dump b start-dump 32) + (format t "~%Mismatch between~%~T~A~% and~T~A~% at file position ~D~%" + a b position) + (when all-chars + (loop with imin = (floor start-dump 4) + with imax = (min (+ imin 9) (length all-chars)) + for i from imin below imax + for j from 0 + for c = (char all-chars i) + do (progn (when (zerop (mod j 8)) (terpri)) + (format t "~4X " (char-code c)))) + (terpri)) + (return nil))) + finally (return t))))) + +(defun test-output (format-name &optional iconv-name (nlines 128) (nchars 10)) + (set 'ext::foo format-name) + (let* ((*print-circle* t) + (mappings (loop for table = (ext::make-encoding format-name) + while (and table (symbolp table)) + do (setf format-name table) + finally (return (or table format-name)))) + (char-bags (all-valid-unicode-chars mappings)) + (encoded-filename (format nil "sandbox/eformat-tmp/iconv-~A.txt" format-name)) + (decoded-filename (format nil "sandbox/eformat-tmp/iconv-~A-utf32.txt" format-name)) + (iconv-filename (format nil "sandbox/eformat-tmp/iconv-~A-iconv-utf32.txt" format-name)) + (random-lines (loop for line from 1 to nlines + collect (random-strings char-bags nchars))) + (all-chars (apply #'concatenate 'string + (loop for i in random-lines + nconc (list i (list #\Newline)))))) + (ensure-directories-exist encoded-filename) + ;; Output in that format + (with-open-file (out encoded-filename :direction :output :external-format format-name + :if-exists :supersede) + (loop for i in random-lines + do (write-line i out))) + (with-open-file (out decoded-filename :direction :output :external-format :ucs-4be + :if-exists :supersede) + (loop for i in random-lines + do (write-line i out))) + (with-open-file (in encoded-filename :direction :input :external-format format-name) + (loop for line = (read-line in nil nil) + for i in random-lines + for n from 1 + while line + unless (string= i line) + do (progn + (format t "Mismatch on line ~D between~% ~S and~% ~S" n line i) + (return-from test-output nil)))) + (when iconv-name + (let ((command (format nil "iconv -f ~A -t UTF-32BE ~A > ~A" + iconv-name encoded-filename iconv-filename))) + (if (zerop + (si::system command)) + (compare-files decoded-filename iconv-filename all-chars) + (prog1 T + (format t "~&;;; iconv command failed:~A~%" command))))))) + +;;; Date: 09/01/2007 +;;; From: Juanjo +;;; Fixed: Not a bug +;;; Description: +;;; +;;; Test external formats by transcoding random sequences of characters using +;;; ECL and iconv. +;;; +#-msvc +;; In Windows SYSTEM does not fail with a nonzero code when it +;; fails to execute a command. Hence in that case we assume +;; we simply can not run these tests +(when (zerop (si::system "iconv -l >/dev/null 2>&1")) + (test external-format.simple-iconv-check + (is-false + (loop for name in '(:ISO-8859-1 :ISO-8859-2 :ISO-8859-3 :ISO-8859-4 + :ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8 + :ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13 + :ISO-8859-14 :ISO-8859-15 :ISO-8859-16 + + :KOI8-R :KOI8-U + + :IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860 + :IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866 + :IBM869 + + :CP936 :CP949 :CP950 + + :WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253 + :WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257 + + ;; :CP932 :WINDOWS-1255 :WINDOWS-1258 with + ;; iconv may output combined characters, when ECL would + ;; output the base and the comibining one. Hence, no simple + ;; comparison is possible. + + :ISO-2022-JP + ;; :ISO-2022-JP-1 + ;; iconv doesn't support ISO-2022-JP-1 (hue hue hue) + ) + unless (progn + (loop for i from 1 to 10 + always (is (test-output name (symbol-name name)) + "iconv test ~s failed" name))) + collect name)))) + + diff --git a/src/tests/regressions/.#compiler.lsp b/src/tests/regressions/.#compiler.lsp new file mode 120000 index 000000000..8fb655653 --- /dev/null +++ b/src/tests/regressions/.#compiler.lsp @@ -0,0 +1 @@ +jack@pandora.670:1470121845 \ No newline at end of file diff --git a/src/tests/regressions/ansi-aux.lsp b/src/tests/regressions/ansi-aux.lsp deleted file mode 100644 index 01b641634..000000000 --- a/src/tests/regressions/ansi-aux.lsp +++ /dev/null @@ -1,1189 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 17:10:18 1998 -;;;; Contains: Aux. functions for CL-TEST - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;; A function for coercing truth values to BOOLEAN - -(defun notnot (x) (not (not x))) - -(defmacro notnot-mv (form) - `(notnot-mv-fn (multiple-value-list ,form))) - -(defun notnot-mv-fn (results) - (if (null results) - (values) - (apply #'values - (not (not (first results))) - (rest results)))) - -(defmacro not-mv (form) - `(not-mv-fn (multiple-value-list ,form))) - -(defun not-mv-fn (results) - (if (null results) - (values) - (apply #'values - (not (first results)) - (rest results)))) - -(declaim (ftype (function (t) function) to-function)) - -(defun to-function (fn) - (etypecase fn - (function fn) - (symbol (symbol-function fn)) - ((cons (eql setf) (cons symbol null)) (fdefinition fn)))) - -;;; Macro to check that a function is returning a specified number of values -;;; (defaults to 1) -(defmacro check-values (form &optional (num 1)) - (let ((v (gensym)) - (n (gensym))) - `(let ((,v (multiple-value-list ,form)) - (,n ,num)) - (check-values-length ,v ,n ',form) - (car ,v)))) - -(defun check-values-length (results expected-number form) - (declare (type fixnum expected-number)) - (let ((n expected-number)) - (declare (type fixnum n)) - (dolist (e results) - (declare (ignore e)) - (decf n)) - (unless (= n 0) - (error "Expected ~A results from ~A, got ~A results instead.~%~ -Results: ~A~%" expected-number form n results)))) - -;;; Do multiple-value-bind, but check # of arguments -(defmacro multiple-value-bind* ((&rest vars) form &body body) - (let ((len (length vars)) - (v (gensym))) - `(let ((,v (multiple-value-list ,form))) - (check-values-length ,v ,len ',form) - (destructuring-bind ,vars ,v ,@body)))) - -;;; Comparison functions that are like various builtins, -;;; but are guaranteed to return T for true. - -(defun eqt (x y) - "Like EQ, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (eq x y))))) - -(defun eqlt (x y) - "Like EQL, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) - -(defun equalt (x y) - "Like EQUAL, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) - -(defun equalpt (x y) - "Like EQUALP, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) - -(defun equalpt-or-report (x y) - "Like EQUALPT, but return either T or a list of the arguments." - (or (equalpt x y) (list x y))) - -(defun string=t (x y) - (notnot-mv (string= x y))) - -(defun =t (x &rest args) - "Like =, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= x args))))) - -(defun <=t (x &rest args) - "Like <=, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (apply #'<= x args))))) - -(defun make-int-list (n) - (loop for i from 0 below n collect i)) - -(defun make-int-array (n &optional (fn #'make-array)) - (when (symbolp fn) - (assert (fboundp fn)) - (setf fn (symbol-function (the symbol fn)))) - (let ((a (funcall (the function fn) n))) - (declare (type (array * *) a)) - (loop for i from 0 below n do (setf (aref a i) i)) - a)) - -;;; Return true if A1 and A2 are arrays with the same rank -;;; and dimensions whose elements are EQUAL - -(defun equal-array (a1 a2) - (and (typep a1 'array) - (typep a2 'array) - (= (array-rank a1) (array-rank a2)) - (if (= (array-rank a1) 0) - (equal (regression-test::my-aref a1) (regression-test::my-aref a2)) - (let ((ad (array-dimensions a1))) - (and (equal ad (array-dimensions a2)) - (locally - (declare (type (array * *) a1 a2)) - (if (= (array-rank a1) 1) - (let ((as (first ad))) - (loop - for i from 0 below as - always (equal (regression-test::my-aref a1 i) - (regression-test::my-aref a2 i)))) - (let ((as (array-total-size a1))) - (and (= as (array-total-size a2)) - (loop - for i from 0 below as - always - (equal - (regression-test::my-row-major-aref a1 i) - (regression-test::my-row-major-aref a2 i)) - )))))))))) - -;;; *universe* is defined elsewhere -- it is a list of various -;;; lisp objects used when stimulating things in various tests. -(declaim (special *universe*)) - -;;; The function EMPIRICAL-SUBTYPEP checks two types -;;; for subtypeness, first using SUBTYPEP*, then (if that -;;; fails) empirically against all the elements of *universe*, -;;; checking if all that are in the first are also in the second. -;;; Return T if this is the case, NIL otherwise. This will -;;; always return T if type1 is truly a subtype of type2, -;;; but may return T even if this is not the case. - -(defun empirical-subtypep (type1 type2) - (multiple-value-bind (sub good) - (subtypep* type1 type2) - (if good - sub - (loop for e in *universe* - always (or (not (typep e type1)) (typep e type2)))))) - -(defun check-type-predicate (P TYPE) - "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) - by applying both to all elements of *UNIVERSE*. Print message - when a mismatch is found, and return number of mistakes." - - (when (symbolp p) - (assert (fboundp p)) - (setf p (symbol-function p))) - (assert (typep p 'function)) - - (loop - for x in *universe* - when - (block failed - (let ((p1 (handler-case - (normally (funcall (the function p) x)) - (error () (format t "(FUNCALL ~S ~S) failed~%" - P x) - (return-from failed t)))) - (p2 (handler-case - (normally (typep x TYPE)) - (error () (format t "(TYPEP ~S '~S) failed~%" - x TYPE) - (return-from failed t))))) - (when (or (and p1 (not p2)) - (and (not p1) p2)) - (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" - P x p1 x TYPE p2) - t))) - collect x)) - -;;; We have a common idiom where a guarded predicate should be -;;; true everywhere - -(defun check-predicate (predicate &optional guard (universe *universe*)) - "Return all elements of UNIVERSE for which the guard (if present) is false - and for which PREDICATE is false." - (remove-if #'(lambda (e) (or (and guard (funcall guard e)) - (funcall predicate e))) - universe)) - -(declaim (special *catch-error-type*)) - -(defun catch-continue-debugger-hook (condition dbh) - "Function that when used as *debugger-hook*, causes - continuable errors to be continued without user intervention." - (declare (ignore dbh)) - (let ((r (find-restart 'continue condition))) - (cond - ((and *catch-error-type* - (not (typep condition *catch-error-type*))) - (format t "Condition ~S is not a ~A~%" condition *catch-error-type*) - (cond (r (format t "Its continue restart is ~S~%" r)) - (t (format t "It has no continue restart~%"))) - (throw 'continue-failed nil)) - (r (invoke-restart r)) - (t (throw 'continue-failed nil))))) - -#| -(defun safe (fn &rest args) - "Apply fn to args, trapping errors. Convert type-errors to the - symbol type-error." - (declare (optimize (safety 3))) - (handler-case - (apply fn args) - (type-error () 'type-error) - (error (c) c))) -|# - -;;; Use the next macro in place of SAFE - -(defmacro catch-type-error (form) -"Evaluate form in safe mode, returning its value if there is no error. -If an error does occur, return type-error on TYPE-ERRORs, or the error -condition itself on other errors." -`(locally (declare (optimize (safety 3))) - (handler-case (normally ,form) - (type-error () 'type-error) - (error (c) c)))) - -(defmacro classify-error* (form) -"Evaluate form in safe mode, returning its value if there is no error. -If an error does occur, return a symbol classify the error, or allow -the condition to go uncaught if it cannot be classified." -`(locally (declare (optimize (safety 3))) - (handler-case (normally ,form) - (undefined-function () 'undefined-function) - (program-error () 'program-error) - (package-error () 'package-error) - (type-error () 'type-error) - (control-error () 'control-error) - (parse-error () 'parse-error) - (stream-error () 'stream-error) - (reader-error () 'reader-error) - (file-error () 'file-error) - (cell-error () 'cell-error) - (division-by-zero () 'division-by-zero) - (floating-point-overflow () 'floating-point-overflow) - (floating-point-underflow () 'floating-point-underflow) - (arithmetic-error () 'arithmetic-error) - (error () 'error) - ))) - -(defun classify-error** (form) - (handler-bind ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) - (proclaim '(optimize (safety 3))) - (classify-error* - (if regression-test::*compile-tests* - (funcall (compile nil `(lambda () - (declare (optimize (safety 3))) - ,form))) - (eval form)) - ))) - -(defmacro classify-error (form) - `(classify-error** ',form)) - -;;; The above is badly designed, since it fails when some signals -;;; may be in more than one class/ - -(defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) - `(handler-bind - ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) - (proclaim '(optimize (safety 3))) - (handler-case - (apply #'values - nil - (multiple-value-list - ,(cond - (inline form) - (regression-test::*compile-tests* - `(funcall (compile nil '(lambda () - (declare (optimize (safety ,safety))) - ,form)))) - (t `(eval ',form))))) - (,error-name (c) - (cond - ,@(case error-name - (type-error - `(((typep (type-error-datum c) - (type-error-expected-type c)) - (values - nil - (list (list 'typep (list 'quote - (type-error-datum c)) - (list 'quote - (type-error-expected-type c))) - "==> true"))))) - ((undefined-function unbound-variable) - (and name-p - `(((not (eq (cell-error-name c) ',name)) - (values - nil - (list 'cell-error-name "==>" - (cell-error-name c))))))) - ((stream-error end-of-file reader-error) - `(((not (streamp (stream-error-stream c))) - (values - nil - (list 'stream-error-stream "==>" - (stream-error-stream c)))))) - (file-error - `(((not (pathnamep (pathname (file-error-pathname c)))) - (values - nil - (list 'file-error-pathname "==>" - (file-error-pathname c)))))) - (t nil)) - (t (printable-p c))))))) - -(defmacro signals-error-always (form error-name) - `(values - (signals-error ,form ,error-name) - (signals-error ,form ,error-name :safety 0))) - -(defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) - (let ((lambda-form - `(lambda (,var) - (declare (optimize (safety ,safety))) - ,form))) - `(let ((,var ,datum-form)) - (declare (optimize safety)) - (handler-bind - ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) - ; (proclaim '(optimize (safety 3))) - (handler-case - (apply #'values - nil - (multiple-value-list - (funcall - ,(cond - (inline `(function ,lambda-form)) - (regression-test::*compile-tests* - `(compile nil ',lambda-form)) - (t `(eval ',lambda-form))) - ,var))) - (type-error - (c) - (let ((datum (type-error-datum c)) - (expected-type (type-error-expected-type c))) - (cond - ((not (eql ,var datum)) - (list :datum-mismatch ,var datum)) - ((typep datum expected-type) - (list :is-typep datum expected-type)) - (t (printable-p c)))))))))) - -(declaim (special *mini-universe*)) - -(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) - "Check that for all elements in some set, either guard-fn is true or - pred-fn signals a type error." - (let (val) - (loop for e in universe - unless (or (funcall guard-fn e) - (equal - (setf val (multiple-value-list - (signals-type-error x e (funcall pred-fn x) :inline t))) - '(t))) - collect (list e val)))) - -(defmacro check-type-error (&body args) - `(locally (declare (optimize safety)) (check-type-error* ,@args))) - -(defun printable-p (obj) - "Returns T iff obj can be printed to a string." - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil)) - (declare (optimize safety)) - (handler-case (and (stringp (write-to-string obj)) t) - (condition (c) (declare (ignore c)) nil))))) - -;;; -;;; The function SUBTYPEP should return two generalized booleans. -;;; This auxiliary function returns booleans instead -;;; (which makes it easier to write tests). -;;; -(defun subtypep* (type1 type2) - (apply #'values - (mapcar #'notnot - (multiple-value-list (subtypep type1 type2))))) - -(defun subtypep*-or-fail (type1 type2) - (let ((results (multiple-value-list (subtypep type1 type2)))) - (and (= (length results) 2) - (or (not (second results)) - (notnot (first results)))))) - -(defun subtypep*-not-or-fail (type1 type2) - (let ((results (multiple-value-list (subtypep type1 type2)))) - (and (= (length results) 2) - (or (not (second results)) - (not (first results)))))) - -;; (declaim (ftype (function (&rest function) (values function &optional)) -;; compose)) - -(defun compose (&rest fns) - (let ((rfns (reverse fns))) - #'(lambda (x) (loop for f - in rfns do (setf x (funcall (the function f) x))) x))) - -(defun evendigitp (c) - (notnot (find c "02468"))) - -(defun odddigitp (c) - (notnot (find c "13579"))) - -(defun nextdigit (c) - (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) - -(defun is-eq-p (x) #'(lambda (y) (eqt x y))) -(defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y)))) - -(defun is-eql-p (x) #'(lambda (y) (eqlt x y))) -(defun is-not-eql-p (x) #'(lambda (y) (not (eqlt x y)))) - -(defun onep (x) (eql x 1)) - -(defun char-invertcase (c) - (if (upper-case-p c) (char-downcase c) - (char-upcase c))) - -(defun string-invertcase (s) - (map 'string #'char-invertcase s)) - -(defun symbol< (x &rest args) - (apply #'string< (symbol-name x) (mapcar #'symbol-name args))) - - -(defun make-list-expr (args) - "Build an expression for computing (LIST . args), but that evades - CALL-ARGUMENTS-LIMIT." - (if (cddddr args) - (list 'list* - (first args) (second args) (third args) (fourth args) - (make-list-expr (cddddr args))) - (cons 'list args))) - -(defparameter +standard-chars+ - (coerce - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ - " 'simple-base-string)) - -(defparameter - +base-chars+ #.(coerce - (concatenate 'string - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "0123456789" - "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") - 'simple-base-string)) - - -(declaim (type simple-base-string +base-chars+)) - -(defparameter +num-base-chars+ (length +base-chars+)) - -(defparameter +alpha-chars+ (subseq +standard-chars+ 0 52)) -(defparameter +lower-case-chars+ (subseq +alpha-chars+ 0 26)) -(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52)) -(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) -(defparameter +digit-chars+ "0123456789") -(defparameter +extended-digit-chars+ (coerce - "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" - 'simple-base-string)) - -(declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ - +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ - +standard-chars+)) - -(defparameter +code-chars+ - (coerce (loop for i from 0 below 256 - for c = (code-char i) - when c collect c) - 'simple-string)) - -(declaim (type simple-string +code-chars+)) - -(defparameter +rev-code-chars+ (reverse +code-chars+)) - -;;; Used in checking for continuable errors - -(defun has-non-abort-restart (c) - (throw 'handled - (if (position 'abort (the list (compute-restarts c)) - :key #'restart-name :test-not #'eq) - 'success - 'fail))) - -(defmacro handle-non-abort-restart (&body body) - `(catch 'handled - (handler-bind ((error #'has-non-abort-restart)) - ,@body))) - -;;; used in elt.lsp -(defun elt-v-6-body () - (let ((x (make-int-list 1000))) - (let ((a (make-array '(1000) :initial-contents x))) - (loop - for i from 0 to 999 do - (unless (eql i (elt a i)) (return nil)) - finally (return t))))) - -(defun make-adj-array (n &key initial-contents) - (if initial-contents - (make-array n :adjustable t :initial-contents initial-contents) - (make-array n :adjustable t))) - -;;; used in elt.lsp -(defun elt-adj-array-6-body () - (let ((x (make-int-list 1000))) - (let ((a (make-adj-array '(1000) :initial-contents x))) - (loop - for i from 0 to 999 do - (unless (eql i (elt a i)) (return nil)) - finally (return t))))) - -(defparameter *displaced* (make-int-array 100000)) - -(defun make-displaced-array (n displacement) - (make-array n :displaced-to *displaced* - - :displaced-index-offset displacement)) - -;;; used in fill.lsp -(defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args) - (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) - :initial-contents '(1 2 3 4 5))) - (b (apply #'fill a fill-args))) - (values (eqt a b) - (map 'list #'identity a)))) - -;;; used in fill-strings.lsp -(defun array-string-fill-test-fn (a &rest fill-args) - (setq a (copy-seq a)) - (let ((b (apply #'fill a fill-args))) - (values (eqt a b) b))) - -;;; From types-and-class.lsp - -(defparameter +float-types+ - '(long-float double-float short-float single-float)) - -(defparameter *subtype-table* -(let ((table - '( - (null symbol) - (symbol t) - (boolean symbol) - (standard-object t) - (function t) - (compiled-function function) - (generic-function function) - (standard-generic-function generic-function) - (class standard-object) - (built-in-class class) - (structure-class class) - (standard-class class) - (method standard-object) - (standard-method method) - (structure-object t) - (method-combination t) - (condition t) - (serious-condition condition) - (error serious-condition) - (type-error error) - (simple-type-error type-error) - (simple-condition condition) - (simple-type-error simple-condition) - (parse-error error) - (hash-table t) - (cell-error error) - (unbound-slot cell-error) - (warning condition) - (style-warning warning) - (storage-condition serious-condition) - (simple-warning warning) - (simple-warning simple-condition) - (keyword symbol) - (unbound-variable cell-error) - (control-error error) - (program-error error) - (undefined-function cell-error) - (package t) - (package-error error) - (random-state t) - (number t) - (real number) - (complex number) - (float real) - (short-float float) - (single-float float) - (double-float float) - (long-float float) - (rational real) - (integer rational) - (ratio rational) - (signed-byte integer) - (integer signed-byte) - (unsigned-byte signed-byte) - (bit unsigned-byte) - (fixnum integer) - (bignum integer) - (bit fixnum) - (arithmetic-error error) - (division-by-zero arithmetic-error) - (floating-point-invalid-operation arithmetic-error) - (floating-point-inexact arithmetic-error) - (floating-point-overflow arithmetic-error) - (floating-point-underflow arithmetic-error) - (character t) - (base-char character) - (standard-char base-char) - (extended-char character) - (sequence t) - (list sequence) - (null list) - (null boolean) - (cons list) - (array t) - (simple-array array) - (vector sequence) - (vector array) - (string vector) - (bit-vector vector) - (simple-vector vector) - (simple-vector simple-array) - (simple-bit-vector bit-vector) - (simple-bit-vector simple-array) - (base-string string) - (simple-string string) - (simple-string simple-array) - (simple-base-string base-string) - (simple-base-string simple-string) - (pathname t) - (logical-pathname pathname) - (file-error error) - (stream t) - (broadcast-stream stream) - (concatenated-stream stream) - (echo-stream stream) - (file-stream stream) - (string-stream stream) - (synonym-stream stream) - (two-way-stream stream) - (stream-error error) - (end-of-file stream-error) - (print-not-readable error) - (readtable t) - (reader-error parse-error) - (reader-error stream-error) - ))) - (when (subtypep* 'character 'base-char) - (setq table - (append - '((character base-char) - ;; (string base-string) - ;; (simple-string simple-base-string) - ) - table))) - - table)) - -(defparameter *disjoint-types-list* - '(cons symbol array - number character hash-table function readtable package - pathname stream random-state condition restart)) - -(defparameter *disjoint-types-list2* - `((cons (cons t t) (cons t (cons t t)) (eql (nil))) - (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *)) - (array vector simple-array simple-vector string simple-string - base-string simple-base-string (eql #())) - (character base-char standard-char (eql #\a) - ,@(if (subtypep 'character 'base-char) nil - (list 'extended-char))) - (function compiled-function generic-function standard-generic-function - (eql ,#'car)) - (package (eql ,(find-package "COMMON-LISP"))) - (pathname logical-pathname (eql #p"")) - (stream broadcast-stream concatenated-stream echo-stream - file-stream string-stream synonym-stream two-way-stream) - (number real complex float integer rational ratio fixnum - bit (integer 0 100) (float 0.0 100.0) (integer 0 *) - (rational 0 *) (mod 10) - (eql 0) - ,@(and (not (subtypep 'bignum nil)) - (list 'bignum))) - (random-state) - ,*condition-types* - (restart) - (readtable))) - -(defparameter *types-list3* - (reduce #'append *disjoint-types-list2* :from-end t)) - -(defun trim-list (list n) - (let ((len (length list))) - (if (<= len n) list - (append (subseq list 0 n) - (format nil "And ~A more omitted." (- len n)))))) - -(defun is-t-or-nil (e) - (or (eqt e t) (eqt e nil))) - -(defun is-builtin-class (type) - (when (symbolp type) (setq type (find-class type nil))) - (typep type 'built-in-class)) - -(defun even-size-p (a) - (some #'evenp (array-dimensions a))) - - -(defun safe-elt (x n) - (classify-error* (elt x n))) - -(defmacro defstruct* (&body args) - `(eval-when (:load-toplevel :compile-toplevel :execute) - (handler-case (eval '(defstruct ,@args)) - (serious-condition () nil)))) - -(defun safely-delete-package (package-designator) - (let ((package (find-package package-designator))) - (when package - (let ((used-by (package-used-by-list package))) - (dolist (using-package used-by) - (unuse-package package using-package))) - (delete-package package)))) - -#-(or allegro openmcl lispworks) -(defun delete-all-versions (pathspec) - "Replace the versions field of the pathname specified by pathspec with - :wild, and delete all the files this refers to." - (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec))) - (truenames (directory wild-pathname))) - (mapc #'delete-file truenames))) - -;;; This is a hack to get around an ACL bug; OpenMCL also apparently -;;; needs it -#+(or allegro openmcl lispworks) -(defun delete-all-versions (pathspec) - (when (probe-file pathspec) (delete-file pathspec))) - -(defconstant +fail-count-limit+ 20) - -(defun frob-simple-condition (c expected-fmt &rest expected-args) - "Try out the format control and format arguments of a simple-condition C, - but make no assumptions about what they print as, only that they - do print." - (declare (ignore expected-fmt expected-args)) - (and (typep c 'simple-condition) - (let ((fc (simple-condition-format-control c)) - (args (simple-condition-format-arguments c))) - (and - (stringp (apply #'format nil fc args)) - t)))) - -(defun frob-simple-error (c expected-fmt &rest expected-args) - (and (typep c 'simple-error) - (apply #'frob-simple-condition c expected-fmt expected-args))) - -(defun frob-simple-warning (c expected-fmt &rest expected-args) - (and (typep c 'simple-warning) - (apply #'frob-simple-condition c expected-fmt expected-args))) - -(defparameter *array-element-types* - '(t (integer 0 0) - bit (unsigned-byte 8) (unsigned-byte 16) - (unsigned-byte 32) float short-float - single-float double-float long-float - nil character base-char symbol boolean null)) - -(defun collect-properties (plist prop) - "Collect all the properties in plist for a property prop." - (loop for e on plist by #'cddr - when (eql (car e) prop) - collect (cadr e))) - -(defmacro def-macro-test (test-name macro-form) - (let ((macro-name (car macro-form))) - (assert (symbolp macro-name)) - `(deftest ,test-name - (values - (signals-error (funcall (macro-function ',macro-name)) - program-error) - (signals-error (funcall (macro-function ',macro-name) - ',macro-form) - program-error) - (signals-error (funcall (macro-function ',macro-name) - ',macro-form nil nil) - program-error)) - t t t))) - -(defun typep* (element type) - (not (not (typep element type)))) - -(defun applyf (fn &rest args) - (etypecase fn - (symbol - #'(lambda (&rest more-args) (apply (the symbol fn) (append args more-args)))) - (function - #'(lambda (&rest more-args) (apply (the function fn) (append args more-args)))))) - -(defun slot-boundp* (object slot) - (notnot (slot-boundp object slot))) - -(defun slot-exists-p* (object slot) - (notnot (slot-exists-p object slot))) - -(defun map-slot-boundp* (c slots) - (mapcar (applyf #'slot-boundp c) slots)) - -(defun map-slot-exists-p* (c slots) - (mapcar (applyf #'slot-exists-p* c) slots)) - -(defun map-slot-value (c slots) - (mapcar (applyf #'slot-value c) slots)) - -(defun map-typep* (object types) - (mapcar (applyf #'typep* object) types)) - -(defun slot-value-or-nil (object slot-name) - (and (slot-exists-p object slot-name) - (slot-boundp object slot-name) - (slot-value object slot-name))) - -(defun is-noncontiguous-sublist-of (list1 list2) - (loop - for x in list1 - do (loop - when (null list2) do (return-from is-noncontiguous-sublist-of nil) - when (eql x (pop list2)) do (return)) - finally (return t))) - -;;; This defines a new metaclass to allow us to get around -;;; the restriction in section 11.1.2.1.2, bullet 19 in some -;;; object system tests - -;;; (when (typep (find-class 'standard-class) 'standard-class) -;;; (defclass substandard-class (standard-class) ()) -;;; (defparameter *can-define-metaclasses* t)) - -;;; Macro for testing that something is undefined but 'harmless' - -(defmacro defharmless (name form) - `(deftest ,name - (block done - (let ((*debugger-hook* #'(lambda (&rest args) - (declare (ignore args)) - (return-from done :good)))) - (handler-case - (unwind-protect (eval ',form) (return-from done :good)) - (condition () :good)))) - :good)) - -(defun rational-safely (x) - "Rational a floating point number, making sure the rational - number isn't 'too big'. This is important in implementations such - as clisp where the floating bounds can be very large." - (assert (floatp x)) - (multiple-value-bind (significand exponent sign) - (integer-decode-float x) - (let ((limit 1000) - (radix (float-radix x))) - (cond - ((< exponent (- limit)) - (* significand (expt radix (- limit)) sign)) - ((> exponent limit) - (* significand (expt radix limit) sign)) - (t (rational x)))))) - -(declaim (special *similarity-list*)) - -(defun is-similar (x y) - (let ((*similarity-list* nil)) - (is-similar* x y))) - -(defgeneric is-similar* (x y)) - -(defmethod is-similar* ((x number) (y number)) - (and (eq (class-of x) (class-of y)) - (= x y) - t)) - -(defmethod is-similar* ((x character) (y character)) - (and (char= x y) t)) - -(defmethod is-similar* ((x symbol) (y symbol)) - (if (null (symbol-package x)) - (and (null (symbol-package y)) - (is-similar* (symbol-name x) (symbol-name y))) - ;; I think the requirements for interned symbols in - ;; 3.2.4.2.2 boils down to EQ after the symbols are in the lisp - (eq x y)) - t) - -(defmethod is-similar* ((x random-state) (y random-state)) - (let ((copy-of-x (make-random-state x)) - (copy-of-y (make-random-state y)) - (bound (1- (ash 1 24)))) - (and - ;; Try 50 values, and assume the random state are the same - ;; if all the values are the same. Assuming the RNG is not - ;; very pathological, this should be acceptable. - (loop repeat 50 - always (eql (random bound copy-of-x) - (random bound copy-of-y))) - t))) - -(defmethod is-similar* ((x cons) (y cons)) - (or (and (eq x y) t) - (and (loop for (x2 . y2) in *similarity-list* - thereis (and (eq x x2) (eq y y2))) - t) - (let ((*similarity-list* - (cons (cons x y) *similarity-list*))) - (and (is-similar* (car x) (car y)) - ;; If this causes stack problems, - ;; convert to a loop - (is-similar* (cdr x) (cdr y)))))) - -(defmethod is-similar* ((x vector) (y vector)) - (or (and (eq x y) t) - (and - (or (not (typep x 'simple-array)) - (typep x 'simple-array)) - (= (length x) (length y)) - (is-similar* (array-element-type x) - (array-element-type y)) - (loop for i below (length x) - always (is-similar* (aref x i) (aref y i))) - t))) - -(defmethod is-similar* ((x array) (y array)) - (or (and (eq x y) t) - (and - (or (not (typep x 'simple-array)) - (typep x 'simple-array)) - (= (array-rank x) (array-rank y)) - (equal (array-dimensions x) (array-dimensions y)) - (is-similar* (array-element-type x) - (array-element-type y)) - (let ((*similarity-list* - (cons (cons x y) *similarity-list*))) - (loop for i below (array-total-size x) - always (is-similar* (row-major-aref x i) - (row-major-aref y i)))) - t))) - -(defmethod is-similar* ((x hash-table) (y hash-table)) - ;; FIXME Add similarity check for hash tables - (error "Sorry, we're not computing this yet.")) - -(defmethod is-similar* ((x pathname) (y pathname)) - (and - (is-similar* (pathname-host x) (pathname-host y)) - (is-similar* (pathname-device x) (pathname-device y)) - (is-similar* (pathname-directory x) (pathname-directory y)) - (is-similar* (pathname-name x) (pathname-name y)) - (is-similar* (pathname-type x) (pathname-type y)) - (is-similar* (pathname-version x) (pathname-version y)) - t)) - -(defmethod is-similar* ((x t) (y t)) - (and (eql x y) t)) - -(defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*) - *print-pprint-dispatch* - nil)) - -(defmacro my-with-standard-io-syntax (&body body) - `(let ((*package* (find-package "COMMON-LISP-USER")) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-lines* nil) - (*print-miser-width* nil) - (*print-pprint-dispatch* *initial-print-pprint-dispatch*) - (*print-pretty* nil) - (*print-radix* nil) - (*print-readably* t) - (*print-right-margin* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-eval* t) - (*read-suppress* nil) - (*readtable* (copy-readtable nil))) - ,@body)) - -;;; Function to produce a non-simple string - -(defun make-special-string (string &key fill adjust displace base) - (let* ((len (length string)) - (len2 (if fill (+ len 4) len)) - (etype (if base 'base-char 'character))) - (if displace - (let ((s0 (make-array (+ len2 5) - :initial-contents - (concatenate 'string - (make-string 2 :initial-element #\X) - string - (make-string (if fill 7 3) - :initial-element #\Y)) - :element-type etype))) - (make-array len2 :element-type etype - :adjustable adjust - :fill-pointer (if fill len nil) - :displaced-to s0 - :displaced-index-offset 2)) - (make-array len2 :element-type etype - :initial-contents - (if fill (concatenate 'string string "ZZZZ") string) - :fill-pointer (if fill len nil) - :adjustable adjust)))) - -(defmacro do-special-strings ((var string-form &optional ret-form) &body forms) - (let ((string (gensym)) - (fill (gensym "FILL")) - (adjust (gensym "ADJUST")) - (base (gensym "BASE")) - (displace (gensym "DISPLACE"))) - `(let ((,string ,string-form)) - (dolist (,fill '(nil t) ,ret-form) - (dolist (,adjust '(nil t)) - (dolist (,base '(nil t)) - (dolist (,displace '(nil t)) - (let ((,var (make-special-string - ,string - :fill ,fill :adjust ,adjust - :base ,base :displace ,displace))) - ,@forms)))))))) - -(defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer)) - (let* ((len (length contents)) - (min (reduce #'min contents)) - (max (reduce #'max contents)) - (len2 (if fill (+ len 4) len))) - (unless (and (typep min etype) - (typep max etype)) - (setq etype `(integer ,min ,max))) - (if displace - (let ((s0 (make-array (+ len2 5) - :initial-contents - (concatenate 'list - (make-list 2 :initial-element - (if (typep 0 etype) 0 min)) - contents - (make-list (if fill 7 3) - :initial-element - (if (typep 1 etype) 1 max))) - :element-type etype))) - (make-array len2 :element-type etype - :adjustable adjust - :fill-pointer (if fill len nil) - :displaced-to s0 - :displaced-index-offset 2)) - (make-array len2 :element-type etype - :initial-contents - (if fill (concatenate 'list - contents - (make-list 4 :initial-element - (if (typep 2 etype) 2 (floor (+ min max) 2)))) - contents) - :fill-pointer (if fill len nil) - :adjustable adjust)))) - -(defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms) - (let ((vector (gensym)) - (fill (gensym "FILL")) - (adjust (gensym "ADJUST")) - (etype (gensym "ETYPE")) - (displace (gensym "DISPLACE"))) - `(let ((,vector ,vec-form)) - (dolist (,fill '(nil t) ,ret-form) - (dolist (,adjust '(nil t)) - (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i)) - (loop for i from 2 to 32 collect `(signed-byte ,i)) - '(integer))) - (dolist (,displace '(nil t)) - (let ((,var (make-special-integer-vector - ,vector - :fill ,fill :adjust ,adjust - :etype ,etype :displace ,displace))) - ,@forms)))))))) - -;;; Return T if arg X is a string designator in this implementation - -(defun string-designator-p (x) - (handler-case - (progn (string x) t) - (error nil))) - -;;; Approximate comparison of numbers -#| -(defun approx= (x y) - (let ((eps 1.0d-4)) - (<= (abs (- x y)) - (* eps (max (abs x) (abs y)))))) -|# - -;;; Approximate equality function -(defun approx= (x y &optional (eps (epsilon x))) - (<= (abs (/ (- x y) (max (abs x) 1))) eps)) - -(defun epsilon (number) - (etypecase number - (complex (* 2 (epsilon (realpart number)))) ;; crude - (short-float short-float-epsilon) - (single-float single-float-epsilon) - (double-float double-float-epsilon) - (long-float long-float-epsilon) - (rational 0))) - -(defun negative-epsilon (number) - (etypecase number - (complex (* 2 (negative-epsilon (realpart number)))) ;; crude - (short-float short-float-negative-epsilon) - (single-float single-float-negative-epsilon) - (double-float double-float-negative-epsilon) - (long-float long-float-negative-epsilon) - (rational 0))) - -(defun sequencep (x) (typep x 'sequence)) - -(defun typef (type) #'(lambda (x) (typep x type))) - -(defun package-designator-p (x) - "TRUE if x could be a package designator. The package need not - actually exist." - (or (packagep x) - (handler-case (and (locally (declare (optimize safety)) - (string x)) - t) - (type-error () nil)))) - -(defmacro def-fold-test (name form) - "Create a test that FORM, which should produce a fresh value, - does not improperly introduce sharing during constant folding." - `(deftest ,name - (flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0) - (compilation-speed 0) (debug 0))) - ,form)) - (eq (%f) (%f))) - nil)) - -;;; Macro used in tests of environments in system macros -;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP -;;; was being called in some system macros without the proper -;;; environment argument - -(defmacro expand-in-current-env (macro-form &environment env) - (macroexpand macro-form env)) diff --git a/src/tests/regressions/ansi.lsp b/src/tests/regressions/ansi.lsp new file mode 100644 index 000000000..7766aee9e --- /dev/null +++ b/src/tests/regressions/ansi.lsp @@ -0,0 +1,75 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +(in-package :cl-test) + +(suite 'regressions/ansi+) + + +;; HyperSpec – 3.* + +;;;;;;;;;;;;;;;;;;; +;; Deftype tests ;; +;;;;;;;;;;;;;;;;;;; + +(ext:with-clean-symbols (ordinary1 ordinary2) + (test ansi.0001.ordinary + (deftype ordinary1 () + `(member nil t)) + + (deftype ordinary2 (a b) + (if a 'CONS `(INTEGER 0 ,b))) + + (is-true (typep T 'ordinary1)) + (is-false (typep :a 'ordinary1)) + (is-false (typep T '(ordinary2 nil 3))) + (is-true (typep 3 '(ordinary2 nil 4))) + (is-false (typep T '(ordinary2 T nil))) + (is-true (typep '(1 . 2) '(ordinary2 T nil))))) + +(ext:with-clean-symbols (opt) + (test ansi.0002.optional + (deftype opt (a &optional b) + (if a 'CONS `(INTEGER 0 ,b))) + + (is-true (typep 5 '(opt nil))) + (is-false (typep 5 '(opt nil 4))))) + +(ext:with-clean-symbols (nest) + (test ansi.0003.nested + (deftype nest ((a &optional b) c . d) + (assert (listp d)) + `(member ,a ,b ,c)) + (is-true (typep 1 '(nest (1 2) 3 4 5 6))) + (is-false (typep 1 '(nest (2 2) 3 4 5 6))) + (is-true (typep '* '(nest (3) 3))) + (is-true (typep 3 '(nest (2) 3))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; 19.* Pathname tests ;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Issue #103 ;; logical-pathname-translations not translating +;; https://gitlab.com/embeddable-common-lisp/ecl/issues/103 +(test ansi.0004.wildcards + (setf (logical-pathname-translations "prog") + '(("CODE;*.*.*" "/tmp/prog/"))) + (is (equal + (namestring (translate-logical-pathname "prog:code;documentation.lisp")) + "/tmp/prog/documentation.lisp"))) + + + +;;;;;;;;;;;;;;;;;;;;;;; +;; 23.* Reader tests ;; +;;;;;;;;;;;;;;;;;;;;;;; +(progn + (defstruct example-struct a) + (test ansi.0005.sharp-s-reader + (finishes + (read-from-string + "(#1=\"Hello\" #S(cl-test::example-struct :A #1#))")))) + + diff --git a/src/tests/regressions/compiler.lsp b/src/tests/regressions/compiler.lsp new file mode 100644 index 000000000..2880a96c9 --- /dev/null +++ b/src/tests/regressions/compiler.lsp @@ -0,0 +1,1152 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Author: Juan Jose Garcia-Ripoll +;;;; Created: Fri Apr 14 11:13:17 CEST 2006 +;;;; Contains: Compiler regression tests + +(in-package :cl-test) + +(suite 'regressions/cmp) + + +;; cl-001 + +;;; Date: 09/05/2006 +;;; From: Brian Spilsbury +;;; Fixed: 20/05/2006 (Brian Spilsbury) +;;; Description: +;;; +;;; (DEFPACKAGE "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T")) +;;; fails to import symbol NIL because IMPORT is invoked as +;;; (IMPORT NIL (find-package "CL")), which does not import +;;; any symbol. +;;; +(test cmp.0001.import + (defpackage "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T")) + (multiple-value-bind (symbol access) + (find-symbol "NIL" (find-package "FOO")) + (is (and (eql symbol NIL) + (eql access :INTERNAL)))) + (delete-package "FOO")) + +;;; Date: 09/05/2006 +;;; From: Brian Spilsbury +;;; Fixed: 20/05/2006 (Brian Spilsbury) +;;; Description: +;;; +;;; Compiled FLET forms failed to shadow global macro definitions, if not +;;; for the compiler, at least for MACRO-FUNCTION and MACROEXPAND[-1] +;;; +(test cmp.0002.macro-shadow + (with-compiler ("aux-cl-0002.lsp" :load t) + '(defmacro foo () 2) + '(defmacro bar (symbol &environment env) + (and (macro-function symbol env) t)) + '(defun doit () (flet ((foo () 1)) (bar foo)))) + (delete-file "aux-cl-0002.lsp") + (delete-file (compile-file-pathname "aux-cl-0002" :type :fas)) + (is-false (doit)) + (fmakunbound 'doit) + (fmakunbound 'bar) + (fmakunbound 'foo)) + +;;; +;;; Fixed: 14/06/2006 (juanjo) +;;; Description: +;;; +;;; APROPOS, APROPOS-LIST and HELP* are case sensitive. +;;; +(test cmp.0003.apropos + (is (equal (apropos-list "bin") + (apropos-list "bin")))) + +;;; Date: 08/07/2006 (Dave Roberts) +;;; Fixed: 02/08/2006 (juanjo) +;;; Description: +;;; +;;; SLIME traps when invoking DESCRIBE. Reason is that STREAMP breaks on +;;; Gray streams. +;;; +(test cmp.0004.streamp + (is-true (streamp (make-instance 'gray:fundamental-stream)))) + +;;; Date: 02/08/2006 (juanjo) +;;; Description: +;;; +;;; There is a problem with SUBTYPEP and type STREAM +;;; +(test cmp.0005.subtypep-stream + (is (equal (multiple-value-list + (subtypep (find-class 'gray:fundamental-stream) 'stream)) + (list t t)))) + +;;; Date: 09/07/2006 (Tim S) +;;; Fixed: 09/07/2006 (Tim S) +;;; Description: +;;; +;;; ENOUGH-NAMESTRING provided too large pathnames even when the +;;; pathname was a subdirectory of the default pathname. +;;; +;;; Date: 31/12/2006 (Richard M. Kreuter) +;;; Fixed: 5/1/2007 (Juanjo) +;;; Description: +;;; ENOUGH-NAMESTRING does not simplify the pathname when the +;;; directory matches completely that of the default path. +;;; + + +(ext:with-clean-symbols (*enough-namestring_tests*) + (defvar *enough-namestring_tests* + `(("/A/b/C/" + ("/A/b/C/drink-up.sot" + "/A/b/C/loozer/whiskey.sot" + "/A/b/C/loozer/whiskey" + "/A/b/whiskey.sot" + "/A/" + "whiskey.sot" + "loozer/whiskey.sot" + "C/loozer/whisky.sot" + "")) + ("A/b/C" ("A/b/C" "A/b/C/loozer" "b/C" "/A/b/C" "/A/" "")) + ("/" ("/A/b/C/drink-up.sot" "/A/b/C/" "/A/" "")) + ("" ("/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.sot" + "/A/b/C/loozer/whiskey" "/A/b/whiskey.sot" + "/A/" "whiskey.sot" "loozer/whiskey.sot" "C/loozer/whisky.sot")) + ("/A/*/C/drink-up.sot" + ("/A/*/C/drink-up.sot" "/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.*" + "/A/b/C/loozer/*.sot" "/A/**/whiskey.sot" "")) + ("/A/b/../c/d.sot" ("/A/b/../c/d.sot" "/A/b/../c/D/e.sot" + "/A/c/d.sot" "../c/d.sot" + "c/e/d.sot")))) + + (test cmp.0006.enough-namestring + (labels ((test-path (path defaults) + (let* ((e-ns (enough-namestring path defaults)) + (d1 (pathname-directory path)) + (d2 (pathname-directory defaults)) + (d3 (pathname-directory e-ns))) + (and (equalp (merge-pathnames e-ns defaults) + (merge-pathnames (parse-namestring path nil defaults) + defaults)) + ;; If directories concide, the "enough-namestring" + ;; removes the directory. But only if the pathname is + ;; absolute. + (not (and (equal (first d1) ':absolute) + (equalp d1 d2) + d3))))) + (test-default+paths (default+paths) + (let ((defaults (first default+paths)) + (paths (second default+paths))) + (every (lambda (path) + (handler-case (test-path path defaults) + (error (error) 'NIL))) + paths)))) + (is-true + (every #'test-default+paths *enough-namestring_tests*))))) + +;;; Date: 10/08/2006 (Lars Brinkhoff) +;;; Fixed: 1/09/2006 (juanjo) +;;; Details: +;;; +;;; ADJUST-ARRAY must signal a type error when the value of :FILL-POINTER is +;;; not NIL and the adjustable array does not have a fill pointer +;;; +(test cmp.0007.adjustable-array + (is (equal + (loop for fp in '(nil t) collect + (loop for i in '(t nil 0 1 2 3) collect + (and + (handler-case (adjust-array (make-array 3 :adjustable t :fill-pointer fp) 4 + :fill-pointer i) + (type-error (c) nil) + (error (c) t)) + t))) + '((nil t nil nil nil nil) (t t t t t t))))) + +;;; Date: 09/10/2006 (Dustin Long) +;;; Fixed: 10/10/2006 +;;; Description: +;;; +;;; The namestring "." is improperly parsed, getting a file type of "" +;;; Additionally we found it more convenient to have the _last_ dot mark +;;; the file type, so that (pathname-type "foo.mpq.txt") => "txt" +;;; + +(test cmp.0008.parse-namestring + (is-false + (loop for (namestring name type) in + '(("." "." NIL) (".." "." "") (".foo" ".foo" NIL) (".foo.mpq.txt" ".foo.mpq" "txt") + ("foo.txt" "foo" "txt") ("foo.mpq.txt" "foo.mpq" "txt")) + unless (let ((x (parse-namestring namestring))) + (and (equal name (pathname-name x)) + (equal type (pathname-type x)) + (equal '() (pathname-directory x)))) + collect namestring))) + +;;; Date: 28/09/2006 +;;; Fixed: 10/10/2006 +;;; Description: +;;; +;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized +;;; The following code tests that at least three objects are finalized. +;;; +;;; Note: this test fails in multithreaded mode. GC takes too long! +(ext:with-clean-symbols (*all-tags*) + (test cmp.0009.finalization + (is-equal '(0 1 2 3 4) + (let ((*all-tags* '())) + (declare (special *all-tags*)) + (flet ((custom-finalizer (tag) + #'(lambda (o) + (declare (ignore o)) + ;; XXX + (push tag *all-tags*)))) + (let ((a '())) + (dotimes (i 5) + (let ((x (cons i i))) + (si::set-finalizer x (custom-finalizer i)) + (push x a)))) + (sleep 1) ; mitigate gc being slow + (dotimes (j 100) + (dotimes (i 10000) + (cons 1.0 1.0)) + (si::gc t))) + (sort *all-tags* #'<))))) + +;;; Date: 8/10/2006 (Dustin Long) +;;; Fixed: 10/10/2006 (Dustin Long) +;;; Description: +;;; +;;; Hash table iterators have to check that their argument is +;;; really a hash table. +;;; +(test cmp.0010.hash-iterator + (is-false + (loop for i in *mini-universe* + when (and (not (hash-table-p i)) + (handler-case (progn (loop for k being the hash-keys of i) t) + (error (c) nil))) + collect (type-of i)))) + +;;; Date: 31/12/2006 (Richard M. Kreuter) +;;; Fixed: 5/1/2007 (Juanjo) +;;; Description: +;;; +;;; The keyword :BACK does not work as expected when creating pathnames +;;; and causes an error when at the beginning: (:RELATIVE :BACK) +;;; +(test cmp.0011.make-pathname-with-back + (is-false + (loop for i from 0 to 200 + with l = (random 10) + with x = (if (zerop l) 0 (random (1+ l))) + with y = (if (= l x) 0 (random (- l x))) + nconc (let* ((l (loop for i from 0 below l collect (princ-to-string i))) + (l2 (append (subseq l 0 y) '("break" :back) (subseq l y nil))) + (d1 (list* :absolute (subseq l2 0 x))) + (d2 (list* :relative (subseq l2 x nil))) + (d3 (list* :absolute l2)) + (d4 (list* :relative l2)) + (p1 (handler-case (make-pathname :directory d1) + (error (c) nil))) + (p2 (handler-case (make-pathname :directory d2) + (error (c) nil))) + (p3 (handler-case (make-pathname :directory d3) + (error (c) nil))) + (p4 (handler-case (make-pathname :directory d4) + (error (c) nil)))) + (if (and p1 p2 p3 p4 + ;; MERGE-PATHNAMES eliminates :BACK + (equalp l (rest (pathname-directory (merge-pathnames p2 p1)))) + ;; MAKE-PATHNAME does not eliminate :BACK + (not (equalp l (rest (pathname-directory (make-pathname :directory d3))))) + (not (equalp l (rest (pathname-directory (make-pathname :directory d4)))))) + nil + (list (list l d1 d2 d3 d4 l2 x y))))))) + +;;; Date: 11/03/2007 (Fare) +;;; Fixed: 23/03/2007 (Juanjo) +;;; Description: +;;; +;;; COPY-READTABLE did not copy the entries of the "from" table +;;; when a second argument, i.e. a "destination" table was supplied. +;;; +(test cmp.0012.copy-readtable + (is-false + (let ((from-readtable (copy-readtable)) + (to-readtable (copy-readtable)) + (char-list '())) + (dotimes (i 20) + (let* ((code (+ 32 (random 70))) + (c (code-char code))) + (push c char-list) + (set-macro-character c + (eval `(lambda (str ch) ,code)) + nil + from-readtable))) + (copy-readtable from-readtable to-readtable) + (loop for c in char-list + unless (and (eql (char-code c) + (let ((*readtable* from-readtable)) + (read-from-string (string c)))) + (eq (get-macro-character c from-readtable) + (get-macro-character c to-readtable))) + collect c)))) + +;;; Date: 05/01/2008 (Anonymous, SF bug report) +;;; Fixed: 06/01/2008 (Juanjo) +;;; Description: +;;; +;;; For a file linked as follows "ln -s //usr/ /tmp/foo", +;;; (truename #p"/tmp/foo") signals an error because //usr is +;;; parsed as a hostname. +;;; +#-windows +(test cmp.0013.truename + (si:system "rm -rf foo; ln -sf //usr/ foo") + (is (equal (namestring (truename "./foo")) "/usr/")) + (si::system "rm foo")) + +;;; Date: 30/08/2008 (Josh Elsasser) +;;; Fixed: 01/09/2008 (Juanjo) +;;; Description: +;;; +;;; Inside the form read by #., recursive definitions a la #n= +;;; and #n# were not properly expanded +;;; +(test cmp.0014.sharp-dot + (is + (equal (with-output-to-string (*standard-output*) + (let ((*print-circle* t)) + (read-from-string "'#.(princ (list '#1=(1 2) '#1#))"))) + "(#1=(1 2) #1#)"))) + +;;; Date: 30/08/2008 (Josh Elsasser) +;;; Fixed: 30/08/2008 (Josh Elsasser) +;;; Description: +;;; +;;; A setf expansion that produces a form with a macro that also has +;;; its own setf expansion does not giver rise to the right code. +;;; +(test cmp.0015.setf-expander + (define-setf-expander triple (place &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (let ((store (gensym))) + (values dummies + vals + `(,store) + `(let ((,(car newval) (/ ,store 3))) + (triple ,setter)) + `(progn + (triple ,getter)))))) + (defmacro hidden (val) + `(triple ,val)) + (defmacro triple (val) + `(* 3 ,val)) + (is-true (equalp + (eval '(let ((foo 5)) + (list foo (triple foo) (setf (triple foo) 6) foo (triple foo)))) + (eval '(let ((foo 5)) + (list foo (hidden foo) (setf (hidden foo) 6) foo (hidden foo)))))) + (fmakunbound 'hidden) + (fmakunbound 'triple)) + +;;; Date: 17/2/2009 +;;; Fixed: 17/2/2009 +;;; Description: +;;; +;;; The defstruct form fails with an :include field that overwrites +;;; a slot that is read only. +;;; +(defstruct compiler.0016-a (a 1 :read-only t)) +(defstruct (compiler.0016-b (:include compiler.0016-a (a 2)))) +(defstruct (compiler.0016-c (:include compiler.0016-a (a 3 :read-only t)))) +(test cmp.0016.defstruct-include + (is-true + (handler-case + (eval '(defstruct (compiler.0016-d (:include compiler.0016-a (a 2 :read-only nil))))) + (error (c) t))) + (is (= (compiler.0016-a-a (make-compiler.0016-a)) 1)) + (is (= (compiler.0016-b-a (make-compiler.0016-b)) 2)) + (is (= (compiler.0016-c-a (make-compiler.0016-c)) 3)) + (is-true + (handler-case + (eval '(setf (compiler.0016-c-a (make-compiler.0016-c)) 3)) + (error (c) t)))) + +;;; Date: 9/11/2009 +;;; Fixed: 9/11/2009 +;;; Description: +;;; +;;; LOAD does not work with special files (/dev/null) +;;; +(test cmp.0017.load-special + (finishes + (load #+(or windows mingw32) "NULL" + #-(or windows mingw32) "/dev/null"))) + +;;; Date: 16/11/2009 (Gabriel) +;;; Fixed: 20/11/2009 (Juanjo) +;;; Description: +;;; +;;; #= and ## reader macros do not work well with #. +;;; +(test cmp.0018.sharp-eq + (is + (equal (handler-case (values (read-from-string "(#1=(0 1 2) #.(length '#1#))")) + (serious-condition (c) nil)) + '((0 1 2) 3)))) + +;;; Date: 14/11/2009 (M. Mondor) +;;; Fixed: 20/11/2009 (Juanjo) +;;; Description: +;;; +;;; FDEFINITION and SYMBOL-FUNCTION cause SIGSEGV when acting on NIL. +;;; +(test cmp.0019.fdefinition + (is-true + (handler-case (fdefinition nil) + (undefined-function (c) t) + (serious-condition (c) nil))) + (is-true + (handler-case (symbol-function nil) + (undefined-function (c) t) + (serious-condition (c) nil)))) + + +;;; Date: 29/11/2009 (P. Costanza) +;;; Fixed: 29/11/2009 (Juanjo) +;;; Description: +;;; +;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE. +;;; +(ext:with-clean-symbols (*update-guard* class-a class-a-b) + (test cmp.0020.make-instances-obsolete + (defparameter *update-guard* nil) + (defclass class-a () ((b :accessor class-a-b :initarg :b))) + (let ((*a* (make-instance 'class-a :b 2))) + (defmethod update-instance-for-redefined-class :before + ((instance standard-object) added-slots discarded-slots property-list + &rest initargs) + (setf *update-guard* t)) + (is-true + (and (null *update-guard*) + (progn (class-a-b *a*) (null *update-guard*)) + (progn (make-instances-obsolete (find-class 'class-a)) + (null *update-guard*)) + (progn (class-a-b *a*) *update-guard*) + (progn (setf *update-guard* nil) + (defclass class-a () ((b :accessor class-a-b :initarg :b))) + (class-a-b *a*) + *update-guard*)))))) + +;;; Date: 25/03/2009 (R. Toy) +;;; Fixed: 4/12/2009 (Juanjo) +;;; Description: +;;; +;;; Conversion of rationals into floats is done by truncating, not by +;;; rounding, what implies a loss of accuracy. +;;; +(test cmp.0021.ratio-to-float + ;; The test builds a ratio which is very close to 1 but which is below it + ;; If we truncate instead of rounding the output will not be 1 coerced + ;; to that floating point type. + (is-false + (loop for type in '(short-float single-float double-float long-float) + for bits = (float-precision (coerce 1 type)) + do (loop for i from (+ bits 7) to (+ bits 13) + nconc (loop with value = (ash 1 i) + with expected = (coerce 1 type) + for j from 0 to 10 + for x = (- value j) + for r = (/ (1- x) x) + for f1 = (coerce r type) + for f2 = (- (coerce (- r) type)) + unless (and (= f1 expected) (= f2 expected)) + collect (list type r)))))) + +;;; Date: 06/04/2010 (M. Kocic) +;;; Fixed: 4/12/2009 +;;; Description: +;;; +;;; Inspection of structs is broken due to undefined inspect-indent +;;; +(ext:with-clean-symbols (st1) + (test cmp.0022.inspect-struct + (is-true + (let ((*query-io* (make-string-input-stream "q +"))) + (defstruct st1 p1) + (let ((v1 (make-st1 :p1 "tttt"))) + (handler-case (progn (inspect v1) t) + (error (c) nil))))))) + + +;; cmp-001 + +;;; Date: 12/03/2006 +;;; From: Dan Corkill +;;; Fixed: 14/04/2006 (juanjo) +;;; Description: +;;; +;;; The inner RETURN form should return to the outer block. +;;; However, the closure (lambda (x) ...) is improperly translated +;;; by the compiler to (lambda (x) (block nil ...) and thus this +;;; form outputs '(1 2 3 4). +;;; +(test cmp.0023.block + (is + (= (funcall (compile nil + '(lambda () + (block nil + (funcall 'mapcar + #'(lambda (x) + (when x (return x))) + '(1 2 3 4))))))))) + +;;; Fixed: 12/01/2006 (juanjo) +;;; Description: +;;; +;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as +;;; synonyms. +;;; +;;; +(test cmp.0024.pathname + (is (equalp (compile-file-pathname "foo" :type :fas) + (compile-file-pathname "foo" :type :fasl)))) + +;;; Fixed: 21/12/2005 (juanjo) +;;; Description: +;;; +;;; Compute the path of the intermediate files (*.c, *.h, etc) +;;; relative to that of the fasl or object file. +;;; +(ext:with-clean-symbols (foo) + (test cmp.0025.paths + (let* ((output (compile-file-pathname "tmp/aux" :type :fasl)) + (h-file (compile-file-pathname output :type :h)) + (c-file (compile-file-pathname output :type :c)) + (data-file (compile-file-pathname output :type :data))) + (is-true + (and + (zerop (si::system "rm -rf tmp; mkdir -p tmp")) + (with-compiler ("aux-compiler.0103-paths.lsp" :output-file output :c-file t + :h-file t :data-file t) + '(defun foo (x) (1+ x))) + (probe-file output) + (probe-file c-file) + (probe-file h-file) + (probe-file data-file) + (zerop (si::system "rm -rf tmp; mkdir -p tmp")) + (delete-file "aux-compiler.0103-paths.lsp")))))) + +;;; Date: 08/03/2006 +;;; From: Dan Corkill +;;; Fixed: 09/03/2006 (juanjo) +;;; Description: +;;; +;;; DEFCONSTANT does not declare the symbol as global and thus the +;;; compiler issues warnings when the symbol is referenced in the +;;; same file in which it is defined as constant. +;;; +#-ecl-bytecmp +(test cmp.0026.defconstant-warn + (is-false + (let ((warn nil)) + (with-dflet ((c::cmpwarn (setf warn t))) + (with-compiler ("aux-compiler.0104.lsp") + '(defconstant foo (list 1 2 3)) + '(print foo))) + (delete-file "aux-compiler.0104.lsp") + (delete-file (compile-file-pathname "aux-compiler.0104.lsp" :type :fas)) + warn))) + +;;; Date: 16/04/2006 +;;; From: Juanjo +;;; Fixed: 16/04/2006 (juanjo) +;;; Description: +;;; +;;; Special declarations should only affect the variable bound and +;;; not their initialization forms. That, even if the variables are +;;; the arguments of a function. +;;; +(test cmp.0027.declaration + (let ((form '(lambda (y) + (flet ((faa (&key (x y)) + (declare (special y)) + x)) + (let ((y 4)) + (declare (special y)) + (faa)))))) + ;; We must test that both the intepreted and the compiled form + ;; output the same value. + (is (= (funcall (compile 'nil form) 3) 3)) + (is (= (funcall (coerce form 'function) 3) 3)))) + +;;; Date: 26/04/2006 +;;; From: Michael Goffioul +;;; Fixed: ---- +;;; Description: +;;; +;;; Functions with more than 64 arguments have to be invoked using +;;; the lisp stack. +;;; +(test cmp.0028.call-arguments-limit + (let ((form '(lambda () + (list (list + 'a0 'b0 'c0 'd0 'e0 'f0 'g0 'h0 'i0 + 'j0 'k0 'l0 'm0 'n0 'o0 'p0 'q0 + 'r0 's0 't0 'u0 'v0 'w0 'x0 'y0 'z0 + 'a1 'b1 'c1 'd1 'e1 'f1 'g1 'h1 'i1 + 'j1 'k1 'l1 'm1 'n1 'o1 'p1 'q1 + 'r1 's1 't1 'u1 'v1 'w1 'x1 'y1 'z1 + 'a2 'b2 'c2 'd2 'e2 'f2 'g2 'h2 'i2 + 'j2 'k2 'l2 'm2 'n2 'o2 'p2 'q2 + 'r2 's2 't2 'u2 'v2 'w2 'x2 'y2 'z2 + 'a3 'b3 'c3 'd3 'e3 'f3 'g3 'h3 'i3 + 'j3 'k3 'l3 'm3 'n3 'o3 'p3 'q3 + 'r3 's3 't3 'u3 'v3 'w3 'x3 'y3 'z3 + 'a4 'b4 'c4 'd4 'e4 'f4 'g4 'h4 'i4 + 'j4 'k4 'l4 'm4 'n4 'o4 'p4 'q4 + 'r4 's4 't4 'u4 'v4 'w4 'x4 'y4 'z4 + 'a5 'b5 'c5 'd5 'e5 'f5 'g5 'h5 'i5 + 'j5 'k5 'l5 'm5 'n5 'o5 'p5 'q5 + 'r5 's5 't5 'u5 'v5 'w5 'x5 'y5 'z5 + 'a6 'b6 'c6 'd6 'e6 'f6 'g6 'h6 'i6 + 'j6 'k6 'l6 'm6 'n6 'o6 'p6 'q6 + 'r6 's6 't6 'u6 'v6 'w6 'x6 'y6 'z6))))) + (is (equal (funcall (compile 'foo form)) + (funcall (coerce form 'function)))))) + +;;; Date: 16/05/2005 +;;; Fixed: 18/05/2006 (juanjo) +;;; Description: +;;; +;;; The detection of when a lisp constant has to be externalized using MAKE-LOAD-FORM +;;; breaks down with some circular structures +;;; +(defclass compiler-test-class () + ((parent :accessor compiler-test-parent :initform nil) + (children :initarg :children :accessor compiler-test-children :initform nil))) + +(defmethod make-load-form ((x compiler-test-class) &optional environment) + (declare (ignore environment)) + (values + ;; creation form + `(make-instance ',(class-of x) :children ',(slot-value x 'children)) + ;; initialization form + `(setf (compiler-test-parent ',x) ',(slot-value x 'parent)))) + +(test cmp.0029.circular-load-form + (is + (equal + (loop for object in + (let ((l (list 1 2 3))) + (list l + (subst 3 l l) + (make-instance 'compiler-test-class) + (subst (make-instance 'compiler-test-class) 3 l))) + collect (clos::need-to-make-load-form-p object nil)) + '(nil nil t t)))) + +;;; Date: 18/05/2005 +;;; Fixed: 17/05/2006 (Brian Spilsbury & juanjo) +;;; Description: +;;; +;;; The compiler is not able to externalize constants that have no +;;; printed representation. In that case MAKE-LOAD-FORM should be +;;; used. +;;; +(test cmp.0030.make-load-form + (let ((output + (with-compiler ("make-load-form.lsp") + "(in-package cl-test)" + "(eval-when (:compile-toplevel) + (defvar s4 (make-instance 'compiler-test-class)) + (defvar s5 (make-instance 'compiler-test-class)) + (setf (compiler-test-parent s5) s4) + (setf (compiler-test-children s4) (list s5)))" + "(defvar a '#.s5)" + "(defvar b '#.s4)" + "(defvar c '#.s5)" + "(defun foo () + (let ((*print-circle* t)) + (with-output-to-string (s) (princ '#1=(1 2 3 #.s4 #1#) s))))"))) + (load output) + (delete-file "make-load-form.lsp") + (delete-file output)) + (is-equal "#1=(1 2 3 # #1#)" (foo)) + +;;; Date: 9/06/2006 (Pascal Costanza) +;;; Fixed: 13/06/2006 (juanjo) +;;; Description: +;;; +;;; A MACROLET function creates a set of local macro definitions. +;;; The forms that expand these macros are themselves affected by +;;; enclosing MACROLET and SYMBOL-MACRO definitions: +;;; (defun bar () +;;; (macrolet ((x () 2)) +;;; (macrolet ((m () (x))) +;;; (m)))) +;;; (compile 'bar) +;;; (bar) => 2 +;;; + (ext:with-clean-symbols (bar) + (test cmp.0031.macrolet + (is (= 2 (progn + (defun bar () + (macrolet ((x () 2)) + (macrolet ((m () (x))) + (m)))) + (compile 'bar) + (bar)))) + (is (= 2 (progn + (defun bar () + (symbol-macrolet ((x 2)) + (macrolet ((m () x)) + (m)))) + (compile 'bar) + (bar))))))) + +;;; Fixed: 13/06/2006 (juanjo) +;;; Description: +;;; +;;; A MACROLET that references a local variable from the form in +;;; which it appears can cause corruption in the interpreter. We +;;; solve this by signalling errors whenever such reference +;;; happens. +;;; +;;; Additionally MACROLET forms should not see the other macro +;;; definitions on the same form, much like FLET functions cannot +;;; call their siblings. +;;; +(ext:with-clean-symbols (compiler-foo) + (test cmp.0032.macrolet-2 + (is-equal '(error 1 error error 6 (7 8) error error) + (flet ((eval-with-error (form) + (handler-case (eval form) + (error (c) 'error)))) + (let ((faa 1)) + (declare (special faa)) + (mapcar #'eval-with-error + '((let ((faa 2)) + (macrolet ((m () faa)) + (m))) + (let ((faa 4)) + (declare (special faa)) + (macrolet ((m () faa)) + (m))) + (let ((faa 4)) + (declare (special compiler-foo)) + (macrolet ((m () compiler-foo)) + (m))) + (let ((faa 5)) + (macrolet ((m () compiler-foo)) + (m))) + (macrolet ((compiler-foo () 6)) + (macrolet ((m () (compiler-foo))) + (m))) + (macrolet ((f1 () 7) + (f2 () 8)) + ;; M should not see the new definitions F1 and F2 + (macrolet ((f1 () 9) + (f2 () 10) + (m () (list 'quote (list (f1) (f2))))) + (m))) + (flet ((compiler-foo () 1)) + (macrolet ((m () (compiler-foo))) + (m))) + (labels ((compiler-foo () 1)) + (macrolet ((m () (compiler-foo))) + (m)))))))) + (makunbound 'compiler-foo) + (fmakunbound 'compiler-foo))) + +;;; Date: 22/06/2006 (juanjo) +;;; Fixed: 29/06/2006 (juanjo) +;;; Description: +;;; +;;; ECL only accepted functions with less than 65 required +;;; arguments. Otherwise it refused to compile the function. The fix must +;;; respect the limit in the number of arguments passed in the C stack and +;;; use the lisp stack for the other required arguments. +;;; +#-ecl-bytecmp +(test cmp.0033.c-arguments-limit + (is (equal '((10 :ERROR :ERROR) (20 :ERROR :ERROR) (30 :ERROR :ERROR) + (40 :ERROR :ERROR) (50 :ERROR :ERROR) (63 :ERROR :ERROR) + (64 :ERROR :ERROR) (65 :ERROR :ERROR) (70 :ERROR :ERROR)) + (mapcar + #'(lambda (nargs) + (let* ((arg-list (loop for i from 0 below nargs + collect (intern (format nil "arg~d" i)))) + (data (loop for i from 0 below nargs collect i)) + (lambda-form `(lambda ,arg-list + (and (equalp (list ,@arg-list) ',data) + ,nargs))) + (c:*compile-verbose* nil) + (c:*compile-print* nil) + (function (compile 'foo lambda-form))) + (list (apply function (subseq data 0 nargs)) + (handler-case (apply function (make-list (1+ nargs))) + (error (c) :error)) + (handler-case (apply function (make-list (1- nargs))) + (error (c) :error))))) + '(10 20 30 40 50 63 64 65 70))))) + +;;; Date: 12/07/2008 (Josh Elsasser) +;;; Fixed: 02/08/2008 (Juanjo) +;;; Description: +;;; +;;; ECL fails to properly compute the closure type of a function that +;;; returns a lambda that calls the function itself. +;;; +(test cmp.0034.compute-closure + (is + (with-compiler ("aux-compiler.0103-paths.lsp" :load t) + '(defun testfun (outer) + (labels ((testlabel (inner) + (if inner + (testfun-map + (lambda (x) (testlabel x)) + inner)) + (print outer))) + (testlabel outer)))))) + +;;; Date: 02/09/2008 (Josh Elsasser) +;;; Fixed: 12/09/2008 (Josh Elsasser) +;;; Description: +;;; +;;; FTYPE proclamations and declarations do not accept user defined +;;; function types. +;;; +(ext:with-clean-symbols (compiler.float-function + compiler.float) + (test cmp.0035.ftype-user-type + (progn + (deftype compiler.float-function () '(function (float) float)) + (deftype compiler.float () 'float) + (loop for (type . fails) in + '(((function (float) float) . nil) + (cons . t) + (compiler.float-function . nil) + (compiler.float . t)) + always (let ((form1 `(proclaim '(ftype ,type foo))) + (form2 `(compile nil '(lambda () + (declare (ftype ,type foo)) + (foo))))) + (cond (fails + (signals simple-error (eval form1)) + (signals warning (eval form2))) + (:otherwise + (finishes (eval form1)) + (finishes (eval form2))))))))) + +;;; Date: 01/11/2008 (E. Marsden) +;;; Fixed: 02/11/2008 (Juanjo) +;;; Description: +;;; +;;; When compiled COERCE with type INTEGER may cause double +;;; evaluation of a form. +;;; +;;; ------------------------------------------------------------ +;;; Date: 03/11/2008 (E. Marsden) +;;; Fixed: 08/11/2008 (Juanjo) +;;; Description: +;;; +;;; TYPEP, with a real type, produces strange results. +;;; +(test cmp.0036.coerce + (is-true (= 1 + (funcall + (compile 'foo '(lambda (x) + (coerce (shiftf x 2) 'integer))) + 1))) + (is-false (funcall + (compile 'foo '(lambda (x) + (typep (shiftf x 1) '(real 10 20)))) + 5))) + +;;; Date: 20/07/2008 (Juanjo) +;;; Fixed: 20/07/2008 (Juanjo) +;;; Description: +;;; +;;; In the new compiler, when compiling LET forms with special variables +;;; the values of the variables are not saved to make the assignments +;;; really parallel. +;;; +(test cmp.0037.let-with-specials + (is + (= + 7 + (progn + (defvar *stak-x*) + (defvar *stak-y*) + (defvar *stak-z*) + (funcall + (compile + nil + '(lambda (*stak-x* *stak-y* *stak-z*) + (labels + ((stak-aux () + (if (not (< (the fixnum *stak-y*) (the fixnum *stak-x*))) + *stak-z* + (let ((*stak-x* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-x*)))) + (*stak-y* *stak-y*) + (*stak-z* *stak-z*)) + (stak-aux))) + (*stak-y* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-y*)))) + (*stak-y* *stak-z*) + (*stak-z* *stak-x*)) + (stak-aux))) + (*stak-z* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-z*)))) + (*stak-y* *stak-x*) + (*stak-z* *stak-y*)) + (stak-aux)))) + (stak-aux))))) + (stak-aux)))) 18 12 6))))) + +;;; Date: 06/10/2009 (J. Pellegrini) +;;; Fixed: 06/10/2009 (Juanjo) +;;; Description: +;;; Extended strings were not accepted as documentation by the interpreter. +;;; +(ext:with-clean-symbols (foo) + (test cmp.0038.docstrings + (eval `(defun foo () + ,(make-array 10 :initial-element #\Space :element-type 'character) + 2)) + (is (= (eval (funcall 'foo)) 2)))) + +;;; Date: 07/11/2009 (A. Hefner) +;;; Fixed: 07/11/2009 (A. Hefner + Juanjo) +;;; Description: +;;; ECL ignores the IGNORABLE declaration +;;; +(test cmp.0039.ignorable + (let ((c::*suppress-compiler-messages* t)) + ;; Issue a warning for unused variables + (is-true + (handler-case (and (compile nil '(lambda (x y) (print x))) nil) + (warning (c) t))) + ;; Do not issue a warning for unused variables declared IGNORE + (is-true + (handler-case (and (compile nil '(lambda (x y) (declare (ignore y)) + (print x))) t) + (warning (c) nil))) + ;; Do not issue a warning for unused variables declared IGNORABLE + (is-true + (handler-case (and (compile nil '(lambda (x y) (declare (ignorable y)) + (print x))) t) + (warning (c) nil))) + ;; Do not issue a warning for used variables declared IGNORABLE + (is-true + (handler-case (and (compile nil '(lambda (x y) (declare (ignorable x y)) + (print x))) t) + (warning (c) nil))))) + +;;; Date: 29/11/2009 (P. Costanza) +;;; Fixed: 29/11/2009 (Juanjo) +;;; Description: +;;; When calling a bytecodes (SETF ...) function from a compiled function +;;; an invalid memory access is produced. This is actually a consequence +;;; of a mismatch between the position of the fields bytecodes.entry +;;; and cfun.entry +;;; +#-ecl-bytcmp +(test cmp.0040.bytecodes-entry-position + (let ((indices (funcall (compile nil + '(lambda () + (ffi:c-inline () () list " + union cl_lispunion x[0]; + cl_index bytecodes = (char*)(&(x->bytecodes.entry)) - (char*)x; + cl_index bclosure = (char*)(&(x->bclosure.entry)) - (char*)x; + cl_index cfun = (char*)(&(x->cfun.entry)) - (char*)x; + cl_index cfunfixed = (char*)(&(x->cfunfixed.entry)) - (char*)x; + cl_index cclosure = (char*)(&(x->cclosure.entry)) - (char*)x; + @(return) = cl_list(5, MAKE_FIXNUM(bytecodes), + MAKE_FIXNUM(bclosure), + MAKE_FIXNUM(cfun), + MAKE_FIXNUM(cfunfixed), + MAKE_FIXNUM(cclosure));" :one-liner nil)))))) + (is-true (apply #'= indices)) t)) + +;;; Date: 07/02/2010 (W. Hebich) +;;; Fixed: 07/02/2010 (Juanjo) +;;; Description: +;;; THE forms do not understand VALUES types +;;; (the (values t) (funcall sym)) +;;; +(test cmp.0041.the-and-values + (is + (handler-case (compile nil '(lambda () (the (values t) (faa)))) + (warning (c) nil)))) + + +;;; Date: 28/03/2010 (M. Mondor) +;;; Fixed: 28/03/2010 (Juanjo) +;;; Description: +;;; ECL does not compile type declarations of a symbol macro +;;; +(test cmp.0042.symbol-macro-declaration + (is + (handler-case (compile 'nil + '(lambda (x) + (symbol-macrolet ((y x)) + (declare (fixnum y)) + (+ y x)))) + (warning (c) nil)))) + +;;; Date: 24/04/2010 (Juanjo) +;;; Fixed 24/04/2010 (Juanjo) +;;; Description: +;;; New special form, WITH-BACKEND. +;;; +(ext:with-clean-symbols (*compiler.0122* compiler.0122a) + (defparameter *compiler.0122* nil) + (test cmp.0043.with-backend + ;; we ensure compiler.0122a isn't compiled upfront + (eval '(defun compiler.0122a () + (ext:with-backend + :bytecodes (setf *compiler.0122* :bytecodes) + :c/c++ (setf *compiler.0122* :c/c++)))) + (is-eql :bytecodes + (progn (compiler.0122a) + *compiler.0122*)) + (is-eql :bytecodes + (compiler.0122a)) + (is-eql :c/c++ + (progn (compile 'compiler.0122a) + (compiler.0122a) + *compiler.0122*)) + (is-eql :c/c++ + (compiler.0122a)))) + + + +;;; Date: 10/08/2008 +;;; From: Juanjo +;;; Fixed: 10/08/2008 +;;; Description: +;;; +;;; COS, SIN and TAN were expanded using a wrong C expression. +;;; + +(test cmp.0044.inline-cos + (is-false + (loop with *compile-verbose* = nil + with *compile-print* = nil + for type in '(short-float single-float double-float long-float) + for sample = (coerce 1.0 type) + for epsilon in '(#.short-float-epsilon #.single-float-epsilon #.double-float-epsilon #.long-float-epsilon) + unless (loop for op in '(sin cos tan sinh cosh tanh) + for f = (compile 'nil `(lambda (x) + (declare (,type x) + (optimize (safety 0) + (speed 3))) + (+ ,sample (,op x)))) + always (loop for x from (- pi) below pi by 0.05 + for xf = (float x sample) + for error = (- (funcall f xf) (+ 1 (funcall op xf))) + always (< (abs error) epsilon))) + collect type))) + + + +;;; Description: +;;; +;;; The interpreter selectively complains when assigning a variable +;;; that has not been declared as special and is not local. +;;; +;;; Fixed: 03/2006 (juanjo) +;;; +(test cmp.0045.global-setq + (is (equal + '(:no-error :error) + (mapcar + (lambda (ext:*action-on-undefined-variable*) + (handler-case + (progn (eval `(setq ,(gensym) 1)) :no-error) + (error (c) :error))) + '(nil ERROR))))) + +;;; Date: 24/04/2010 (Juanjo) +;;; Fixed: 24/04/2010 (Juanjo) +;;; Description: +;;; The interpreter does not increase the lexical environment depth when +;;; optimizing certain forms (LIST, LIST*, CONS...) and thus causes some +;;; of the arguments to be eagerly evaluated. +;;; +(test cmp.0046.list-optimizer-error + (is (string-equal + (with-output-to-string (*standard-output*) + (eval '(list (print 1) (progn (print 2) (print 3))))) + " +1 +2 +3 "))) + + + +;;; Date: 2015-09-04 +;;; Fixed: Daniel Kochmański +;;; Description +;;; Compiler signalled arithmetic-error when producing C code for infinity +;;; and NaN float values (part of ieee floating point extensions). + +#+ieee-floating-point +(ext:with-clean-symbols (infty-test) + (test cmp.0047.infinity-test + (finishes (compile nil + (lambda () + (> 0.0 ext:single-float-negative-infinity)))) + (is-true + (progn + (with-compiler ("aux-compiler-0048.infty-test.2.lsp" :load t) + '(defun doit () (> 0.0 ext:single-float-negative-infinity))) + (delete-file "aux-compiler-0048.infty-test.2.lsp") + (delete-file "aux-compiler-0048.infty-test.2.fas") + (doit))))) + + + +;;; Date: 2015-12-18 +;;; Fixed: Daniel Kochmański +;;; Description +;;; Compiler expanded FIND incorrectly (ignored START and END arguments) + +(ext:with-clean-symbols (check-single-wildcard) + (test cmp.0048.cmpopt-sequences + (defun check-single-wildcard (identifier wildcard-pos) + (not (find #\* identifier :start (1+ wildcard-pos)))) + (is-true (check-single-wildcard "dan*" 3)))) + +;;; Date: 2016-02-10 +;;; Fixed: Daniel Kochmański +;;; Description +;;; Aux closures created by C compiler weren't handled correctly +;;; in respect of the environment and declarations of the +;;; variables +(test cmp.0049.cmptop/call + (finishes + (funcall (compile nil '(lambda () + (labels + ((fun-2 () (fun-3 'cool)) + (fun-3 (clause-var) + (flet ((fun-4 () clause-var)) + (fun-4)))) + (let ((fun-1 (lambda () (fun-2)))) + (funcall fun-1)))))))) + + +;;; Date 2016-04-21 +;;; Fixed: Daniel Kochmański +;;; Description +;;; typep didn't recognize * as a t abberv +;;; +(test cmp.0050.ftype-args* + (declaim (ftype (function (*) (values T)) ce)) + (defun ce (expression) expression) + (is-false (ce nil))) diff --git a/src/tests/regressions/doit.lsp b/src/tests/regressions/doit.lsp deleted file mode 100644 index 11b8bc577..000000000 --- a/src/tests/regressions/doit.lsp +++ /dev/null @@ -1,58 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;; Remove compiled files -(let* ((fn (compile-file-pathname "doit.lsp")) - (type (pathname-type fn)) - (dir-pathname (make-pathname :name :wild :type type)) - (files (union (directory "aux*.*") (directory dir-pathname) :test #'equal))) - (assert type) - (assert (not (string-equal type "lsp"))) - (mapc #'delete-file files)) - -(si::package-lock (find-package "COMMON-LISP") nil) -(require 'rt) - -#+ecl (compile nil '(lambda () nil)) - -(setq *load-verbose* nil - *load-print* nil - *compile-verbose* nil - *compile-print* nil) - -(unless (find-package :cl-test) - (make-package :cl-test)) - -(in-package :cl-test) -(use-package :sb-rt) - -(load "tools.lsp") -(load "universe.lsp") -(load "ansi-aux.lsp") - -(load "tests/test-ansi.lsp") -(load "tests/mixed.lsp") -(load "tests/compiler.lsp") - -#-ecl-bytecmp -(progn - (load "tests/embedding.lsp") - #+ffi (load "tests/foreign-interface.lsp")) - -#+clos -(load "tests/metaobject-protocol.lsp") - -#+threads -(load "tests/multiprocessing.lsp") - -#+unicode -(load "tests/external-formats.lsp") -(load "tests/random-states.lsp") - -(setf sb-rt::*expected-failures* - (nconc sb-rt::*expected-failures* - '(SEM-SIGNAL-N-PROCESSES - SEM-SIGNAL-ONLY-N-PROCESSES - SEM-INTERRUPTED-RESIGNALS))) - -(time (sb-rt:do-tests)) diff --git a/src/tests/regressions/tests/embedding.lsp b/src/tests/regressions/embedding.lsp similarity index 87% rename from src/tests/regressions/tests/embedding.lsp rename to src/tests/regressions/embedding.lsp index dcad21805..c51210474 100644 --- a/src/tests/regressions/tests/embedding.lsp +++ b/src/tests/regressions/embedding.lsp @@ -7,6 +7,8 @@ (in-package :cl-test) +(suite 'regressions/emb) + (defun test-C-program (c-code &key capture-output) (ensure-directories-exist "tmp/") (with-open-file (s "tmp/aux.c" :direction :output :if-exists :supersede @@ -44,8 +46,9 @@ ;;; ;;; Fixed: 03/2006 (juanjo) ;;; -(deftest embedding.0001.shutdown - (let* ((skeleton " +(test emb.0001.shutdown + (is (equal + (let* ((skeleton " #include #include int main (int argc, char **argv) { @@ -55,11 +58,11 @@ int main (int argc, char **argv) { cl_shutdown(); exit(0); }") - (form '(push (lambda () (print :shutdown)) si::*exit-hooks*)) - (c-code (format nil skeleton (format nil "~S" form))) - (data (test-C-program c-code :capture-output t))) - data) - (:shutdown)) + (form '(push (lambda () (print :shutdown)) si::*exit-hooks*)) + (c-code (format nil skeleton (format nil "~S" form))) + (data (test-C-program c-code :capture-output t))) + data) + '(:shutdown)))) ;;; Date: 2016-05-25 (Vadim Penzin) ;;; Date: 2016-05-27 (Vadim Penzin) @@ -78,8 +81,9 @@ int main (int argc, char **argv) { ;;; user interaction (ie picking the restart), hence we only test ;;; the ECL_HANDLER_CASE. ;;; -(deftest embedding.0002.handlers - (let* ((c-code " +(test emb.0002.handlers + (is-true + (let* ((c-code " #include #include @@ -102,5 +106,4 @@ main ( const int argc, const char * const argv [] ) return result; } ")) - (test-C-program c-code)) - T) + (test-C-program c-code)))) diff --git a/src/tests/regressions/tests/external-formats.lsp b/src/tests/regressions/external-formats.lsp similarity index 86% rename from src/tests/regressions/tests/external-formats.lsp rename to src/tests/regressions/external-formats.lsp index 3a0d9d5ce..d8982c8ce 100644 --- a/src/tests/regressions/tests/external-formats.lsp +++ b/src/tests/regressions/external-formats.lsp @@ -8,13 +8,10 @@ ;;;; Based on the code and files from FLEXI-STREAMS 1.0.7 ;;;; -#+(or) -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package :cl-test) - (make-package :cl-test))) - (in-package :cl-test) +(suite 'features/eformat) + ;;; eformat-001 @@ -135,7 +132,6 @@ about each individual comparison if VERBOSE is true." :external-format external-format-out) (funcall *copy-function* in out)))) (one-comparison (path-in external-format-in path-out external-format-out) - (format t "~%;;; ~A -> ~A" path-in path-out) (loop with full-path-in = (merge-pathnames path-in "./eformat-tests/") and full-path-out = (ensure-directories-exist (merge-pathnames path-out "./eformat-tmp/")) @@ -150,8 +146,9 @@ about each individual comparison if VERBOSE is true." (copy-file full-path-in external-format-in full-path-out external-format-out direction-out direction-in) - (multiple-value-setq (ok pos) - (file-equal full-path-out full-path-orig))) + (is (multiple-value-setq (ok pos) + (file-equal full-path-out full-path-orig)) + "~%~A -> ~A" path-in path-out)) collect (progn (format t "~%;;; Discordance at pos ~D~%between ~A~% and ~A~%" pos full-path-out full-path-orig) @@ -171,9 +168,8 @@ about each individual comparison if VERBOSE is true." ;;; supported formats and checking against the expected results. This ;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. ;;; -(deftest external-format.0001-transcode-read-char - (do-eformat-test-001 'copy-stream) - nil) +(test external-format.0001-transcode-read-char + (is-false (do-eformat-test-001 'copy-stream))) ;;; Date: 02/01/2007 ;;; From: Juanjo @@ -184,9 +180,8 @@ about each individual comparison if VERBOSE is true." ;;; supported formats and checking against the expected results. This ;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. ;;; -(deftest external-format.0002-transcode-read-char - (do-eformat-test-001 'copy-stream*) - nil) +(test external-format.0002-transcode-read-char + (is-false (do-eformat-test-001 'copy-stream*))) ;;; eformat-002 @@ -293,7 +288,7 @@ about each individual comparison if VERBOSE is true." (si::system command)) (compare-files decoded-filename iconv-filename all-chars) (prog1 T - (format t "~&;;; iconv command failed:~A" command))))))) + (format t "~&;;; iconv command failed:~A~%" command))))))) ;;; Date: 09/01/2007 ;;; From: Juanjo @@ -308,37 +303,37 @@ about each individual comparison if VERBOSE is true." ;; fails to execute a command. Hence in that case we assume ;; we simply can not run these tests (when (zerop (si::system "iconv -l >/dev/null 2>&1")) - (deftest external-format.simple-iconv-check - (loop for name in '(:ISO-8859-1 :ISO-8859-2 :ISO-8859-3 :ISO-8859-4 - :ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8 - :ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13 - :ISO-8859-14 :ISO-8859-15 :ISO-8859-16 + (test external-format.simple-iconv-check + (is-false + (loop for name in '(:ISO-8859-1 :ISO-8859-2 :ISO-8859-3 :ISO-8859-4 + :ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8 + :ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13 + :ISO-8859-14 :ISO-8859-15 :ISO-8859-16 - :KOI8-R :KOI8-U + :KOI8-R :KOI8-U - :IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860 - :IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866 - :IBM869 + :IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860 + :IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866 + :IBM869 - :CP936 :CP949 :CP950 + :CP936 :CP949 :CP950 - :WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253 - :WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257 + :WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253 + :WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257 - ;; :CP932 :WINDOWS-1255 :WINDOWS-1258 with - ;; iconv may output combined characters, when ECL would - ;; output the base and the comibining one. Hence, no simple - ;; comparison is possible. + ;; :CP932 :WINDOWS-1255 :WINDOWS-1258 with + ;; iconv may output combined characters, when ECL would + ;; output the base and the comibining one. Hence, no simple + ;; comparison is possible. - :ISO-2022-JP - ;; :ISO-2022-JP-1 - ;; iconv doesn't support ISO-2022-JP-1 (hue hue hue) - ) - unless (progn - (format t "~%;;; Testing ~A " name) - (loop for i from 1 to 10 - always (test-output name (symbol-name name)))) - collect name) - nil)) + :ISO-2022-JP + ;; :ISO-2022-JP-1 + ;; iconv doesn't support ISO-2022-JP-1 (hue hue hue) + ) + unless (progn + (loop for i from 1 to 10 + always (is (test-output name (symbol-name name)) + "iconv test ~s failed" name))) + collect name)))) diff --git a/src/tests/regressions/foreign-interface.lsp b/src/tests/regressions/foreign-interface.lsp new file mode 100644 index 000000000..1351fede8 --- /dev/null +++ b/src/tests/regressions/foreign-interface.lsp @@ -0,0 +1,114 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Author: Juan Jose Garcia-Ripoll +;;;; Author: Daniel Kochmański +;;;; Created: Fri Apr 14 11:13:17 CEST 2006 +;;;; Contains: Foreign Function Interface regression tests + +(in-package :cl-test) +(suite 'regressions/ffi) + +;;; Date: 23/03/2006 +;;; From: Klaus Falb +;;; Fixed: 26/02/2006 (juanjo) +;;; Description: +;;; +;;; Callback functions have to be declared static so that there +;;; are no conflicts among callbacks in different files. +;;; +;;; Fixed: 13/04/2006 (juanjo) +;;; Description: +;;; +;;; Header should be included as +;;; + +(test ffi.0001.callback + (is + (and (zerop (si::system "rm -rf tmp; mkdir tmp")) + (with-open-file (s "tmp/a.lsp" :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print '(ffi:defcallback foo :void () nil) s)) + (with-open-file (s "tmp/b.lsp" :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print '(ffi:defcallback foo :void () nil) s)) + (compile-file "tmp/a.lsp" :system-p t) + (compile-file "tmp/b.lsp" :system-p t) + (c:build-program "tmp/foo" :lisp-files + (list (compile-file-pathname "tmp/a.lsp" :type :object) + (compile-file-pathname "tmp/b.lsp" :type :object))) + (probe-file (compile-file-pathname "tmp/foo" :type :program)) + (zerop (si::system "rm -rf tmp"))))) + +;;; Date: 29/07/2008 +;;; From: Juajo +;;; Description: +;;; Callback examples based on the C compiler +;;; +(test ffi.0002.callback-sffi-example + (is + (and (zerop (si::system "rm -rf tmp; mkdir tmp")) + (with-open-file (s "tmp/c.lsp" :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print + '(defun callback-user (callback arg) + (ffi:c-inline (callback arg) (:pointer-void :int) :int " +int (*foo)(int) = #0; +@(return) = foo(#1); +" + :one-liner nil :side-effects nil)) + s) + (print + '(ffi:defcallback ffi-002-foo :int ((a :int)) + (1+ a)) + s)) + (compile-file "tmp/c.lsp" :load t) + (eql (callback-user (ffi:callback 'ffi-002-foo) 2) 3) + t))) + +;;; Date: 29/07/2008 +;;; From: Juajo +;;; Description: +;;; Callback examples based on the DFFI. Only work if this feature +;;; has been linked in. +;;; +#+dffi +(test ffi.0003.callback-dffi-example + (is + (and (zerop (si::system "rm -rf tmp; mkdir tmp")) + (with-open-file (s "tmp/c.lsp" :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print + '(defun callback-user (callback arg) + (ffi:c-inline (callback arg) (:pointer-void :int) :int " +int (*foo)(int) = #0; +@(return) = foo(#1); +" + :one-liner nil :side-effects nil)) + s)) + (compile-file "tmp/c.lsp" :load t) + (eval '(ffi:defcallback foo-002b :int ((a :int)) + (1+ a))) + (eql (callback-user (ffi:callback 'foo-002b) 2) 3) + t))) + +;;; Date: 25/04/2010 (Juanjo) +;;; Description: +;;; Regression test to ensure that two foreign data compare +;;; EQUAL when their addresses are the same. +(test ffi.0004.foreign-data-equal + (is + (equal (ffi:make-pointer 1234 :void) + (ffi:make-pointer 1234 :int)))) + +;;; Date: 2016-01-04 (jackdaniel) +;;; Description: +;;; Regression test to ensure, that the string is properly +;;; recognized as an array +(test ffi.0005.string-is-array + (finishes + (si::make-foreign-data-from-array "dan"))) diff --git a/src/tests/regressions/metaobject-protocol.lsp b/src/tests/regressions/metaobject-protocol.lsp new file mode 100644 index 000000000..eb3b0ee5e --- /dev/null +++ b/src/tests/regressions/metaobject-protocol.lsp @@ -0,0 +1,620 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Author: Juan Jose Garcia-Ripoll +;;;; Author: Daniel Kochmański +;;;; Created: Fri Apr 14 11:13:17 CEST 2006 +;;;; Contains: Metaobject Protocol tests + +(in-package #:cl-test) + +(suite 'regressions/mop) + + +;; mop-001 + +(defun delete-class (&rest class-names) + ;;; do nothing. We will figure out later what to do. + (values)) + +;;; Fixed: 14/04/2006 (juanjo) +;;; Description: +;;; +;;; The slot definitions from some classes did not get converted. +;;; Besides, metaobject CLASS had the same list for direct and effective +;;; slots. +;;; +(test mop.0001.fixup + (is-false + (block top + (labels ((test-class (class-object) + (let ((x (find-if-not #'(lambda (x) + (typep x 'clos:standard-direct-slot-definition)) + (clos:class-direct-slots class-object)))) + (when x + (format t "Class ~a has as direct slot ~a" class-object x) + (return-from top (class-name class-object)))) + (let ((x (find-if-not #'(lambda (x) + (typep x 'clos:standard-effective-slot-definition)) + (clos:class-slots class-object)))) + (when x + (format t "Class ~a has as effective slot ~a" class-object x) + (return-from top (class-name class-object)))) + (mapc #'test-class (clos:class-direct-subclasses class-object)))) + (test-class (find-class 't)) + nil)))) + +;;; Date: 13/02/2006 +;;; From: Dan Debertin +;;; Fixed: 24-02-2006 (juanjo) +;;; Description: +;;; +;;; Subclasses of STANDARD-CLASS would not inherit all their slots +;;; and thus would cause runtime errors when creating instances. +;;; + +(test mop.0002.metaclasses + (is + (= 3 + (eval '(progn + (defclass foo-metaclass (standard-class) ()) + (defclass faa () ((a :initform 2 :initarg :a)) (:metaclass foo-metaclass)) + (prog1 (slot-value (make-instance 'faa :a 3) 'a) + (cl-test::delete-class 'foo-metaclass 'faa))))))) + +;;; Date: 02/03/2006 +;;; From: Pascal Costanza +;;; Fixed: 07/03/2006 (juanjo) +;;; Description: +;;; +;;; CLOS should export the symbols from the AMOP. +;;; + + +(defconstant +mop-symbols+ '("DIRECT-SLOT-DEFINITION" +"EFFECTIVE-SLOT-DEFINITION" "EQL-SPECIALIZER" "FORWARD-REFERENCED-CLASS" +"FUNCALLABLE-STANDARD-CLASS" "FUNCALLABLE-STANDARD-OBJECT" "METAOBJECT" +"SLOT-DEFINITION" "SPECIALIZER" "STANDARD-ACCESSOR-METHOD" +"STANDARD-DIRECT-SLOT-DEFINITION" "STANDARD-EFFECTIVE-SLOT-DEFINITION" +"STANDARD-READER-METHOD" "STANDARD-SLOT-DEFINITION" "STANDARD-WRITER-METHOD" +"ACCESSOR-METHOD-SLOT-DEFINITION" "ADD-DEPENDENT" "ADD-DIRECT-METHOD" +"ADD-DIRECT-SUBCLASS" "CLASS-DEFAULT-INITARGS" +"CLASS-DIRECT-DEFAULT-INITARGS" "CLASS-DIRECT-SLOTS" +"CLASS-DIRECT-SUBCLASSES" "CLASS-DIRECT-SUPERCLASSES" "CLASS-FINALIZED-P" +"CLASS-PRECEDENCE-LIST" "CLASS-PROTOTYPE" "CLASS-SLOTS" +"COMPUTE-APPLICABLE-METHODS-USING-CLASSES" "COMPUTE-CLASS-PRECEDENCE-LIST" +"COMPUTE-DEFAULT-INITARGS" "COMPUTE-DISCRIMINATING-FUNCTION" +"COMPUTE-EFFECTIVE-METHOD" "COMPUTE-EFFECTIVE-SLOT-DEFINITION" +"COMPUTE-SLOTS" "DIRECT-SLOT-DEFINITION-CLASS" +"EFFECTIVE-SLOT-DEFINITION-CLASS" "ENSURE-CLASS" "ENSURE-CLASS-USING-CLASS" +"ENSURE-GENERIC-FUNCTION-USING-CLASS" "EQL-SPECIALIZER-OBJECT" +"EXTRACT-LAMBDA-LIST" "EXTRACT-SPECIALIZER-NAMES" "FINALIZE-INHERITANCE" +"FIND-METHOD-COMBINATION" "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" +"GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" +"GENERIC-FUNCTION-DECLARATIONS" "GENERIC-FUNCTION-LAMBDA-LIST" +"GENERIC-FUNCTION-METHOD-CLASS" "GENERIC-FUNCTION-METHOD-COMBINATION" +"GENERIC-FUNCTION-METHODS" "GENERIC-FUNCTION-NAME" "INTERN-EQL-SPECIALIZER" +"MAKE-METHOD-LAMBDA" "MAP-DEPENDENTS" "METHOD-FUNCTION" +"METHOD-GENERIC-FUNCTION" "METHOD-LAMBDA-LIST" "METHOD-SPECIALIZERS" +"READER-METHOD-CLASS" "REMOVE-DEPENDENT" "REMOVE-DIRECT-METHOD" +"REMOVE-DIRECT-SUBCLASS" "SET-FUNCALLABLE-INSTANCE-FUNCTION" +"SLOT-BOUNDP-USING-CLASS" "SLOT-DEFINITION-ALLOCATION" +"SLOT-DEFINITION-INITARGS" "SLOT-DEFINITION-INITFORM" +"SLOT-DEFINITION-INITFUNCTION" "SLOT-DEFINITION-LOCATION" +"SLOT-DEFINITION-NAME" "SLOT-DEFINITION-READERS" "SLOT-DEFINITION-WRITERS" +"SLOT-DEFINITION-TYPE" "SLOT-MAKUNBOUND-USING-CLASS" +"SLOT-VALUE-USING-CLASS" "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" +"SPECIALIZER-DIRECT-METHODS" "STANDARD-INSTANCE-ACCESS" "UPDATE-DEPENDENT" +"VALIDATE-SUPERCLASS" "WRITER-METHOD-CLASS")) + +(test mop.0003.amop-symbols + (is-false + (let ((*package* (find-package "CLOS"))) + (remove-if #'(lambda (x) + (multiple-value-bind (s to) + (find-symbol x *package*) + (and s (eq to :external)))) + +mop-symbols+)))) + +;;; Date: 02/03/2006 +;;; From: Dank Corkill +;;; Fixed: 02-03-2006 (Dan Corkill) +;;; Description: +;;; +;;; DEFCLASS allows additional options which should be handled by the +;;; metaclass. +;;; +;;; Description: +;;; +;;; Readers and writers for slot documentation. +;;; + +(test mop.0004.defclass-options + (is + (equal + '(T) + (eval '(let ((*aux* 5)) + (declare (special *aux*)) + (defclass foo-metaclass (standard-class) ()) + (defmethod shared-initialize ((class foo-metaclass) slot-names + &rest initargs &key option) + (prog1 (call-next-method) + (setf *aux* option))) + (defclass faa () + ((a :initform *aux* :initarg :a)) + (:metaclass foo-metaclass) + (:option t)) + (prog1 (slot-value (make-instance 'faa) 'a) + (cl-test::delete-class 'foo-metaclass 'faa))))) + "DEFCLASS allows additional options which should be handled by ~ +the metaclass") + (is + (equal (eval '(progn + (defclass fee () + ((a :initform *aux* :initarg :a))) + (setf (documentation (first (clos:class-slots (find-class 'fee))) t) + #1="hola") + (documentation (first (clos:class-slots (find-class 'fee))) t))) + #1#) + "Readers and writers for slot documentation")) + +;;; Date: 25/03/2006 +;;; From: Pascal Costanza +;;; Fixed: 03/04/2006 (juanjo) +;;; Description: +;;; +;;; The default slot setter methods had the first argument +;;; (i.e. the new value) specialized to NIL. This makes it +;;; impossible to write further specializations. +;;; +(test mop.0005.setf-specializer + (defclass fee () + ((a :accessor fee-a))) + (is + (equal '(t fee) + (mapcar #'class-name + (clos:method-specializers + (first (clos:generic-function-methods #'(setf fee-a))))))) + (is + (equal '(fee) + (mapcar #'class-name + (clos:method-specializers + (first (clos:generic-function-methods #'fee-a)))))) + (delete-class 'fee)) + +;;; Date: 06/04/2006 +;;; From: Pascal Costanza +;;; Fixed: --- +;;; Description: +;;; +;;; When a required argument in a method is not explicitely given +;;; an specializer, the specializer should be T. Thus +;;; (defmethod foo (a)) +;;; is equivalent to +;;; (defmethod foo ((a t))) +;;; +(ext:with-clean-symbols (test-method) + (test mop.0006.method-specializer + (defmethod test-method (a)) + (is (equal + (mop:method-specializers + (first (mop:generic-function-methods #'test-method))) + (list (find-class t)))) + (fmakunbound 'test-method))) + +;;; Date: 22/04/2006 +;;; From: M. Goffioul +;;; Fixed: 23/04/2006 (juanjo) +;;; Description: +;;; +;;; When a class inherits from two other classes which have a slot +;;; with the same name, the new class should inherit the accessors +;;; from both classes. +;;; + +(ext:with-clean-symbols (fee-1 fee-2 fee-3 c-slot-0) + (test mop.0007.slot-inheritance + (defclass fee-1 () + ((slot-0 :initform 0 :reader slot-0) + (slot-1 :initform 1 :reader slot-1))) + (defclass fee-2 () + ((slot-0 :initform 2 :reader slot-2))) + (defclass fee-3 (fee-1 fee-2) + ((slot-0 :initform 3 :accessor c-slot-0))) + (flet ((accessors (class) + (list (class-name class) + (mapcar #'clos:slot-definition-readers (clos:class-slots class)) + (mapcar #'clos:slot-definition-readers (clos:class-slots class))))) + (is (equal (accessors (find-class 'fee-1)) + '(fee-1 ((slot-0) (slot-1)) ((slot-0) (slot-1))))) + (is (equal (accessors (find-class 'fee-2)) + '(fee-2 ((slot-2)) ((slot-2))))) + (is (equal (accessors (find-class 'fee-3)) + '(fee-3 ((c-slot-0 slot-0 slot-2) (slot-1)) + ((c-slot-0 slot-0 slot-2) (slot-1))))) + (is (equal (mapcar #'(lambda (o) + (mapcar #'(lambda (method) + (handler-case (funcall method o) + (error (c) nil))) + '(slot-0 slot-2 c-slot-0))) + (mapcar #'make-instance '(fee-1 fee-2 fee-3))) + '((0 nil nil) + (nil 2 nil) + (3 3 3)))) + (delete-class 'fee-1 'fee-2 'fee-3)))) + + +;;; Date: 28/04/2006 +;;; From: P. Costanza +;;; Fixed: 05/05/2006 (P. Costanza) +;;; Description: +;;; +;;; Option names from classes and generic functions which are not +;;; in the keyword package should be quoted. This test is +;;; essentially like mop.0004... because our DEFGENERIC does not +;;; support non-keyword options. +;;; +(test mop.0008.defclass-option-quote + (eval '(let ((*aux* 5)) + (declare (special *aux*)) + (defclass foo-metaclass (standard-class) ()) + (defmethod shared-initialize ((class foo-metaclass) slot-names + &rest initargs &key ((cl-user::option option))) + (prog1 (call-next-method) + (setf *aux* option))) + (defclass faa () + ((a :initform *aux* :initarg :a)) + (:metaclass foo-metaclass) + (cl-user::option t)) + (is (equal '(t) + (slot-value (make-instance 'faa) 'a))) + (cl-test::delete-class 'foo-metaclass 'faa)))) + + +;;; Date: 05/10/2006 +;;; From: Rick Taube +;;; Fixed: 10/10/2006 (juanjo) +;;; Description: +;;; +;;; :INITFORM arguments do not get properly expanded when the form +;;; is a constant variable. +;;; +;;; (defclass a () ((a :initform most-positive-fixnum))) +;;; (slot-value (make-instance a) 'a) => most-positive-fixnum +;;; +(test mop.0009.defclass-initform + (is (equal + (loop for quoting in '(nil t) + collect + (loop for f in '(most-positive-fixnum #1=#.(lambda () 1) 12 "hola" :a t nil) + collect (prog1 (eval `(progn + (defclass foo () + ((a :initform ,(if quoting (list 'quote f) f)))) + (slot-value (make-instance 'foo) 'a))) + (cl-test::delete-class 'foo)))) + '((#.most-positive-fixnum #1# 12 "hola" :a t nil) + (most-positive-fixnum #1# 12 "hola" :a t nil))))) + + +;; Test MOP dependents +(defclass mop-dependent-object () + ((log :initform nil :initarg :log :accessor mop-dependent-object-log))) + +(defmethod clos:update-dependent ((object t) (dep mop-dependent-object) &rest initargs) + (push (list* object initargs) (mop-dependent-object-log dep))) + +;;; Date: 23/04/2012 +;;; Description: +;;; +;;; ADD-DEPENDENT uses pushnew +;;; +(test mop.0010.gf-add/non-redundant + (is-true + (let* ((dep (make-instance 'mop-dependent-object)) + l1 l2) + (fmakunbound 'mop-gf-add/remove-dependent) + (defgeneric mop-gf-add/remove-dependent (a)) + (let ((f #'mop-gf-add/remove-dependent)) + (clos:add-dependent f dep) + (setf l1 (clos::generic-function-dependents f)) + (clos:add-dependent f dep) + (setf l2 (clos::generic-function-dependents f)) + (and (eq l1 l2) + (equalp l1 (list dep))))))) + +;;; Date: 23/04/2012 +;;; Description: +;;; +;;; Generic functions have dependents and are activated +;;; +(test mop.0011.gf-add/remove-dependent + (let* ((dep (make-instance 'mop-dependent-object)) + l1 l2 l3 l4 l5 l6) + (fmakunbound 'mop-gf-add/remove-dependent) + (defgeneric mop-gf-add/remove-dependent (a)) + (let ((f #'mop-gf-add/remove-dependent) + m1 m2) + ;; + ;; * ADD-DEPENDENT registers the object with the function + ;; + (clos:add-dependent f dep) + (setf l1 (clos::generic-function-dependents f)) + ;; + ;; * ADD-METHOD invokes UPDATE-DEPENDENT + ;; + (defmethod mop-gf-add/remove-dependent ((a number)) (cos a)) + (setf l2 (mop-dependent-object-log dep)) + ;; + ;; * REMOVE-METHOD invokes UPDATE-DEPENDENT + ;; + (setf m1 (first (compute-applicable-methods f (list 1.0)))) + (remove-method f m1) + (setf l3 (mop-dependent-object-log dep)) + ;; + ;; * REMOVE-DEPENDENT eliminates all dependencies + ;; + (clos:remove-dependent f dep) + (setf l4 (clos::generic-function-dependents f)) + ;; + ;; * ADD-METHOD invokes UPDATE-DEPENDENT but has no effect + ;; + (defmethod mop-gf-add/remove-dependent ((a symbol)) a) + (setf l5 (mop-dependent-object-log dep)) + ;; + ;; * REMOVE-METHOD invokes UPDATE-DEPENDENT but has no effect + ;; + (setf m2 (first (compute-applicable-methods f (list 'a)))) + (setf l6 (mop-dependent-object-log dep)) + ;; the first call to defmethod adds two entries: one for the + ;; add-method and another one for a reinitialize-instance with + ;; the name of the function + (is-true (equalp l1 (list dep))) + (is-true (eq l2 (rest l3))) + (is-true (equalp l3 + (list (list f 'remove-method m1) + (list f 'add-method m1) + (list f)))) + (is-true (null l4)) + (is-true (eq l5 l3)) + (is-true (eq l6 l3))))) + +;;; Date: 23/04/2012 +;;; Description: +;;; +;;; ADD-DEPENDENT does not duplicate elements +;;; +(test mop.0012.class-add/remove-dependent + (let* ((dep (make-instance 'mop-dependent-object)) + l1 l2) + (when (find-class 'mop-class-add/remove-dependent nil) + (setf (class-name (find-class 'mop-class-add/remove-dependent)) nil)) + (defclass mop-class-add/remove-dependent () ()) + (let ((f (find-class 'mop-class-add/remove-dependent))) + (clos:add-dependent f dep) + (setf l1 (clos::class-dependents f)) + (clos:add-dependent f dep) + (setf l2 (clos::class-dependents f)) + (is-true + (and (eq l1 l2) + (equalp l1 (list dep))))))) + +;;; Date: 23/04/2012 +;;; Description: +;;; +;;; Standard classes have dependents and are activated +;;; +(test mop.0013.class-add/remove-dependent + (let* ((dep (make-instance 'mop-dependent-object)) + l1 l2 l3 l4 l5) + (when (find-class 'mop-class-add/remove-dependent nil) + (setf (class-name (find-class 'mop-class-add/remove-dependent)) nil)) + (defclass mop-class-add/remove-dependent () ()) + (let ((f (find-class 'mop-class-add/remove-dependent))) + ;; + ;; * ADD-DEPENDENT registers the object with the class + ;; + (clos:add-dependent f dep) + (setf l1 (clos::class-dependents f)) + ;; + ;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT + ;; + (defclass mop-class-add/remove-dependent () (a)) + (setf l2 (clos::class-dependents f)) + (setf l3 (mop-dependent-object-log dep)) + ;; + ;; * REMOVE-DEPENDENT eliminates object from list + ;; + (clos:remove-dependent f dep) + (setf l4 (clos::class-dependents f)) + ;; + ;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT without effect + ;; + (defclass mop-class-add/remove-dependent () ()) + (setf l5 (mop-dependent-object-log dep)) + ;; + ;; the first call to defclass adds one entry with the reinitialization + ;; of the class both in name and list of slots + (is-true + (and (equalp l1 (list dep)) + (eq l1 l2) + (equalp l3 + (list (list f :name 'mop-class-add/remove-dependent + :direct-superclasses nil + :direct-slots '((:name a))))) + (null l4) + (eq l5 l3)))))) + + +;; Test MOP dispatch + +;;; Date: 23/04/2012 +;;; Description: +;;; +;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES works with one and +;;; two methods and no EQL. +;;; +(test mop.0014.c-a-m-u-c-two-methods + (fmakunbound 'mop-fn) + (defgeneric mop-fn (a) + (:method ((a number)) (cos a)) + (:method ((a symbol)) a)) + (let ((m1 (compute-applicable-methods #'mop-fn (list 1.0))) + (m2 (compute-applicable-methods #'mop-fn (list 'a)))) + (flet ((f (class) + (multiple-value-list (clos:compute-applicable-methods-using-classes + #'mop-fn (list (find-class class)))))) + (is-true + (and (equalp (f 'number) (list m1 t)) + (equalp (f 'real) (list m1 t)) + (equalp (f 'symbol) (list m2 t)) + (equalp (f 'cons) '(nil t))))))) + +;;; Date: 23/04/2012 +;;; Description: +;;; +;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES fails with EQL +;;; specializers when one of the specializers is covered by the +;;; classes. +;;; +(test mop.0015.-c-a-m-u-c-fails-with-eql + (fmakunbound 'mop-fn) + (defgeneric mop-fn (a) + (:method ((a (eql 1))) 1) + (:method ((a (eql 'a))) 2) + (:method ((a float)) 3)) + (let ((m1 (compute-applicable-methods #'mop-fn (list 1))) + (m2 (compute-applicable-methods #'mop-fn (list 'a))) + (m3 (compute-applicable-methods #'mop-fn (list 1.0)))) + (flet ((f (class) + (multiple-value-list (clos:compute-applicable-methods-using-classes + #'mop-fn (list (find-class class)))))) + (is-true + (and (equalp (f 'integer) (list nil nil)) + (equalp (f 'number) (list nil nil)) + (equalp (f 'symbol) (list nil nil)) + (equalp (f 'float) (list m3 t)) + (= (length m1) 1) + (= (length m2) 1) + (= (length m3) 1)))))) + +;;; Date: 24/04/2012 +;;; Description: +;;; +;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked and honored by ECL. +;;; +(test mop.0016.discriminator + (fmakunbound 'foo) + (defclass my-generic-function (standard-generic-function) + ()) + (defmethod clos:compute-discriminating-function ((gf my-generic-function)) + ;; We compute the invocaions of c-d-f. Note that it is invoked + ;; quite often -- we could probably optimize this. + #'(lambda (&rest args) + args)) + (defgeneric foo (a) + (:generic-function-class my-generic-function)) + (is (equal '(2) + (unwind-protect + (foo 2) + (fmakunbound 'foo))))) + +;;; Date: 24/04/2012 +;;; Description: +;;; +;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked on ADD-METHOD, REMOVE-METHOD, +;;; DEFGENERIC, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE acting on +;;; generic functions. +;;; +(ext:with-clean-symbols (*mop-discriminator-recomputation* foo my-generic-function) + (test mop.0017.discriminator-recomputation + (defparameter *mop-discriminator-recomputation* 0) + (defclass my-generic-function (standard-generic-function) ()) + (defmethod clos:compute-discriminating-function ((gf my-generic-function)) + ;; We compute the invocaions of c-d-f. Note that it is invoked + ;; quite often -- we could probably optimize this. + (incf *mop-discriminator-recomputation*) + (call-next-method)) + (is-true + (and (progn + (setf *mop-discriminator-recomputation* 0) + (eval '(defgeneric foo (a) + (:generic-function-class my-generic-function))) + (plusp *mop-discriminator-recomputation* )) + (typep #'foo 'my-generic-function) + (progn + (setf *mop-discriminator-recomputation* 0) + (eval '(defmethod foo ((a number)) (print a))) + (plusp *mop-discriminator-recomputation*)) + (progn + (setf *mop-discriminator-recomputation* 0) + (eval '(remove-method #'foo (first (compute-applicable-methods + #'foo + (list 1.0))))) + (plusp *mop-discriminator-recomputation*)))))) + +;;; Date: 24/04/2012 +;;; Description: +;;; +;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS-USING-CLASSES for +;;; user-defined generic function classes. +;;; +(ext:with-clean-symbols (*mop-dispatch-used* my-generic-function foo) + (test mop.0018.c-a-m-u-c-is-honored + (defparameter *mop-dispatch-used* 0) + (defclass my-generic-function (standard-generic-function) ()) + (defmethod clos:compute-applicable-methods-using-classes + ((gf my-generic-function) classes) + (incf *mop-dispatch-used*) + (call-next-method)) + (defgeneric foo (a) + (:generic-function-class my-generic-function) + (:method ((a number)) (cos 1.0))) + (is-true + (and (zerop *mop-dispatch-used*) + (progn (foo 1.0) (plusp *mop-dispatch-used*)))))) + +;;; Date: 24/04/2012 +;;; Description: +;;; +;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS for +;;; user-defined generic function classes. +;;; +(ext:with-clean-symbols (*mop-dispatch-used* my-generic-function foo) + (test mop.0019.compute-applicable-methods-is-honored + (defparameter *mop-dispatch-used* 0) + (defclass my-generic-function (standard-generic-function) ()) + (defmethod clos:compute-applicable-methods-using-classes + ((gf my-generic-function) classes) + (incf *mop-dispatch-used*) + (values nil nil)) + (defmethod compute-applicable-methods + ((gf my-generic-function) args) + (incf *mop-dispatch-used*) + (call-next-method)) + (defgeneric foo (a) + (:generic-function-class my-generic-function) + (:method ((a number)) (cos 1.0))) + (is-true + (and (zerop *mop-dispatch-used*) + (progn (foo 1.0) (= *mop-dispatch-used* 2)))))) + +;;; From: Pascal Costanza +;;; Description: +;;; +;;; sort-applicable-methods is invoked by two methods and one +;;; invocation triggers a disambiguation error: +;;; +;;; Condition of type: SIMPLE-ERROR +;;; The type specifiers # and # can not be disambiguated with respect to the argument specializer: # +(ext:with-clean-symbols (a b c f) + (defclass a () ()) + (defclass b () ()) + (defclass c (a b) ()) + (defmethod f ((o a))) + (defmethod f ((o b))) + (test mop.0020.c-a-m-disambiguation + (finishes + (clos:compute-applicable-methods-using-classes + #'f (list (find-class 'c)))))) + + diff --git a/src/tests/regressions/mixed.lsp b/src/tests/regressions/mixed.lsp new file mode 100644 index 000000000..2845b8c05 --- /dev/null +++ b/src/tests/regressions/mixed.lsp @@ -0,0 +1,178 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Contains: Various regression tests for ECL + +(in-package :cl-test) + +(suite 'regressions/mixed) + + +;;; (EXT:PACKAGE-LOCK) returned the wrong value. +;;; Fixed in 77a267c7e42860affac8eddfcddb8e81fccd44e5 + +(test mix.0001.package-lock + ;; Don't know the first state + (ext:package-lock "CL-USER" nil) + (is-false (ext:package-lock "CL-USER" t)) + (is-true (ext:package-lock "CL-USER" nil)) + (is-false (ext:package-lock "CL-USER" nil))) + + +;; Bugs from sourceforge + +(test mix.0002.mvb-not-evaled + (is (eq :ok (block nil + (tagbody + (return (multiple-value-bind () + (go :fail) :bad)) + :fail + (return :ok)))))) + + + +(ext:with-clean-symbols (foo) + (declaim (ftype (function (cons) t) foo) + (ftype (function (t cons) t) (setf foo))) + + (defun foo (cons) + (first cons)) + + (defun (setf foo) (value cons) + (setf (first cons) value)) + + (test mix.0003.declaim-type + (let ((*bar* (cons 'x 'y))) + (is (eq (foo *bar*) 'x)) + (is (eq (setf (foo *bar*) 'z) 'z) "signals on error: +;; Z is not of type CONS. +;; [Condition of type TYPE-ERROR]")))) + + + +(test mix.0004.style-warning-argument-order + (let ((warning nil)) + (is (eq :ok + (handler-bind + ((style-warning + (lambda (c) + (format t "got style-warning: ~s~%" c) + (setf warning c)))) + (block nil + (tagbody + (return (multiple-value-bind () (go :fail) :bad)) + :fail + (return :ok)))))) + (is-false warning))) + +(test mix.0005.write-hash-readable + (is (= (hash-table-count + (read-from-string + (write-to-string (make-hash-table) + :readably t)))))) + +(test mix.0006.find-package + (is + (let ((string ":cl-user")) + (find-package + (let ((*package* (find-package :cl))) + (read-from-string string))))) + (is + (let ((string ":cl-user")) + (let ((*package* (find-package :cl))) + (find-package + (read-from-string string)))))) + + + +;;; Date: 2016-05-21 (Masataro Asai) +;;; Description: +;;; +;;; RESTART-CASE investigates the body in an incorrect manner, +;;; then remove the arguments to SIGNAL, which cause the slots of +;;; the conditions to be not set properly. +;;; +;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/247 +;;; +(ext:with-clean-symbols (x) + (define-condition x () ((y :initarg :y))) + (test mix.0007.restart-case-body + (is-false (handler-bind ((x (lambda (c) (slot-value c 'y)))) + (restart-case + (signal 'x :y 1)))))) + + +;;; Date: 2016-04-21 (Juraj) +;;; Fixed: 2016-06-21 (Daniel Kochmański) +;;; Description: +;;; +;;; Trace did not respect *TRACE-OUTPUT*. +;;; +;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/236 +;;; +(ext:with-clean-symbols (fact) + (defun fact (n) (if (zerop n) :boom (fact (1- n)))) + (test mix.0008.trace-output + (is-eql 0 + (length + (with-output-to-string (*trace-output*) + (trace fact) + (fact 3) + (untrace fact) + *trace-output*))))) + + +;;;; Author: Daniel Kochmański +;;;; Created: 2015-09-21 +;;;; Contains: Random state tests +#+ (or) +(def-test mix.0009.random-states (:compile-at :definition-time) + (is (numberp (random 18)) "Trivial case") + (is (numberp (random 18 #$1)) + "Check if we can generate random number from a read random ~ + state") + (is (numberp (random 18 (make-random-state))) + "Check if we can generate random number from a new random ~ + state") + (is (numberp (random 18 (make-random-state #$1))) + "Check if we can copy use copied random state from reader") + (is (= (random 18 #$1) + (random 18 #$1) + (random 18 #$1)) + "Check if the same seed produces the same result") + (is (let ((*print-readably* t) + (rs (make-random-state #$1))) + (equalp + (format nil "~S" #$1) + (format nil "~S" rs))) + "Check if we get the same table from the same seed") + (is (let* ((*print-readably* t) + (rs (make-random-state #$1)) + (rs-read (read-from-string + (format nil "~S" rs)))) + (equalp + (format nil "~S" rs-read) + (format nil "~S" rs))) + "Check if we can read back the random state")) + + +;;; Date: 2016-08-04 (jd) +;;; Fixed: 2016-08-04 (jd) +;;; Description: +;;; +;;; file-stream-fd caused internal error if fed with non-file ANSI +;;; stream +;;; +;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/271 +;;; +(test mix.0010.file-stream-fd + ;; We check the second one only if first test passes. Second test + ;; caused internal error of ECL and crashed the process preventing + ;; further tests, so we perform it only on versions after the fix. + (if (signals simple-type-error (ext:file-stream-fd "")) + (signals simple-type-error (ext:file-stream-fd + (make-string-output-stream))) + (fail (ext:file-stream-fd (make-string-output-stream)) + "Not-file stream would cause internal error on this ECL (skipped)"))) + + diff --git a/src/tests/regressions/tests/multiprocessing.lsp b/src/tests/regressions/multiprocessing.lsp similarity index 62% rename from src/tests/regressions/tests/multiprocessing.lsp rename to src/tests/regressions/multiprocessing.lsp index ca2288b19..20d6b6291 100644 --- a/src/tests/regressions/tests/multiprocessing.lsp +++ b/src/tests/regressions/multiprocessing.lsp @@ -7,6 +7,8 @@ (in-package :cl-test) +(suite 'regressions/mp) + ;; Auxiliary routines for multithreaded tests @@ -39,9 +41,10 @@ creating stray processes." (let ((all-processes (gensym)) (output (gensym)) (leftover (gensym))) - `(deftest ,name - (mp-test-run #'(lambda () ,body)) - ,expected-value))) + `(test ,name + (is-equal + (mp-test-run #'(lambda () ,body)) + ,expected-value)))) ;; Locks @@ -54,7 +57,7 @@ creating stray processes." ;;; When a WITH-LOCK is interrupted, it is not able to release ;;; the resulting lock and an error is signaled. ;;; -(def-mp-test mp-0001-with-lock +(test mp-0001-with-lock (let ((flag t) (lock (mp:make-lock :name "mp-0001-with-lock" :recursive nil))) (mp:with-lock (lock) @@ -76,38 +79,35 @@ creating stray processes." ;; and the process should gracefully quit, without ;; signalling any serious condition (and (progn (sleep 1) - (mp:process-kill background-process)) + (is (mp:process-kill background-process))) (progn (sleep 1) - (not (mp:process-active-p background-process))) - (eq flag 1) - t)))) - t) + (is (not (mp:process-active-p background-process)))) + (is (eq flag 1))))))) ;; Semaphores ;;; Date: 14/04/2012 ;;; Ensure that at creation name and counter are set -(deftest sem-make-and-counter - (loop with name = "sem-make-and-counter" - for count from 0 to 10 - for sem = (mp:make-semaphore :name name :count count) - always (and (eq (mp:semaphore-name sem) name) - (= (mp:semaphore-count sem) count) - (zerop (mp:semaphore-wait-count sem)))) - t) +(test sem-make-and-counter + (is (loop with name = "sem-make-and-counter" + for count from 0 to 10 + for sem = (mp:make-semaphore :name name :count count) + always (and (eq (mp:semaphore-name sem) name) + (= (mp:semaphore-count sem) count) + (zerop (mp:semaphore-wait-count sem)))))) ;;; Date: 14/04/2012 ;;; Ensure that signal changes the counter by the specified amount -(deftest sem-signal-semaphore-count - (loop with name = "sem-signal-semaphore-count" - for count from 0 to 10 - always (loop for delta from 0 to 10 - for sem = (mp:make-semaphore :name name :count count) - always (and (= (mp:semaphore-count sem) count) - (null (mp:signal-semaphore sem delta)) - (= (mp:semaphore-count sem ) (+ count delta))))) - t) +(test sem-signal-semaphore-count + (is + (loop with name = "sem-signal-semaphore-count" + for count from 0 to 10 + always (loop for delta from 0 to 10 + for sem = (mp:make-semaphore :name name :count count) + always (and (= (mp:semaphore-count sem) count) + (null (mp:signal-semaphore sem delta)) + (= (mp:semaphore-count sem ) (+ count delta))))))) ;;; Date: 14/04/2012 ;;; A semaphore with a count of zero blocks a process @@ -127,51 +127,51 @@ creating stray processes." ;;; Date: 14/04/2012 ;;; We can signal multiple processes -(def-mp-test sem-signal-n-processes - (loop for count from 1 upto 10 always - (let* ((counter 0) - (lock (mp:make-lock :name "sem-signal-n-processes")) - (sem (mp:make-semaphore :name "sem-signal-n-processs")) - (all-process - (loop for i from 1 upto count - collect (mp:process-run-function - "sem-signal-n-processes" - #'(lambda () - (mp:wait-on-semaphore sem) - (mp:with-lock (lock) (incf counter))))))) - (and (zerop counter) - (every #'mp:process-active-p all-process) - (= (mp:semaphore-wait-count sem) count) - (progn (mp:signal-semaphore sem count) (sleep 0.2) - (= counter count)) - (= (mp:semaphore-count sem) 0)))) - t) +(test sem-signal-n-processes + (loop for count from 1 upto 10 always + (let* ((counter 0) + (lock (mp:make-lock :name "sem-signal-n-processes")) + (sem (mp:make-semaphore :name "sem-signal-n-processs")) + (all-process + (loop for i from 1 upto count + collect (mp:process-run-function + "sem-signal-n-processes" + #'(lambda () + (mp:wait-on-semaphore sem) + (mp:with-lock (lock) (incf counter))))))) + (and (is (zerop counter)) + (is (every #'mp:process-active-p all-process)) + (is (= (mp:semaphore-wait-count sem) count)) + (is (progn (mp:signal-semaphore sem count) + (sleep 0.2) + (= counter count))) + (is (= (mp:semaphore-count sem) 0)))))) ;;; Date: 14/04/2012 ;;; When we signal N processes and N+M are waiting, only N awake -(def-mp-test sem-signal-only-n-processes - (loop for m from 1 upto 3 always - (loop for n from 1 upto 4 always - (let* ((counter 0) - (lock (mp:make-lock :name "sem-signal-n-processes")) - (sem (mp:make-semaphore :name "sem-signal-n-processs")) - (all-process - (loop for i from 1 upto (+ n m) - collect (mp:process-run-function - "sem-signal-n-processes" - #'(lambda () - (mp:wait-on-semaphore sem) - (mp:with-lock (lock) (incf counter))))))) - (and (zerop counter) - (every #'mp:process-active-p all-process) - (= (mp:semaphore-wait-count sem) (+ m n)) - (progn (mp:signal-semaphore sem n) (sleep 0.02) - (= counter n)) - (= (mp:semaphore-wait-count sem) m) - (progn (mp:signal-semaphore sem m) (sleep 0.02) - (= counter (+ n m))) - )))) - t) +(test sem-signal-only-n-processes + (loop for m from 1 upto 3 always + (loop for n from 1 upto 4 always + (let* ((counter 0) + (lock (mp:make-lock :name "sem-signal-n-processes")) + (sem (mp:make-semaphore :name "sem-signal-n-processs")) + (all-process + (loop for i from 1 upto (+ n m) + collect (mp:process-run-function + "sem-signal-n-processes" + #'(lambda () + (mp:wait-on-semaphore sem) + (mp:with-lock (lock) (incf counter))))))) + (and (is (zerop counter)) + (is (every #'mp:process-active-p all-process)) + (is (= (mp:semaphore-wait-count sem) (+ m n))) + (is (progn (mp:signal-semaphore sem n) + (sleep 0.02) + (= counter n))) + (is (= (mp:semaphore-wait-count sem) m)) + (is (progn (mp:signal-semaphore sem m) + (sleep 0.02) + (= counter (+ n m))))))))) ;;; Date: 14/04/2012 ;;; It is possible to kill processes waiting for a semaphore. @@ -220,41 +220,39 @@ creating stray processes." ;;; killed, but the process must still be in the queue for the semaphore ;;; to awake it. The way we solve this is by intercepting the kill signal. ;;; -(def-mp-test sem-interrupted-resignals - (let* ((sem (mp:make-semaphore :name "sem-interrupted-resignals")) - (flag1 nil) - (flag2 nil) - (process1 (mp:process-run-function - "sem-interrupted-resignals" - #'(lambda () - (unwind-protect - (mp:wait-on-semaphore sem) - (sleep 4) - (setf flag1 t) - )))) - (process2 (mp:process-run-function - "sem-interrupted-resignals" - #'(lambda () - (mp:wait-on-semaphore sem) - (setf flag2 t))))) - (sleep 0.2) - (and (= (mp:semaphore-wait-count sem) 2) - (mp:process-active-p process1) - (mp:process-active-p process2) - ;; We kill the process but ensure it is still running - (progn (mp:process-kill process1) - (mp:process-active-p process1)) - (null flag1) - ;; ... and in the queue - (= (mp:semaphore-wait-count sem) 2) - ;; We awake it and it should awake the other one - (progn (format t "~%;;; Signaling semaphore") - (mp:signal-semaphore sem) - (sleep 1) - (zerop (mp:semaphore-wait-count sem))) - flag2 - t)) - t) +(test sem-interrupted-resignals + (let* ((sem (mp:make-semaphore :name "sem-interrupted-resignals")) + (flag1 nil) + (flag2 nil) + (process1 (mp:process-run-function + "sem-interrupted-resignals" + #'(lambda () + (unwind-protect + (mp:wait-on-semaphore sem) + (sleep 4) + (setf flag1 t) + )))) + (process2 (mp:process-run-function + "sem-interrupted-resignals" + #'(lambda () + (mp:wait-on-semaphore sem) + (setf flag2 t))))) + (sleep 0.2) + (and (is (= (mp:semaphore-wait-count sem) 2)) + (is (mp:process-active-p process1)) + (is (mp:process-active-p process2)) + ;; We kill the process but ensure it is still running + (is (progn (mp:process-kill process1) + (mp:process-active-p process1))) + (is (null flag1)) + ;; ... and in the queue + (is (= (mp:semaphore-wait-count sem) 2)) + ;; We awake it and it should awake the other one + (is (progn (format t "~%;;; Signaling semaphore") + (mp:signal-semaphore sem) + (sleep 1) + (zerop (mp:semaphore-wait-count sem)))) + (is flag2)))) ;;; Date: 14/04/2012 ;;; 1 producer and N consumers, non-blocking, because the initial count @@ -310,37 +308,35 @@ creating stray processes." ;;; Date: 12/04/2012 ;;; Non-recursive mutexes should signal an error when they ;;; cannot be relocked. -(deftest mutex-001-recursive-error - (let* ((mutex (mp:make-lock :name 'mutex-001-recursive-error))) - (and - (mp:get-lock mutex) - (eq (mp:lock-owner mutex) mp:*current-process*) - (handler-case - (progn (mp:get-lock mutex) nil) - (error (c) t)) - (mp:giveup-lock mutex) - (null (mp:lock-owner mutex)) - (zerop (mp:lock-count mutex)) - t)) - t) +(test mutex-001-recursive-error + (is-true + (let* ((mutex (mp:make-lock :name 'mutex-001-recursive-error))) + (and + (mp:get-lock mutex) + (eq (mp:lock-owner mutex) mp:*current-process*) + (handler-case + (progn (mp:get-lock mutex) nil) + (error (c) t)) + (mp:giveup-lock mutex) + (null (mp:lock-owner mutex)) + (zerop (mp:lock-count mutex)))))) ;;; Date: 12/04/2012 ;;; Recursive locks increase the counter. -(deftest mutex-002-recursive-count - (let* ((mutex (mp:make-lock :name 'mutex-002-recursive-count :recursive t))) - (and - (loop for i from 1 upto 10 - always (and (mp:get-lock mutex) - (= (mp:lock-count mutex) i) - (eq (mp:lock-owner mutex) mp:*current-process*))) - (loop for i from 9 downto 0 - always (and (eq (mp:lock-owner mutex) mp:*current-process*) - (mp:giveup-lock mutex) - (= (mp:lock-count mutex) i))) - (null (mp:lock-owner mutex)) - (zerop (mp:lock-count mutex)) - t)) - t) +(test mutex-002-recursive-count + (is-true + (let* ((mutex (mp:make-lock :name 'mutex-002-recursive-count :recursive t))) + (and + (loop for i from 1 upto 10 + always (and (mp:get-lock mutex) + (= (mp:lock-count mutex) i) + (eq (mp:lock-owner mutex) mp:*current-process*))) + (loop for i from 9 downto 0 + always (and (eq (mp:lock-owner mutex) mp:*current-process*) + (mp:giveup-lock mutex) + (= (mp:lock-count mutex) i))) + (null (mp:lock-owner mutex)) + (zerop (mp:lock-count mutex)))))) ;;; Date: 12/04/2012 @@ -415,36 +411,34 @@ creating stray processes." ;;; Date: 14/04/2012 ;;; Ensure that at creation name and counter are set, and mailbox is empty. -(deftest mailbox-make-and-counter - (loop with name = "mbox-make-and-counter" - for count from 4 to 63 - for mbox = (mp:make-mailbox :name name :count count) - always (and (eq (mp:mailbox-name mbox) name) - (>= (mp:mailbox-count mbox) count) - (mp:mailbox-empty-p mbox) - t)) - t) +(test mailbox-make-and-counter + (is + (loop with name = "mbox-make-and-counter" + for count from 4 to 63 + for mbox = (mp:make-mailbox :name name :count count) + always (and (eq (mp:mailbox-name mbox) name) + (>= (mp:mailbox-count mbox) count) + (mp:mailbox-empty-p mbox))))) ;;; Date: 14/04/2012 ;;; Ensure that the mailbox works in a nonblocking fashion (when the ;;; number of messages < mailbox size in a single producer and single ;;; consumer setting. We do not need to create new threads for this. -(deftest mbox-mailbox-nonblocking-io-1-to-1 - (loop with count = 30 - with name = "mbox-mailbox-nonblocking-io-1-to-1" - with mbox = (mp:make-mailbox :name name :count count) - for l from 1 to 10 - for messages = (loop for i from 1 to l - do (mp:mailbox-send mbox i) - collect i) - always - (and (not (mp:mailbox-empty-p mbox)) - (equalp (loop for i from 1 to l - collect (mp:mailbox-read mbox)) - messages) - (mp:mailbox-empty-p mbox) - t)) - t) +(test mbox-mailbox-nonblocking-io-1-to-1 + (is + (loop with count = 30 + with name = "mbox-mailbox-nonblocking-io-1-to-1" + with mbox = (mp:make-mailbox :name name :count count) + for l from 1 to 10 + for messages = (loop for i from 1 to l + do (mp:mailbox-send mbox i) + collect i) + always + (and (not (mp:mailbox-empty-p mbox)) + (equalp (loop for i from 1 to l + collect (mp:mailbox-read mbox)) + messages) + (mp:mailbox-empty-p mbox))))) ;;; Date: 14/04/2012 ;;; The mailbox blocks a process when it saturates the write queue. @@ -501,48 +495,46 @@ creating stray processes." ;;; Date: 14/04/2012 ;;; 1 producer and N consumer, but they do not block, because the ;;; queue is large enough and pre-filled with messages -(def-mp-test mbox-1-to-n-non-blocking - (loop with lock = (mp:make-lock :name "mbox-1-to-n-communication") - for n from 1 to 10 - for m = (round 128 n) - for length = (* n m) - for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length) - for flags = (make-array length :initial-element nil) - for aux = (loop for i from 0 below length - do (mp:mailbox-send mbox i)) - for producers = (loop for i from 0 below n - do (mp:process-run-function - "mbox-1-to-n-consumer" - #'(lambda () - (loop for i from 0 below m - for msg = (mp:mailbox-read mbox) - do (setf (aref flags msg) t))))) - do (sleep 0.1) - always (and (every #'identity flags) - (mp:mailbox-empty-p mbox))) - t) +(test mbox-1-to-n-non-blocking + (loop with lock = (mp:make-lock :name "mbox-1-to-n-communication") + for n from 1 to 10 + for m = (round 128 n) + for length = (* n m) + for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length) + for flags = (make-array length :initial-element nil) + for aux = (loop for i from 0 below length + do (mp:mailbox-send mbox i)) + for producers = (loop for i from 0 below n + do (mp:process-run-function + "mbox-1-to-n-consumer" + #'(lambda () + (loop for i from 0 below m + for msg = (mp:mailbox-read mbox) + do (setf (aref flags msg) t))))) + do (sleep 0.1) + always (and (is (every #'identity flags)) + (is (mp:mailbox-empty-p mbox))))) ;;; Date: 14/04/2012 ;;; 1 producer and N consumers, which block, because the producer ;;; is started _after_ them and is slower. -(def-mp-test mbox-1-to-n-blocking - (loop for n from 1 to 10 - for m = (round 10000 n) - for length = (* n m) - for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length) - for flags = (make-array length :initial-element nil) - for producers = (loop for i from 0 below n - do (mp:process-run-function - "mbox-1-to-n-consumer" - #'(lambda () - (loop for i from 0 below m - for msg = (mp:mailbox-read mbox) - do (setf (aref flags msg) t))))) - do (loop for i from 0 below length - do (mp:mailbox-send mbox i)) - do (sleep 0.1) - always (and (every #'identity flags) - (mp:mailbox-empty-p mbox))) - t) +(test mbox-1-to-n-blocking + (loop for n from 1 to 10 + for m = (round 10000 n) + for length = (* n m) + for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length) + for flags = (make-array length :initial-element nil) + for producers = (loop for i from 0 below n + do (mp:process-run-function + "mbox-1-to-n-consumer" + #'(lambda () + (loop for i from 0 below m + for msg = (mp:mailbox-read mbox) + do (setf (aref flags msg) t))))) + do (loop for i from 0 below length + do (mp:mailbox-send mbox i)) + do (sleep 0.1) + always (and (is (every #'identity flags)) + (is (mp:mailbox-empty-p mbox))))) diff --git a/src/tests/regressions/tests/compiler.lsp b/src/tests/regressions/tests/compiler.lsp deleted file mode 100644 index f1d9a0bee..000000000 --- a/src/tests/regressions/tests/compiler.lsp +++ /dev/null @@ -1,1183 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Juan Jose Garcia-Ripoll -;;;; Created: Fri Apr 14 11:13:17 CEST 2006 -;;;; Contains: Compiler regression tests - -(in-package :cl-test) - - -;; cl-001 - -;;; Date: 09/05/2006 -;;; From: Brian Spilsbury -;;; Fixed: 20/05/2006 (Brian Spilsbury) -;;; Description: -;;; -;;; (DEFPACKAGE "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T")) -;;; fails to import symbol NIL because IMPORT is invoked as -;;; (IMPORT NIL (find-package "CL")), which does not import -;;; any symbol. -;;; - -(deftest compiler.0001.import - (progn - (defpackage "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T")) - (prog1 (multiple-value-list (find-symbol "NIL" (find-package "FOO"))) - (delete-package "FOO"))) - (NIL :INTERNAL)) - -;;; Date: 09/05/2006 -;;; From: Brian Spilsbury -;;; Fixed: 20/05/2006 (Brian Spilsbury) -;;; Description: -;;; -;;; Compiled FLET forms failed to shadow global macro definitions, if not -;;; for the compiler, at least for MACRO-FUNCTION and MACROEXPAND[-1] -;;; - -(deftest compiler.0002.macro-shadow - (progn - (with-compiler ("aux-cl-0002.lsp") - '(defmacro foo () 2) - '(defmacro test (symbol &environment env) - (and (macro-function symbol env) t)) - '(defun doit () (flet ((foo () 1)) (test foo)))) - (load "aux-cl-0002") - (delete-file "aux-cl-0002.lsp") - (delete-file (compile-file-pathname "aux-cl-0002" :type :fas)) - (prog1 - (doit) - (fmakunbound 'doit) - (fmakunbound 'test) - (fmakunbound 'foo))) - NIL) - -;;; -;;; Fixed: 14/06/2006 (juanjo) -;;; Description: -;;; -;;; APROPOS, APROPOS-LIST and HELP* are case sensitive. -;;; - -(deftest compiler.0003.apropos - (and (equal (apropos-list "bin") - (apropos-list "bin")) - t) - t) - -;;; Date: 08/07/2006 (Dave Roberts) -;;; Fixed: 02/08/2006 (juanjo) -;;; Description: -;;; -;;; SLIME traps when invoking DESCRIBE. Reason is that STREAMP breaks on -;;; Gray streams. -;;; - -(deftest compiler.0004.streamp - (streamp (make-instance 'gray:fundamental-stream)) - t) - -;;; Date: 02/08/2006 (juanjo) -;;; Description: -;;; -;;; There is a problem with SUBTYPEP and type STREAM -;;; - -(deftest compiler.0005.subtypep-stream - (subtypep (find-class 'gray:fundamental-stream) 'stream) - t t) - -;;; Date: 09/07/2006 (Tim S) -;;; Fixed: 09/07/2006 (Tim S) -;;; Description: -;;; -;;; ENOUGH-NAMESTRING provided too large pathnames even when the -;;; pathname was a subdirectory of the default pathname. -;;; -;;; Date: 31/12/2006 (Richard M. Kreuter) -;;; Fixed: 5/1/2007 (Juanjo) -;;; Description: -;;; ENOUGH-NAMESTRING does not simplify the pathname when the -;;; directory matches completely that of the default path. -;;; - -(defvar *enough-namestring_tests* - `(("/A/b/C/" - ("/A/b/C/drink-up.sot" - "/A/b/C/loozer/whiskey.sot" - "/A/b/C/loozer/whiskey" - "/A/b/whiskey.sot" - "/A/" - "whiskey.sot" - "loozer/whiskey.sot" - "C/loozer/whisky.sot" - "")) - ("A/b/C" ("A/b/C" "A/b/C/loozer" "b/C" "/A/b/C" "/A/" "")) - ("/" ("/A/b/C/drink-up.sot" "/A/b/C/" "/A/" "")) - ("" ("/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.sot" - "/A/b/C/loozer/whiskey" "/A/b/whiskey.sot" - "/A/" "whiskey.sot" "loozer/whiskey.sot" "C/loozer/whisky.sot")) - ("/A/*/C/drink-up.sot" - ("/A/*/C/drink-up.sot" "/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.*" - "/A/b/C/loozer/*.sot" "/A/**/whiskey.sot" "")) - ("/A/b/../c/d.sot" ("/A/b/../c/d.sot" "/A/b/../c/D/e.sot" - "/A/c/d.sot" "../c/d.sot" - "c/e/d.sot")))) - -(deftest compiler.0006.enough-namestring - (labels ((test-path (path defaults) - (let* ((e-ns (enough-namestring path defaults)) - (d1 (pathname-directory path)) - (d2 (pathname-directory defaults)) - (d3 (pathname-directory e-ns))) - (and (equalp (merge-pathnames e-ns defaults) - (merge-pathnames (parse-namestring path nil defaults) - defaults)) - ;; If directories concide, the "enough-namestring" - ;; removes the directory. But only if the pathname is - ;; absolute. - (not (and (equal (first d1) ':absolute) - (equalp d1 d2) - d3))))) - (test-default+paths (default+paths) - (let ((defaults (first default+paths)) - (paths (second default+paths))) - (every (lambda (path) - (handler-case (test-path path defaults) - (error (error) 'NIL))) - paths)))) - (every #'test-default+paths *enough-namestring_tests*)) - t) - -;;; Date: 10/08/2006 (Lars Brinkhoff) -;;; Fixed: 1/09/2006 (juanjo) -;;; Details: -;;; -;;; ADJUST-ARRAY must signal a type error when the value of :FILL-POINTER is -;;; not NIL and the adjustable array does not have a fill pointer -;;; - -(deftest compiler.0007.adjustable-array - (loop for fp in '(nil t) collect - (loop for i in '(t nil 0 1 2 3) collect - (and - (handler-case (adjust-array (make-array 3 :adjustable t :fill-pointer fp) 4 - :fill-pointer i) - (type-error (c) nil) - (error (c) t)) - t))) - ((nil t nil nil nil nil) (t t t t t t))) - -;;; Date: 09/10/2006 (Dustin Long) -;;; Fixed: 10/10/2006 -;;; Description: -;;; -;;; The namestring "." is improperly parsed, getting a file type of "" -;;; Additionally we found it more convenient to have the _last_ dot mark -;;; the file type, so that (pathname-type "foo.mpq.txt") => "txt" -;;; - -(deftest compiler.0008.parse-namestring - (loop for (namestring name type) in - '(("." "." NIL) (".." "." "") (".foo" ".foo" NIL) (".foo.mpq.txt" ".foo.mpq" "txt") - ("foo.txt" "foo" "txt") ("foo.mpq.txt" "foo.mpq" "txt")) - unless (let ((x (parse-namestring namestring))) - (and (equal name (pathname-name x)) - (equal type (pathname-type x)) - (equal '() (pathname-directory x)))) - collect namestring) - ()) - -;;; Date: 28/09/2006 -;;; Fixed: 10/10/2006 -;;; Description: -;;; -;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized -;;; The following code tests that at least three objects are finalized. -;;; -;;; Note: this test fails in multithreaded mode. GC takes too long! -(deftest compiler.0009.finalization - (let ((*all-tags* '())) - (declare (special *all-tags*)) - (flet ((custom-finalizer (tag) - #'(lambda (o) (push tag *all-tags*)))) - (let ((a '())) - (dotimes (i 5) - (let ((x (cons i i))) - (si::set-finalizer x (custom-finalizer i)) - (push x a)))) - (dotimes (j 100) - (dotimes (i 10000) - (cons 1.0 1.0)) - (si::gc t))) - (sort *all-tags* #'<)) - (0 1 2 3 4)) - - -;;; Date: 8/10/2006 (Dustin Long) -;;; Fixed: 10/10/2006 (Dustin Long) -;;; Description: -;;; -;;; Hash table iterators have to check that their argument is -;;; really a hash table. -;;; - -(deftest compiler.0010.hash-iterator - (loop for i in *mini-universe* - when (and (not (hash-table-p i)) - (handler-case (progn (loop for k being the hash-keys of i) t) - (error (c) nil))) - collect (type-of i)) - nil) - -;;; Date: 31/12/2006 (Richard M. Kreuter) -;;; Fixed: 5/1/2007 (Juanjo) -;;; Description: -;;; -;;; The keyword :BACK does not work as expected when creating pathnames -;;; and causes an error when at the beginning: (:RELATIVE :BACK) -;;; - -(deftest compiler.0011.make-pathname-with-back - (loop for i from 0 to 200 - with l = (random 10) - with x = (if (zerop l) 0 (random (1+ l))) - with y = (if (= l x) 0 (random (- l x))) - nconc (let* ((l (loop for i from 0 below l collect (princ-to-string i))) - (l2 (append (subseq l 0 y) '("break" :back) (subseq l y nil))) - (d1 (list* :absolute (subseq l2 0 x))) - (d2 (list* :relative (subseq l2 x nil))) - (d3 (list* :absolute l2)) - (d4 (list* :relative l2)) - (p1 (handler-case (make-pathname :directory d1) - (error (c) nil))) - (p2 (handler-case (make-pathname :directory d2) - (error (c) nil))) - (p3 (handler-case (make-pathname :directory d3) - (error (c) nil))) - (p4 (handler-case (make-pathname :directory d4) - (error (c) nil)))) - (if (and p1 p2 p3 p4 - ;; MERGE-PATHNAMES eliminates :BACK - (equalp l (rest (pathname-directory (merge-pathnames p2 p1)))) - ;; MAKE-PATHNAME does not eliminate :BACK - (not (equalp l (rest (pathname-directory (make-pathname :directory d3))))) - (not (equalp l (rest (pathname-directory (make-pathname :directory d4)))))) - nil - (list (list l d1 d2 d3 d4 l2 x y))))) - nil) - -;;; Date: 11/03/2007 (Fare) -;;; Fixed: 23/03/2007 (Juanjo) -;;; Description: -;;; -;;; COPY-READTABLE did not copy the entries of the "from" table -;;; when a second argument, i.e. a "destination" table was supplied. -;;; - -(deftest compiler.0012.copy-readtable - (let ((from-readtable (copy-readtable)) - (to-readtable (copy-readtable)) - (char-list '())) - (dotimes (i 20) - (let* ((code (+ 32 (random 70))) - (c (code-char code))) - (push c char-list) - (set-macro-character c - (eval `(lambda (str ch) ,code)) - nil - from-readtable))) - (copy-readtable from-readtable to-readtable) - (loop for c in char-list - unless (and (eql (char-code c) - (let ((*readtable* from-readtable)) - (read-from-string (string c)))) - (eq (get-macro-character c from-readtable) - (get-macro-character c to-readtable))) - collect c)) - nil) - -;;; Date: 05/01/2008 (Anonymous, SF bug report) -;;; Fixed: 06/01/2008 (Juanjo) -;;; Description: -;;; -;;; For a file linked as follows "ln -s //usr/ /tmp/foo", -;;; (truename #p"/tmp/foo") signals an error because //usr is -;;; parsed as a hostname. -;;; - -#-windows -(deftest compiler.0013.truename - (progn - (si:system "rm -rf foo; ln -sf //usr/ foo") - (prog1 (namestring (truename "./foo")) - (si::system "rm foo"))) - "/usr/") - -;;; Date: 30/08/2008 (Josh Elsasser) -;;; Fixed: 01/09/2008 (Juanjo) -;;; Description: -;;; -;;; Inside the form read by #., recursive definitions a la #n= -;;; and #n# were not properly expanded -;;; -(deftest compiler.0014.sharp-dot - (with-output-to-string (*standard-output*) - (let ((*print-circle* t)) - (read-from-string "'#.(princ (list '#1=(1 2) '#1#))"))) - "(#1=(1 2) #1#)") - -;;; Date: 30/08/2008 (Josh Elsasser) -;;; Fixed: 30/08/2008 (Josh Elsasser) -;;; Description: -;;; -;;; A setf expansion that produces a form with a macro that also has -;;; its own setf expansion does not giver rise to the right code. -;;; -(deftest compiler.0015-setf-expander - (progn - (define-setf-expander triple (place &environment env) - (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place env) - (let ((store (gensym))) - (values dummies - vals - `(,store) - `(let ((,(car newval) (/ ,store 3))) - (triple ,setter)) - `(progn - (triple ,getter)))))) - (defmacro hidden (val) - `(triple ,val)) - (defmacro triple (val) - `(* 3 ,val)) - (prog1 - (equalp (eval '(let ((foo 5)) - (list foo (triple foo) (setf (triple foo) 6) foo (triple foo)))) - (eval '(let ((foo 5)) - (list foo (hidden foo) (setf (hidden foo) 6) foo (hidden foo))))) - (fmakunbound 'hidden) - (fmakunbound 'triple))) - T) - -;;; Date: 17/2/2009 -;;; Fixed: 17/2/2009 -;;; Description: -;;; -;;; The defstruct form fails with an :include field that overwrites -;;; a slot that is read only. -;;; -(deftest compiler.0016.defstruct-include - (progn - (eval '(progn - (defstruct compiler.0016-a (a 1 :read-only t)) - (defstruct (compiler.0016-b (:include compiler.0016-a (a 2)))) - (defstruct (compiler.0016-c (:include compiler.0016-a (a 3 :read-only t)))))) - (values - (handler-case (eval '(defstruct (compiler.0016-d (:include compiler.0016-a (a 2 :read-only nil))))) - (error (c) t)) - (compiler.0016-a-a (make-compiler.0016-a)) - (compiler.0016-b-a (make-compiler.0016-b)) - (compiler.0016-c-a (make-compiler.0016-c)) - (handler-case (eval '(setf (compiler.0016-c-a (make-compiler.0016-c)) 3)) - (error (c) t)))) - t 1 2 3 t) - -;;; Date: 9/11/2009 -;;; Fixed: 9/11/2009 -;;; Description: -;;; -;;; LOAD does not work with special files (/dev/null) -;;; -(deftest compiler.0017.load-special - (handler-case (and (load #+(or windows mingw32) "NULL" - #-(or windows mingw32) "/dev/null") - t) - (serious-condition (c) nil)) - t) - -;;; Date: 16/11/2009 (Gabriel) -;;; Fixed: 20/11/2009 (Juanjo) -;;; Description: -;;; -;;; #= and ## reader macros do not work well with #. -;;; -(deftest compiler.0018.sharp-eq - (handler-case (values (read-from-string "(#1=(0 1 2) #.(length '#1#))")) - (serious-condition (c) nil)) - ((0 1 2) 3)) - -;;; Date: 14/11/2009 (M. Mondor) -;;; Fixed: 20/11/2009 (Juanjo) -;;; Description: -;;; -;;; FDEFINITION and SYMBOL-FUNCTION cause SIGSEGV when acting on NIL. -;;; -(deftest compiler.0019.fdefinition - (and (handler-case (fdefinition nil) - (undefined-function (c) t) - (serious-condition (c) nil)) - (handler-case (symbol-function nil) - (undefined-function (c) t) - (serious-condition (c) nil))) - t) - - -;;; Date: 29/11/2009 (P. Costanza) -;;; Fixed: 29/11/2009 (Juanjo) -;;; Description: -;;; -;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE. -;;; -(deftest compiler.0020.make-instances-obsolete - (progn - (defparameter *update-guard* nil) - (defclass compiler.0020-a () ((b :accessor compiler.0020-a-b :initarg :b))) - (let ((*a* (make-instance 'compiler.0020-a :b 2))) - (defmethod update-instance-for-redefined-class :before - ((instance standard-object) added-slots discarded-slots property-list - &rest initargs) - (setf *update-guard* t)) - (and (null *update-guard*) - (progn (compiler.0020-a-b *a*) (null *update-guard*)) - (progn (make-instances-obsolete (find-class 'compiler.0020-a)) - (null *update-guard*)) - (progn (compiler.0020-a-b *a*) *update-guard*) - (progn (setf *update-guard* nil) - (defclass compiler.0020-a () ((b :accessor compiler.0020-a-b :initarg :b))) - (compiler.0020-a-b *a*) - *update-guard*) - t))) - t) - -;;; Date: 25/03/2009 (R. Toy) -;;; Fixed: 4/12/2009 (Juanjo) -;;; Description: -;;; -;;; Conversion of rationals into floats is done by truncating, not by -;;; rounding, what implies a loss of accuracy. -;;; -(deftest compiler.0021.ratio-to-float - ;; The test builds a ratio which is very close to 1 but which is below it - ;; If we truncate instead of rounding the output will not be 1 coerced - ;; to that floating point type. - (loop for type in '(short-float single-float double-float long-float) - for bits = (float-precision (coerce 1 type)) - do (loop for i from (+ bits 7) to (+ bits 13) - nconc (loop with value = (ash 1 i) - with expected = (coerce 1 type) - for j from 0 to 10 - for x = (- value j) - for r = (/ (1- x) x) - for f1 = (coerce r type) - for f2 = (- (coerce (- r) type)) - unless (and (= f1 expected) (= f2 expected)) - collect (list type r)))) - nil) - -;;; Date: 06/04/2010 (M. Kocic) -;;; Fixed: 4/12/2009 -;;; Description: -;;; -;;; Inspection of structs is broken due to undefined inspect-indent -;;; -(deftest compiler.0022.inspect-struct - (let ((*query-io* (make-string-input-stream "q -"))) - (defstruct st1 p1) - (let ((v1 (make-st1 :p1 "tttt"))) - (handler-case (progn (inspect v1) t) - (error (c) nil)))) - t) - - -;; cmp-001 - -;;; Date: 12/03/2006 -;;; From: Dan Corkill -;;; Fixed: 14/04/2006 (juanjo) -;;; Description: -;;; -;;; The inner RETURN form should return to the outer block. -;;; However, the closure (lambda (x) ...) is improperly translated -;;; by the compiler to (lambda (x) (block nil ...) and thus this -;;; form outputs '(1 2 3 4). -;;; -(deftest compiler.0023.block - (funcall (compile nil - '(lambda () - (block nil - (funcall 'mapcar - #'(lambda (x) - (when x (return x))) - '(1 2 3 4)))) - )) - 1) - -;;; Fixed: 12/01/2006 (juanjo) -;;; Description: -;;; -;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as -;;; synonyms. -;;; -;;; -(deftest compiler.0024.pathname - (and (equalp (compile-file-pathname "foo" :type :fas) - (compile-file-pathname "foo" :type :fasl)) - t) - t) - -;;; Fixed: 21/12/2005 (juanjo) -;;; Description: -;;; -;;; Compute the path of the intermediate files (*.c, *.h, etc) -;;; relative to that of the fasl or object file. -;;; - -(deftest compiler.0025.paths - (let* ((output (compile-file-pathname "tmp/aux" :type :fasl)) - (h-file (compile-file-pathname output :type :h)) - (c-file (compile-file-pathname output :type :c)) - (data-file (compile-file-pathname output :type :data))) - (and - (zerop (si::system "rm -rf tmp; mkdir tmp")) - (with-compiler ("aux-compiler.0103-paths.lsp" :output-file output :c-file t - :h-file t :data-file t) - '(defun foo (x) (1+ x))) - (probe-file output) - (probe-file c-file) - (probe-file h-file) - (probe-file data-file) - (delete-file "aux-compiler.0103-paths.lsp") - t)) - t) - -;;; Date: 08/03/2006 -;;; From: Dan Corkill -;;; Fixed: 09/03/2006 (juanjo) -;;; Description: -;;; -;;; DEFCONSTANT does not declare the symbol as global and thus the -;;; compiler issues warnings when the symbol is referenced in the -;;; same file in which it is defined as constant. -;;; - -#-ecl-bytecmp -(deftest compiler.0026.defconstant-warn - (let ((warn nil)) - (with-dflet ((c::cmpwarn (setf warn t))) - (with-compiler ("aux-compiler.0104.lsp") - '(defconstant foo (list 1 2 3)) - '(print foo))) - (delete-file "aux-compiler.0104.lsp") - (delete-file (compile-file-pathname "aux-compiler.0104.lsp" :type :fas)) - warn) - nil) - -;;; Date: 16/04/2006 -;;; From: Juanjo -;;; Fixed: 16/04/2006 (juanjo) -;;; Description: -;;; -;;; Special declarations should only affect the variable bound and -;;; not their initialization forms. That, even if the variables are -;;; the arguments of a function. -;;; - -(deftest compiler.0027.declaration - (let ((form '(lambda (y) - (flet ((faa (&key (x y)) - (declare (special y)) - x)) - (let ((y 4)) - (declare (special y)) - (faa)))))) - ;; We must test that both the intepreted and the compiled form - ;; output the same value. - (list (funcall (compile 'nil form) 3) - (funcall (coerce form 'function) 3))) - (3 3)) - -;;; Date: 26/04/2006 -;;; From: Michael Goffioul -;;; Fixed: ---- -;;; Description: -;;; -;;; Functions with more than 64 arguments have to be invoked using -;;; the lisp stack. -;;; - -(deftest compiler.0028.call-arguments-limit - (let ((form '(lambda () - (list (list - 'a0 'b0 'c0 'd0 'e0 'f0 'g0 'h0 'i0 - 'j0 'k0 'l0 'm0 'n0 'o0 'p0 'q0 - 'r0 's0 't0 'u0 'v0 'w0 'x0 'y0 'z0 - 'a1 'b1 'c1 'd1 'e1 'f1 'g1 'h1 'i1 - 'j1 'k1 'l1 'm1 'n1 'o1 'p1 'q1 - 'r1 's1 't1 'u1 'v1 'w1 'x1 'y1 'z1 - 'a2 'b2 'c2 'd2 'e2 'f2 'g2 'h2 'i2 - 'j2 'k2 'l2 'm2 'n2 'o2 'p2 'q2 - 'r2 's2 't2 'u2 'v2 'w2 'x2 'y2 'z2 - 'a3 'b3 'c3 'd3 'e3 'f3 'g3 'h3 'i3 - 'j3 'k3 'l3 'm3 'n3 'o3 'p3 'q3 - 'r3 's3 't3 'u3 'v3 'w3 'x3 'y3 'z3 - 'a4 'b4 'c4 'd4 'e4 'f4 'g4 'h4 'i4 - 'j4 'k4 'l4 'm4 'n4 'o4 'p4 'q4 - 'r4 's4 't4 'u4 'v4 'w4 'x4 'y4 'z4 - 'a5 'b5 'c5 'd5 'e5 'f5 'g5 'h5 'i5 - 'j5 'k5 'l5 'm5 'n5 'o5 'p5 'q5 - 'r5 's5 't5 'u5 'v5 'w5 'x5 'y5 'z5 - 'a6 'b6 'c6 'd6 'e6 'f6 'g6 'h6 'i6 - 'j6 'k6 'l6 'm6 'n6 'o6 'p6 'q6 - 'r6 's6 't6 'u6 'v6 'w6 'x6 'y6 'z6))))) - (equal (funcall (compile 'foo form)) - (funcall (coerce form 'function)))) - t) - -;;; Date: 16/05/2005 -;;; Fixed: 18/05/2006 (juanjo) -;;; Description: -;;; -;;; The detection of when a lisp constant has to be externalized using MAKE-LOAD-FORM -;;; breaks down with some circular structures -;;; - -(defclass compiler.017-class () - ((parent :accessor compiler.017-parent :initform nil) - (children :initarg :children :accessor compiler.017-children :initform nil))) - -(defmethod make-load-form ((x compiler.017-class) &optional environment) - (declare (ignore environment)) - (values - ;; creation form - `(make-instance ',(class-of x) :children ',(slot-value x 'children)) - ;; initialization form - `(setf (compiler.017-parent ',x) ',(slot-value x 'parent)) - )) - -(deftest compiler.0029.circular-load-form - (loop for object in - (let ((l (list 1 2 3))) - (list l - (subst 3 l l) - (make-instance 'compiler.017-class) - (subst (make-instance 'compiler.017-class) 3 l))) - collect (clos::need-to-make-load-form-p object nil)) - (nil nil t t)) - -;;; Date: 18/05/2005 -;;; Fixed: 17/05/2006 (Brian Spilsbury & juanjo) -;;; Description: -;;; -;;; The compiler is not able to externalize constants that have no printed representation. -;;; In that case MAKE-LOAD-FORM should be used. -;;; - -(deftest compiler.0030.make-load-form - (let ((output (compile-file-pathname "aux-compiler.0108.lsp" :type :fasl))) - (with-open-file (s "aux-compiler.0108.lsp" :if-exists :supersede :if-does-not-exist :create :direction :output) - (princ " -(eval-when (:compile-toplevel) - (defvar s4 (make-instance 'compiler.017-class)) - (defvar s5 (make-instance 'compiler.017-class)) - (setf (compiler.017-parent s5) s4) - (setf (compiler.017-children s4) (list s5))) - -(defvar a '#.s5) -(defvar b '#.s4) -(defvar c '#.s5) -(defun foo () - (let ((*print-circle* t)) - (with-output-to-string (s) (princ '#1=(1 2 3 #.s4 #1#) s)))) -" s)) - (compile-file "aux-compiler.0108.lsp") - (load output) - (prog1 (foo) - (delete-file output) - (delete-file "aux-compiler.0108.lsp"))) - "#1=(1 2 3 # #1#)") - -;;; Date: 9/06/2006 (Pascal Costanza) -;;; Fixed: 13/06/2006 (juanjo) -;;; Description: -;;; -;;; A MACROLET function creates a set of local macro definitions. -;;; The forms that expand these macros are themselves affected by -;;; enclosing MACROLET and SYMBOL-MACRO definitions: -;;; (defun bar () -;;; (macrolet ((x () 2)) -;;; (macrolet ((m () (x))) -;;; (m)))) -;;; (compile 'bar) -;;; (bar) => 2 -;;; -(deftest compiler.0031.macrolet - (list - (progn - (defun bar () - (macrolet ((x () 2)) - (macrolet ((m () (x))) - (m)))) - (compile 'bar) - (bar)) - (progn - (defun bar () - (symbol-macrolet ((x 2)) - (macrolet ((m () x)) - (m)))) - (compile 'bar) - (bar))) - (2 2)) - -;;; Fixed: 13/06/2006 (juanjo) -;;; Description: -;;; -;;; A MACROLET that references a local variable from the form in -;;; which it appears can cause corruption in the interpreter. We -;;; solve this by signalling errors whenever such reference -;;; happens. -;;; -;;; Additionally MACROLET forms should not see the other macro -;;; definitions on the same form, much like FLET functions cannot -;;; call their siblings. -;;; -(deftest compiler.0032.macrolet - (flet ((eval-with-error (form) - (handler-case (eval form) - (error (c) 'error)))) - (makunbound 'compiler.0110-foo) - (fmakunbound 'compiler.0110-foo) - (let ((faa 1)) - (declare (special faa)) - (mapcar #'eval-with-error - '((let ((faa 2)) - (macrolet ((m () faa)) - (m))) - (let ((faa 4)) - (declare (special faa)) - (macrolet ((m () faa)) - (m))) - (let ((faa 4)) - (declare (special compiler.0110-foo)) - (macrolet ((m () compiler.0110-foo)) - (m))) - (let ((faa 5)) - (macrolet ((m () compiler.0110-foo)) - (m))) - (macrolet ((compiler.0110-foo () 6)) - (macrolet ((m () (compiler.0110-foo))) - (m))) - (macrolet ((f1 () 7) - (f2 () 8)) - ;; M should not see the new definitions F1 and F2 - (macrolet ((f1 () 9) - (f2 () 10) - (m () (list 'quote (list (f1) (f2))))) - (m))) - (flet ((compiler.0110-foo () 1)) - (macrolet ((m () (compiler.0110-foo))) - (m))) - (labels ((compiler.0110-foo () 1)) - (macrolet ((m () (compiler.0110-foo))) - (m))))))) - (error 1 error error 6 (7 8) error error )) - -;;; Date: 22/06/2006 (juanjo) -;;; Fixed: 29/06/2006 (juanjo) -;;; Description: -;;; -;;; ECL only accepted functions with less than 65 required -;;; arguments. Otherwise it refused to compile the function. The fix must -;;; respect the limit in the number of arguments passed in the C stack and -;;; use the lisp stack for the other required arguments. -;;; -#-ecl-bytecmp -(deftest compiler.0033.c-arguments-limit - (mapcar #'(lambda (nargs) - (let* ((arg-list (loop for i from 0 below nargs - collect (intern (format nil "arg~d" i)))) - (data (loop for i from 0 below nargs collect i)) - (lambda-form `(lambda ,arg-list - (and (equalp (list ,@arg-list) ',data) - ,nargs))) - (c:*compile-verbose* nil) - (c:*compile-print* nil) - (function (compile 'foo lambda-form))) - (list (apply function (subseq data 0 nargs)) - (handler-case (apply function (make-list (1+ nargs))) - (error (c) :error)) - (handler-case (apply function (make-list (1- nargs))) - (error (c) :error))))) - '(10 20 30 40 50 63 64 65 70)) - ((10 :ERROR :ERROR) (20 :ERROR :ERROR) (30 :ERROR :ERROR) (40 :ERROR :ERROR) - (50 :ERROR :ERROR) (63 :ERROR :ERROR) (64 :ERROR :ERROR) (65 :ERROR :ERROR) - (70 :ERROR :ERROR))) - -(let* ((nargs 10) - (arg-list (loop for i from 0 below nargs - collect (intern (format nil "arg~d" i)))) - (arguments (make-list nargs))) - (apply (compile 'foo `(lambda ,arg-list - (length (list ,@arg-list)))) - arguments)) - -;;; Date: 12/07/2008 (Josh Elsasser) -;;; Fixed: 02/08/2008 (Juanjo) -;;; Description: -;;; -;;; ECL fails to properly compute the closure type of a function that -;;; returns a lambda that calls the function itself. -;;; -(deftest compiler.0034.compute-closure - (and (with-compiler ("aux-compiler.0103-paths.lsp" :load t) - (defun testfun (outer) - (labels ((testlabel (inner) - (if inner - (testfun-map - (lambda (x) (testlabel x)) - inner)) - (print outer))) - (testlabel outer)))) - t) - t) - -;;; Date: 02/09/2008 (Josh Elsasser) -;;; Fixed: 12/09/2008 (Josh Elsasser) -;;; Description: -;;; -;;; FTYPE proclamations and declarations do not accept user defined -;;; function types. -;;; -(deftest compiler.0035.ftype-user-type - (progn - (deftype compiler.0113-float-function () '(function (float) float)) - (deftype compiler.0113-float () 'float) - (loop for (type . fails) in - '(((function (float) float) . nil) - (cons . t) - (compiler.0113-float-function . nil) - (compiler.0113-float . t)) - always (let ((form1 `(proclaim '(ftype ,type foo))) - (form2 `(compile nil '(lambda () - (declare (ftype ,type foo)) - (foo))))) - (if fails - (and (signals-error (eval form1) error) - (signals-error (eval form2) error) - t) - (progn - (eval form1) - (eval form2) - t))))) - t) - -;;; Date: 01/11/2008 (E. Marsden) -;;; Fixed: 02/11/2008 (Juanjo) -;;; Description: -;;; -;;; When compiled COERCE with type INTEGER may cause double -;;; evaluation of a form. -(deftest compiler.0036.coerce - (funcall - (compile 'foo '(lambda (x) (coerce (shiftf x 2) 'integer))) - 1) - 1) - -;;; Date: 03/11/2008 (E. Marsden) -;;; Fixed: 08/11/2008 (Juanjo) -;;; Description: -;;; -;;; TYPEP, with a real type, produces strange results. -;;; -(deftest compiler.0037.coerce - (funcall - (compile 'foo '(lambda (x) (typep (shiftf x 1) '(real 10 20)))) - 5) - NIL) - -;;; Date: 20/07/2008 (Juanjo) -;;; Fixed: 20/07/2008 (Juanjo) -;;; Description: -;;; -;;; In the new compiler, when compiling LET forms with special variables -;;; the values of the variables are not saved to make the assignments -;;; really parallel. -;;; -(deftest compiler.0038.let-with-specials - (progn - (defvar *stak-x*) - (defvar *stak-y*) - (defvar *stak-z*) - (funcall - (compile - nil - '(lambda (*stak-x* *stak-y* *stak-z*) - (labels - ((stak-aux () - (if (not (< (the fixnum *stak-y*) (the fixnum *stak-x*))) - *stak-z* - (let ((*stak-x* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-x*)))) - (*stak-y* *stak-y*) - (*stak-z* *stak-z*)) - (stak-aux))) - (*stak-y* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-y*)))) - (*stak-y* *stak-z*) - (*stak-z* *stak-x*)) - (stak-aux))) - (*stak-z* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-z*)))) - (*stak-y* *stak-x*) - (*stak-z* *stak-y*)) - (stak-aux)))) - (stak-aux))))) - (stak-aux)))) 18 12 6)) - 7) - -;;; Date: 06/10/2009 (J. Pellegrini) -;;; Fixed: 06/10/2009 (Juanjo) -;;; Description: -;;; Extended strings were not accepted as documentation by the interpreter. -;;; -(deftest compiler.0039.docstrings - (handler-case - (progn - (eval `(defun foo () ,(make-array 10 :initial-element #\Space :element-type 'character) 2)) - (eval (funcall 'foo))) - (serious-condition (c) nil)) - 2) - -;;; Date: 07/11/2009 (A. Hefner) -;;; Fixed: 07/11/2009 (A. Hefner + Juanjo) -;;; Description: -;;; ECL ignores the IGNORABLE declaration -;;; -(deftest compiler.0040.ignorable - (let ((c::*suppress-compiler-messages* t)) - (and - ;; Issue a warning for unused variables - (handler-case (and (compile nil '(lambda (x y) (print x))) nil) - (warning (c) t)) - ;; Do not issue a warning for unused variables declared IGNORE - (handler-case (and (compile nil '(lambda (x y) (declare (ignore y)) - (print x))) t) - (warning (c) nil)) - ;; Do not issue a warning for unused variables declared IGNORABLE - (handler-case (and (compile nil '(lambda (x y) (declare (ignorable y)) - (print x))) t) - (warning (c) nil)) - ;; Do not issue a warning for used variables declared IGNORABLE - (handler-case (and (compile nil '(lambda (x y) (declare (ignorable x y)) - (print x))) t) - (warning (c) nil)))) - t) - -;;; Date: 29/11/2009 (P. Costanza) -;;; Fixed: 29/11/2009 (Juanjo) -;;; Description: -;;; When calling a bytecodes (SETF ...) function from a compiled function -;;; an invalid memory access is produced. This is actually a consequence -;;; of a mismatch between the position of the fields bytecodes.entry -;;; and cfun.entry -;;; -#-ecl-bytcmp -(deftest compiler.0041.bytecodes-entry-position - (let ((indices (funcall (compile nil - '(lambda () - (ffi:c-inline () () list " - union cl_lispunion x[0]; - cl_index bytecodes = (char*)(&(x->bytecodes.entry)) - (char*)x; - cl_index bclosure = (char*)(&(x->bclosure.entry)) - (char*)x; - cl_index cfun = (char*)(&(x->cfun.entry)) - (char*)x; - cl_index cfunfixed = (char*)(&(x->cfunfixed.entry)) - (char*)x; - cl_index cclosure = (char*)(&(x->cclosure.entry)) - (char*)x; - @(return) = cl_list(5, MAKE_FIXNUM(bytecodes), - MAKE_FIXNUM(bclosure), - MAKE_FIXNUM(cfun), - MAKE_FIXNUM(cfunfixed), - MAKE_FIXNUM(cclosure));" :one-liner nil)))))) - (and (apply #'= indices) t)) - t) - -;;; Date: 07/02/2010 (W. Hebich) -;;; Fixed: 07/02/2010 (Juanjo) -;;; Description: -;;; THE forms do not understand VALUES types -;;; (the (values t) (funcall sym)) -;;; -(deftest compiler.0042.the-and-values - (handler-case (and (compile 'foo '(lambda () (the (values t) (faa)))) - t) - (warning (c) nil)) - t) - - -;;; Date: 28/03/2010 (M. Mondor) -;;; Fixed: 28/03/2010 (Juanjo) -;;; Description: -;;; ECL does not compile type declarations of a symbol macro -;;; -(deftest compiler.0043.symbol-macro-declaration - (handler-case (and (compile 'nil - '(lambda (x) - (symbol-macrolet ((y x)) - (declare (fixnum y)) - (+ y x)))) - nil) - (warning (c) t)) - nil) - -;;; Date: 24/04/2010 (Juanjo) -;;; Fixed 24/04/2010 (Juanjo) -;;; Description: -;;; New special form, WITH-BACKEND. -;;; -(deftest compiler.0044.with-backend - (progn - (defparameter *compiler.0122* nil) - (defun compiler.0122a () - (ext:with-backend - :bytecodes (setf *compiler.0122* :bytecodes) - :c/c++ (setf *compiler.0122* :c/c++))) - (list - (progn (compiler.0122a) *compiler.0122*) - (compiler.0122a) - (progn (compile 'compiler.0122a) (compiler.0122a) *compiler.0122*) - (compiler.0122a))) - (:bytecodes :bytecodes :c/c++ :c/c++)) - - - -;;; Date: 10/08/2008 -;;; From: Juanjo -;;; Fixed: 10/08/2008 -;;; Description: -;;; -;;; COS, SIN and TAN were expanded using a wrong C expression. -;;; - -(deftest compiler.0045.inline-cos - (loop with *compile-verbose* = nil - with *compile-print* = nil - for type in '(short-float single-float double-float long-float) - for sample = (coerce 1.0 type) - for epsilon in '(#.short-float-epsilon #.single-float-epsilon #.double-float-epsilon #.long-float-epsilon) - unless (loop for op in '(sin cos tan sinh cosh tanh) - for f = (compile 'nil `(lambda (x) - (declare (,type x) - (optimize (safety 0) - (speed 3))) - (+ ,sample (,op x)))) - always (loop for x from (- pi) below pi by 0.05 - for xf = (float x sample) - for error = (- (funcall f xf) (+ 1 (funcall op xf))) - always (< (abs error) epsilon))) - collect type) - nil) - - - -;;; Description: -;;; -;;; The interpreter selectively complains when assigning a variable -;;; that has not been declared as special and is not local. -;;; -;;; Fixed: 03/2006 (juanjo) -;;; -(deftest compiler.0046.global-setq - (mapcar - (lambda (ext:*action-on-undefined-variable*) - (handler-case - (progn (eval `(setq ,(gensym) 1)) :no-error) - (error (c) :error))) - '(nil ERROR)) - (:no-error :error)) - -;;; Date: 24/04/2010 (Juanjo) -;;; Fixed: 24/04/2010 (Juanjo) -;;; Description: -;;; The interpreter does not increase the lexical environment depth when -;;; optimizing certain forms (LIST, LIST*, CONS...) and thus causes some -;;; of the arguments to be eagerly evaluated. -;;; -(deftest compiler.0046.list-optimizer-error - (with-output-to-string (*standard-output*) - (eval '(list (print 1) (progn (print 2) (print 3))))) - " -1 -2 -3 ") - - - -;;; Date: 2015-09-04 -;;; Fixed: Daniel Kochmański -;;; Description -;;; Compiler signalled arithmetic-error when producing C code for infinity -;;; and NaN float values (part of ieee floating point extensions). - -#+ieee-floating-point -(deftest compiler.0047.infinity-test.1 - (progn - (defun aux-compiler-0047.infty-test.1 () - (> 0.0 ext:single-float-negative-infinity)) - (compile 'aux-compiler-0047.infty-test.1)) - aux-compiler-0047.infty-test.1 NIL NIL) - -#+ieee-floating-point -(deftest compiler.0048.infinity-test.2 - (progn - (with-compiler ("aux-compiler-0048.infty-test.2.lsp") - '(defun doit () (> 0.0 ext:single-float-negative-infinity))) - (load "aux-compiler-0048.infty-test.2.fas") - (delete-file "aux-compiler-0048.infty-test.2.lsp") - (delete-file "aux-compiler-0048.infty-test.2.fas") - (doit)) - T) - - - -;;; Date: 2015-12-18 -;;; Fixed: Daniel Kochmański -;;; Description -;;; Compiler expanded FIND incorrectly (ignored START and END arguments) - -(deftest compiler.0049.cmpopt-sequences.1 - (progn - (defun check-single-wildcard (identifier wildcard-pos) - (not (find #\* identifier :start (1+ wildcard-pos)))) - (compile 'check-single-wildcard) - (check-single-wildcard "dan*" 3)) - T) - -;;; Date: 2016-02-10 -;;; Fixed: Daniel Kochmański -;;; Description -;;; Aux closures created by C compiler weren't handled correctly -;;; in respect of the environment and declarations of the -;;; variables -(deftest compiler.0050.cmptop/call.1 - (funcall (compile nil '(lambda () - (labels - ((fun-2 () (fun-3 'cool)) - (fun-3 (clause-var) - (flet ((fun-4 () clause-var)) - (fun-4)))) - (let ((fun-1 (lambda () (fun-2)))) - (funcall fun-1)))))) - cool) - - -;;; Date 2016-04-21 -;;; Fixed: Daniel Kochmański -;;; Description -;;; typep didn't recognize * as a t abberv -;;; -(deftest compiler.0051.ftype-args* - (progn - (declaim (ftype (function (*) (values T)) ce)) - (defun ce (expression) nil) - (compile 'ce) - (ce nil)) - nil) diff --git a/src/tests/regressions/tests/foreign-interface.lsp b/src/tests/regressions/tests/foreign-interface.lsp deleted file mode 100644 index de92d5c3d..000000000 --- a/src/tests/regressions/tests/foreign-interface.lsp +++ /dev/null @@ -1,119 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Juan Jose Garcia-Ripoll -;;;; Author: Daniel Kochmański -;;;; Created: Fri Apr 14 11:13:17 CEST 2006 -;;;; Contains: Foreign Function Interface regression tests - -(in-package :cl-test) - -;;; Date: 23/03/2006 -;;; From: Klaus Falb -;;; Fixed: 26/02/2006 (juanjo) -;;; Description: -;;; -;;; Callback functions have to be declared static so that there -;;; are no conflicts among callbacks in different files. -;;; -;;; Fixed: 13/04/2006 (juanjo) -;;; Description: -;;; -;;; Header should be included as -;;; - -(deftest foreign-interface.0001.callback - (and - (zerop (si::system "rm -rf tmp; mkdir tmp")) - (with-open-file (s "tmp/a.lsp" :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print '(ffi:defcallback foo :void () nil) s)) - (with-open-file (s "tmp/b.lsp" :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print '(ffi:defcallback foo :void () nil) s)) - (compile-file "tmp/a.lsp" :system-p t) - (compile-file "tmp/b.lsp" :system-p t) - (c:build-program "tmp/foo" :lisp-files - (list (compile-file-pathname "tmp/a.lsp" :type :object) - (compile-file-pathname "tmp/b.lsp" :type :object))) - (probe-file (compile-file-pathname "tmp/foo" :type :program)) - (zerop (si::system "rm -rf tmp")) - t) - t) - -;;; Date: 29/07/2008 -;;; From: Juajo -;;; Description: -;;; Callback examples based on the C compiler -;;; -(deftest foreign-interface.0002.callback - (and - (zerop (si::system "rm -rf tmp; mkdir tmp")) - (with-open-file (s "tmp/c.lsp" :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print - '(defun callback-user (callback arg) - (ffi:c-inline (callback arg) (:pointer-void :int) :int " -int (*foo)(int) = #0; -@(return) = foo(#1); -" - :one-liner nil :side-effects nil)) - s) - (print - '(ffi:defcallback ffi-002-foo :int ((a :int)) - (1+ a)) - s)) - (compile-file "tmp/c.lsp" :load t) - (eql (callback-user (ffi:callback 'ffi-002-foo) 2) 3) - t) - t) - -;;; Date: 29/07/2008 -;;; From: Juajo -;;; Description: -;;; Callback examples based on the DFFI. Only work if this feature -;;; has been linked in. -;;; -#+dffi -(deftest foreign-interface.0003.callback - (and - (zerop (si::system "rm -rf tmp; mkdir tmp")) - (with-open-file (s "tmp/c.lsp" :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print - '(defun callback-user (callback arg) - (ffi:c-inline (callback arg) (:pointer-void :int) :int " -int (*foo)(int) = #0; -@(return) = foo(#1); -" - :one-liner nil :side-effects nil)) - s)) - (compile-file "tmp/c.lsp" :load t) - (eval '(ffi:defcallback foo-002b :int ((a :int)) - (1+ a))) - (eql (callback-user (ffi:callback 'foo-002b) 2) 3) - t) - t) - -;;; Date: 25/04/2010 (Juanjo) -;;; Description: -;;; Regression test to ensure that two foreign data compare -;;; EQUAL when their addresses are the same. -(deftest foreign-interface.0004.foreign-data-equal - (equal (ffi:make-pointer 1234 :void) - (ffi:make-pointer 1234 :int)) - t) - -;;; Date: 2016-01-04 (jackdaniel) -;;; Description: -;;; Regression test to ensure, that the string is properly -;;; recognized as an array -(deftest foreign-interface.0004 - (progn - (si::make-foreign-data-from-array "dan") - t) - t) diff --git a/src/tests/regressions/tests/metaobject-protocol.lsp b/src/tests/regressions/tests/metaobject-protocol.lsp deleted file mode 100644 index 88df8d8d4..000000000 --- a/src/tests/regressions/tests/metaobject-protocol.lsp +++ /dev/null @@ -1,638 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Juan Jose Garcia-Ripoll -;;;; Author: Daniel Kochmański -;;;; Created: Fri Apr 14 11:13:17 CEST 2006 -;;;; Contains: Metaobject Protocol tests - -(in-package :cl-test) - -(use-package :clos) - - -;; mop-001 - -(defun delete-class (&rest class-names) - ;;; do nothing. We will figure out later what to do. - (values)) - -;;; Fixed: 14/04/2006 (juanjo) -;;; Description: -;;; -;;; The slot definitions from some classes did not get converted. -;;; Besides, metaobject CLASS had the same list for direct and effective -;;; slots. -;;; -(deftest mop-0001-fixup - (block top - (labels ((test-class (class-object) - (let ((x (find-if-not #'(lambda (x) - (typep x 'standard-direct-slot-definition)) - (class-direct-slots class-object)))) - (when x - (format t "Class ~a has as direct slot ~a" class-object x) - (return-from top (class-name class-object)))) - (let ((x (find-if-not #'(lambda (x) - (typep x 'standard-effective-slot-definition)) - (class-slots class-object)))) - (when x - (format t "Class ~a has as effective slot ~a" class-object x) - (return-from top (class-name class-object)))) - (mapc #'test-class (clos::class-direct-subclasses class-object)))) - (test-class (find-class 't)) - nil)) - nil) - -;;; Date: 13/02/2006 -;;; From: Dan Debertin -;;; Fixed: 24-02-2006 (juanjo) -;;; Description: -;;; -;;; Subclasses of STANDARD-CLASS would not inherit all their slots -;;; and thus would cause runtime errors when creating instances. -;;; - -(deftest mop-0002-metaclasses - (eval '(progn - (defclass foo-metaclass (standard-class) ()) - (defclass faa () ((a :initform 2 :initarg :a)) (:metaclass foo-metaclass)) - (prog1 (slot-value (make-instance 'faa :a 3) 'a) - (cl-test::delete-class 'foo-metaclass 'faa)))) - 3) - -;;; Date: 02/03/2006 -;;; From: Pascal Costanza -;;; Fixed: 07/03/2006 (juanjo) -;;; Description: -;;; -;;; CLOS should export the symbols from the AMOP. -;;; - - -(defconstant +mop-symbols+ '("DIRECT-SLOT-DEFINITION" -"EFFECTIVE-SLOT-DEFINITION" "EQL-SPECIALIZER" "FORWARD-REFERENCED-CLASS" -"FUNCALLABLE-STANDARD-CLASS" "FUNCALLABLE-STANDARD-OBJECT" "METAOBJECT" -"SLOT-DEFINITION" "SPECIALIZER" "STANDARD-ACCESSOR-METHOD" -"STANDARD-DIRECT-SLOT-DEFINITION" "STANDARD-EFFECTIVE-SLOT-DEFINITION" -"STANDARD-READER-METHOD" "STANDARD-SLOT-DEFINITION" "STANDARD-WRITER-METHOD" -"ACCESSOR-METHOD-SLOT-DEFINITION" "ADD-DEPENDENT" "ADD-DIRECT-METHOD" -"ADD-DIRECT-SUBCLASS" "CLASS-DEFAULT-INITARGS" -"CLASS-DIRECT-DEFAULT-INITARGS" "CLASS-DIRECT-SLOTS" -"CLASS-DIRECT-SUBCLASSES" "CLASS-DIRECT-SUPERCLASSES" "CLASS-FINALIZED-P" -"CLASS-PRECEDENCE-LIST" "CLASS-PROTOTYPE" "CLASS-SLOTS" -"COMPUTE-APPLICABLE-METHODS-USING-CLASSES" "COMPUTE-CLASS-PRECEDENCE-LIST" -"COMPUTE-DEFAULT-INITARGS" "COMPUTE-DISCRIMINATING-FUNCTION" -"COMPUTE-EFFECTIVE-METHOD" "COMPUTE-EFFECTIVE-SLOT-DEFINITION" -"COMPUTE-SLOTS" "DIRECT-SLOT-DEFINITION-CLASS" -"EFFECTIVE-SLOT-DEFINITION-CLASS" "ENSURE-CLASS" "ENSURE-CLASS-USING-CLASS" -"ENSURE-GENERIC-FUNCTION-USING-CLASS" "EQL-SPECIALIZER-OBJECT" -"EXTRACT-LAMBDA-LIST" "EXTRACT-SPECIALIZER-NAMES" "FINALIZE-INHERITANCE" -"FIND-METHOD-COMBINATION" "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" -"GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" -"GENERIC-FUNCTION-DECLARATIONS" "GENERIC-FUNCTION-LAMBDA-LIST" -"GENERIC-FUNCTION-METHOD-CLASS" "GENERIC-FUNCTION-METHOD-COMBINATION" -"GENERIC-FUNCTION-METHODS" "GENERIC-FUNCTION-NAME" "INTERN-EQL-SPECIALIZER" -"MAKE-METHOD-LAMBDA" "MAP-DEPENDENTS" "METHOD-FUNCTION" -"METHOD-GENERIC-FUNCTION" "METHOD-LAMBDA-LIST" "METHOD-SPECIALIZERS" -"READER-METHOD-CLASS" "REMOVE-DEPENDENT" "REMOVE-DIRECT-METHOD" -"REMOVE-DIRECT-SUBCLASS" "SET-FUNCALLABLE-INSTANCE-FUNCTION" -"SLOT-BOUNDP-USING-CLASS" "SLOT-DEFINITION-ALLOCATION" -"SLOT-DEFINITION-INITARGS" "SLOT-DEFINITION-INITFORM" -"SLOT-DEFINITION-INITFUNCTION" "SLOT-DEFINITION-LOCATION" -"SLOT-DEFINITION-NAME" "SLOT-DEFINITION-READERS" "SLOT-DEFINITION-WRITERS" -"SLOT-DEFINITION-TYPE" "SLOT-MAKUNBOUND-USING-CLASS" -"SLOT-VALUE-USING-CLASS" "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" -"SPECIALIZER-DIRECT-METHODS" "STANDARD-INSTANCE-ACCESS" "UPDATE-DEPENDENT" -"VALIDATE-SUPERCLASS" "WRITER-METHOD-CLASS")) - -(deftest mop-0003-symbols - (let ((*package* (find-package "CLOS"))) - (and (remove-if #'(lambda (x) - (multiple-value-bind (s t) - (find-symbol x *package*) - (and s (eq t :external)))) - +mop-symbols+) - t)) - nil) - -;;; Date: 02/03/2006 -;;; From: Dank Corkill -;;; Fixed: 02-03-2006 (Dan Corkill) -;;; Description: -;;; -;;; DEFCLASS allows additional options which should be handled by the -;;; metaclass. -;;; - -(deftest mop-0004-defclass-options - (eval '(let ((*aux* 5)) - (declare (special *aux*)) - (defclass foo-metaclass (standard-class) ()) - (defmethod shared-initialize ((class foo-metaclass) slot-names - &rest initargs &key option) - (prog1 (call-next-method) - (setf *aux* option))) - (defclass faa () - ((a :initform *aux* :initarg :a)) - (:metaclass foo-metaclass) - (:option t)) - (prog1 (slot-value (make-instance 'faa) 'a) - (cl-test::delete-class 'foo-metaclass 'faa)))) - (T)) - -;;; Date: 02/03/2006 -;;; From: Dank Corkill -;;; Fixed: 02-03-2006 (Dan Corkill) -;;; Description: -;;; -;;; Readers and writers for slot documentation. -;;; - -(deftest mop-0004b-slot-documentation - (eval '(progn - (defclass fee () - ((a :initform *aux* :initarg :a))) - (setf (documentation (first (clos:class-slots (find-class 'fee))) t) - #1="hola") - (documentation (first (clos:class-slots (find-class 'fee))) t))) - #1#) - -;;; Date: 25/03/2006 -;;; From: Pascal Costanza -;;; Fixed: 03/04/2006 (juanjo) -;;; Description: -;;; -;;; The default slot setter methods had the first argument -;;; (i.e. the new value) specialized to NIL. This makes it -;;; impossible to write further specializations. -;;; - -(deftest mop-0005-setf-specializer - (progn - (defclass fee () - ((a :accessor fee-a))) - (prog1 - (list - (mapcar #'class-name - (method-specializers (first (generic-function-methods #'(setf fee-a))))) - (mapcar #'class-name - (method-specializers (first (generic-function-methods #'fee-a))))) - (delete-class 'fee))) - ((t fee) (fee))) - -;;; Date: 06/04/2006 -;;; From: Pascal Costanza -;;; Fixed: --- -;;; Description: -;;; -;;; When a required argument in a method is not explicitely given -;;; an specializer, the specializer should be T. Thus -;;; (defmethod foo (a)) -;;; is equivalent to -;;; (defmethod foo ((a t))) -;;; - -(deftest mop-0006-method-specializer - (progn - (defmethod mop-0006-foo (a)) - (prog1 - (method-specializers (first (generic-function-methods #'mop-0006-foo))) - (fmakunbound 'mop-0006-foo))) - (#.(find-class t))) - -;;; Date: 22/04/2006 -;;; From: M. Goffioul -;;; Fixed: 23/04/2006 (juanjo) -;;; Description: -;;; -;;; When a class inherits from two other classes which have a slot -;;; with the same name, the new class should inherit the accessors -;;; from both classes. -;;; - -(deftest mop-0007-slot-inheritance - (progn - (defclass fee-1 () - ((slot-0 :initform 0 :reader slot-0) - (slot-1 :initform 1 :reader slot-1))) - (defclass fee-2 () - ((slot-0 :initform 2 :reader slot-2))) - (defclass fee-3 (fee-1 fee-2) - ((slot-0 :initform 3 :accessor c-slot-0))) - (flet ((accessors (class) - (list (class-name class) - (mapcar #'slot-definition-readers (class-slots class)) - (mapcar #'slot-definition-readers (class-slots class))))) - (prog1 - (list (accessors (find-class 'fee-1)) - (accessors (find-class 'fee-2)) - (accessors (find-class 'fee-3)) - (mapcar #'(lambda (o) - (mapcar #'(lambda (method) - (handler-case (funcall method o) - (error (c) nil))) - '(slot-0 slot-2 c-slot-0))) - (mapcar #'make-instance '(fee-1 fee-2 fee-3)))) - (delete-class 'fee-1 'fee-2 'fee-3)))) - ((fee-1 ((slot-0) (slot-1)) ((slot-0) (slot-1))) - (fee-2 ((slot-2)) ((slot-2))) - (fee-3 ((c-slot-0 slot-0 slot-2) (slot-1)) - ((c-slot-0 slot-0 slot-2) (slot-1))) - ((0 nil nil) - (nil 2 nil) - (3 3 3)))) - - -;;; Date: 28/04/2006 -;;; From: P. Costanza -;;; Fixed: 05/05/2006 (P. Costanza) -;;; Description: -;;; -;;; Option names from classes and generic functions which are not -;;; in the keyword package should be quoted. This test is -;;; essentially like mop-0004-... because our DEFGENERIC does not -;;; support non-keyword options. -;;; - -(deftest mop-0008-defclass-option-quote - (eval '(let ((*aux* 5)) - (declare (special *aux*)) - (defclass foo-metaclass (standard-class) ()) - (defmethod shared-initialize ((class foo-metaclass) slot-names - &rest initargs &key ((cl-user::option option))) - (prog1 (call-next-method) - (setf *aux* option))) - (defclass faa () - ((a :initform *aux* :initarg :a)) - (:metaclass foo-metaclass) - (cl-user::option t)) - (prog1 (slot-value (make-instance 'faa) 'a) - (cl-test::delete-class 'foo-metaclass 'faa)))) - (t)) - - -;;; Date: 05/10/2006 -;;; From: Rick Taube -;;; Fixed: 10/10/2006 (juanjo) -;;; Description: -;;; -;;; :INITFORM arguments do not get properly expanded when the form -;;; is a constant variable. -;;; -;;; (defclass a () ((a :initform most-positive-fixnum))) -;;; (slot-value (make-instance a) 'a) => most-positive-fixnum -;;; - -(deftest mop-0009-defclass-initform - (loop for quoting in '(nil t) - collect - (loop for f in '(most-positive-fixnum #1=#.(lambda () 1) 12 "hola" :a t nil) - collect (prog1 (eval `(progn - (defclass foo () ((a :initform ,(if quoting (list 'quote f) f)))) - (slot-value (make-instance 'foo) 'a))) - (cl-test::delete-class 'foo)))) - ((#.most-positive-fixnum #1# 12 "hola" :a t nil) - (most-positive-fixnum #1# 12 "hola" :a t nil))) - - -;; Test MOP dependents -(defclass mop-dependent-object () - ((log :initform nil :initarg :log :accessor mop-dependent-object-log))) - -(defmethod update-dependent ((object t) (dep mop-dependent-object) &rest initargs) - (push (list* object initargs) (mop-dependent-object-log dep))) - -;;; Date: 23/04/2012 -;;; Description: -;;; -;;; ADD-DEPENDENT uses pushnew -;;; -(deftest mop-gf-add-non-redundant - (let* ((dep (make-instance 'mop-dependent-object)) - l1 l2) - (fmakunbound 'mop-gf-add/remove-dependent) - (defgeneric mop-gf-add/remove-dependent (a)) - (let ((f #'mop-gf-add/remove-dependent)) - (clos:add-dependent f dep) - (setf l1 (clos::generic-function-dependents f)) - (clos:add-dependent f dep) - (setf l2 (clos::generic-function-dependents f)) - (and (eq l1 l2) - (equalp l1 (list dep)) - t))) - t) - -;;; Date: 23/04/2012 -;;; Description: -;;; -;;; Generic functions have dependents and are activated -;;; -(deftest mop-gf-add/remove-dependent - (let* ((dep (make-instance 'mop-dependent-object)) - l1 l2 l3 l4 l5 l6) - (fmakunbound 'mop-gf-add/remove-dependent) - (defgeneric mop-gf-add/remove-dependent (a)) - (let ((f #'mop-gf-add/remove-dependent) - m1 m2) - ;; - ;; * ADD-DEPENDENT registers the object with the function - ;; - (clos:add-dependent f dep) - (setf l1 (clos::generic-function-dependents f)) - ;; - ;; * ADD-METHOD invokes UPDATE-DEPENDENT - ;; - (defmethod mop-gf-add/remove-dependent ((a number)) (cos a)) - (setf l2 (mop-dependent-object-log dep)) - ;; - ;; * REMOVE-METHOD invokes UPDATE-DEPENDENT - ;; - (setf m1 (first (compute-applicable-methods f (list 1.0)))) - (remove-method f m1) - (setf l3 (mop-dependent-object-log dep)) - ;; - ;; * REMOVE-DEPENDENT eliminates all dependencies - ;; - (clos:remove-dependent f dep) - (setf l4 (clos::generic-function-dependents f)) - ;; - ;; * ADD-METHOD invokes UPDATE-DEPENDENT but has no effect - ;; - (defmethod mop-gf-add/remove-dependent ((a symbol)) a) - (setf l5 (mop-dependent-object-log dep)) - ;; - ;; * REMOVE-METHOD invokes UPDATE-DEPENDENT but has no effect - ;; - (setf m2 (first (compute-applicable-methods f (list 'a)))) - (setf l6 (mop-dependent-object-log dep)) - ;; the first call to defmethod adds two entries: one for the - ;; add-method and another one for a reinitialize-instance with - ;; the name of the function - (values (equalp l1 (list dep)) - (eq l2 (rest l3)) - (equalp l3 - (list (list f 'remove-method m1) - (list f 'add-method m1) - (list f))) - (null l4) - (eq l5 l3) - (eq l6 l3) - t))) - t t t t t t t) - -;;; Date: 23/04/2012 -;;; Description: -;;; -;;; ADD-DEPENDENT does not duplicate elements -;;; -(deftest mop-class-add/remove-dependent - (let* ((dep (make-instance 'mop-dependent-object)) - l1 l2) - (when (find-class 'mop-class-add/remove-dependent nil) - (setf (class-name (find-class 'mop-class-add/remove-dependent)) nil)) - (defclass mop-class-add/remove-dependent () ()) - (let ((f (find-class 'mop-class-add/remove-dependent))) - (clos:add-dependent f dep) - (setf l1 (clos::class-dependents f)) - (clos:add-dependent f dep) - (setf l2 (clos::class-dependents f)) - (and (eq l1 l2) - (equalp l1 (list dep)) - t))) - t) - -;;; Date: 23/04/2012 -;;; Description: -;;; -;;; Standard classes have dependents and are activated -;;; -(deftest mop-class-add/remove-dependent - (let* ((dep (make-instance 'mop-dependent-object)) - l1 l2 l3 l4 l5) - (when (find-class 'mop-class-add/remove-dependent nil) - (setf (class-name (find-class 'mop-class-add/remove-dependent)) nil)) - (defclass mop-class-add/remove-dependent () ()) - (let ((f (find-class 'mop-class-add/remove-dependent))) - ;; - ;; * ADD-DEPENDENT registers the object with the class - ;; - (clos:add-dependent f dep) - (setf l1 (clos::class-dependents f)) - ;; - ;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT - ;; - (defclass mop-class-add/remove-dependent () (a)) - (setf l2 (clos::class-dependents f)) - (setf l3 (mop-dependent-object-log dep)) - ;; - ;; * REMOVE-DEPENDENT eliminates object from list - ;; - (clos:remove-dependent f dep) - (setf l4 (clos::class-dependents f)) - ;; - ;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT without effect - ;; - (defclass mop-class-add/remove-dependent () ()) - (setf l5 (mop-dependent-object-log dep)) - ;; - ;; the first call to defclass adds one entry with the reinitialization - ;; of the class both in name and list of slots - (and (equalp l1 (list dep)) - (eq l1 l2) - (equalp l3 - (list (list f :name 'mop-class-add/remove-dependent - :direct-superclasses nil - :direct-slots '((:name a))))) - (null l4) - (eq l5 l3) - t))) - t) - - -;; Test MOP dispatch - -;;; Date: 23/04/2012 -;;; Description: -;;; -;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES works with one and -;;; two methods and no EQL. -;;; -(deftest mop-c-a-m-u-c-two-methods - (progn - (fmakunbound 'mop-fn) - (defgeneric mop-fn (a) - (:method ((a number)) (cos a)) - (:method ((a symbol)) a)) - (let ((m1 (compute-applicable-methods #'mop-fn (list 1.0))) - (m2 (compute-applicable-methods #'mop-fn (list 'a)))) - (flet ((f (class) - (multiple-value-list (clos:compute-applicable-methods-using-classes - #'mop-fn (list (find-class class)))))) - (and (equalp (f 'number) (list m1 t)) - (equalp (f 'real) (list m1 t)) - (equalp (f 'symbol) (list m2 t)) - (equalp (f 'cons) '(nil t)) - t)))) - t) - -;;; Date: 23/04/2012 -;;; Description: -;;; -;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES fails with EQL -;;; specializers when one of the specializers is covered by the -;;; classes. -;;; -(deftest mop-c-a-m-u-c-fails-with-eql - (progn - (fmakunbound 'mop-fn) - (defgeneric mop-fn (a) - (:method ((a (eql 1))) 1) - (:method ((a (eql 'a))) 2) - (:method ((a float)) 3)) - (let ((m1 (compute-applicable-methods #'mop-fn (list 1))) - (m2 (compute-applicable-methods #'mop-fn (list 'a))) - (m3 (compute-applicable-methods #'mop-fn (list 1.0)))) - (flet ((f (class) - (multiple-value-list (clos:compute-applicable-methods-using-classes - #'mop-fn (list (find-class class)))))) - (and (equalp (f 'integer) (list nil nil)) - (equalp (f 'number) (list nil nil)) - (equalp (f 'symbol) (list nil nil)) - (equalp (f 'float) (list m3 t)) - (= (length m1) 1) - (= (length m2) 1) - (= (length m3) 1) - t)))) - t) - -;;; Date: 24/04/2012 -;;; Description: -;;; -;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked and honored by ECL. -;;; -(deftest mop-discriminator - (progn - (fmakunbound 'foo) - (defclass my-generic-function (standard-generic-function) - ()) - (defmethod clos:compute-discriminating-function ((gf my-generic-function)) - ;; We compute the invocaions of c-d-f. Note that it is invoked - ;; quite often -- we could probably optimize this. - #'(lambda (&rest args) - args)) - (defgeneric foo (a) - (:generic-function-class my-generic-function)) - (unwind-protect - (foo 2) - (fmakunbound 'foo))) - (2)) - -;;; Date: 24/04/2012 -;;; Description: -;;; -;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked on ADD-METHOD, REMOVE-METHOD, -;;; DEFGENERIC, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE acting on -;;; generic functions. -;;; -(deftest mop-discriminator-recomputation - (progn - (defparameter *mop-discriminator-recomputation* 0) - (fmakunbound 'foo) - (defclass my-generic-function (standard-generic-function) - ()) - (defmethod clos:compute-discriminating-function ((gf my-generic-function)) - ;; We compute the invocaions of c-d-f. Note that it is invoked - ;; quite often -- we could probably optimize this. - (incf *mop-discriminator-recomputation*) - (call-next-method)) - (and (progn - (setf *mop-discriminator-recomputation* 0) - (eval '(defgeneric foo (a) - (:generic-function-class my-generic-function))) - (plusp *mop-discriminator-recomputation* )) - (typep #'foo 'my-generic-function) - (progn - (setf *mop-discriminator-recomputation* 0) - (eval '(defmethod foo ((a number)) (print a))) - (plusp *mop-discriminator-recomputation*)) - (progn - (setf *mop-discriminator-recomputation* 0) - (eval '(remove-method #'foo (first (compute-applicable-methods - #'foo - (list 1.0))))) - (plusp *mop-discriminator-recomputation*)) - t)) - t) - -;;; Date: 24/04/2012 -;;; Description: -;;; -;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS-USING-CLASSES for -;;; user-defined generic function classes. -;;; -(deftest mop-compute-applicable-methods-using-classes-is-honored - (progn - (defparameter *mop-dispatch-used* 0) - (fmakunbound 'foo) - (defclass my-generic-function (standard-generic-function) - ()) - (defmethod clos:compute-applicable-methods-using-classes - ((gf my-generic-function) classes) - (incf *mop-dispatch-used*) - (call-next-method)) - (defgeneric foo (a) - (:generic-function-class my-generic-function) - (:method ((a number)) (cos 1.0))) - (and (zerop *mop-dispatch-used*) - (progn (foo 1.0) (plusp *mop-dispatch-used*)))) - t) - -;;; Date: 24/04/2012 -;;; Description: -;;; -;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS for -;;; user-defined generic function classes. -;;; -(deftest mop-compute-applicable-methods-is-honored - (progn - (defparameter *mop-dispatch-used* 0) - (fmakunbound 'foo) - (defclass my-generic-function (standard-generic-function) - ()) - (defmethod clos:compute-applicable-methods-using-classes - ((gf my-generic-function) classes) - (incf *mop-dispatch-used*) - (values nil nil)) - (defmethod compute-applicable-methods - ((gf my-generic-function) args) - (incf *mop-dispatch-used*) - (call-next-method)) - (defgeneric foo (a) - (:generic-function-class my-generic-function) - (:method ((a number)) (cos 1.0))) - (and (zerop *mop-dispatch-used*) - (progn (foo 1.0) (= *mop-dispatch-used* 2)))) - t) - -;;; From: Pascal Costanza -;;; Description: -;;; -;;; sort-applicable-methods is invoked by two methods and one -;;; invocation triggers a disambiguation error: -;;; -;;; Condition of type: SIMPLE-ERROR -;;; The type specifiers # and # can not be disambiguated with respect to the argument specializer: # -(deftest mop-compute-applicable-methods-disambiguation.0001 - (ext:with-clean-symbols (a b c f) - (defclass a () ()) - (defclass b () ()) - (defclass c (a b) ()) - (defmethod f ((o a))) - (defmethod f ((o b))) - (compute-applicable-methods-using-classes - #'f (list (find-class 'c))) - T) - T) - - diff --git a/src/tests/regressions/tests/mixed.lsp b/src/tests/regressions/tests/mixed.lsp deleted file mode 100644 index 209c3b7fb..000000000 --- a/src/tests/regressions/tests/mixed.lsp +++ /dev/null @@ -1,146 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Contains: Various regression tests for ECL - -(in-package :cl-test) - - -;;; (EXT:PACKAGE-LOCK) returned the wrong value. -;;; Fixed in 77a267c7e42860affac8eddfcddb8e81fccd44e5 - -(deftest mixed-0001-package-lock - (progn - ;; Don't know the first state - (ext:package-lock "CL-USER" nil) - (values - (ext:package-lock "CL-USER" t) - (ext:package-lock "CL-USER" nil) - (ext:package-lock "CL-USER" nil))) - nil t nil) - - -;; Bugs from sourceforge - -(deftest mixed.0002.mvb-not-evaled - (assert - (eq :ok - (block nil - (tagbody - (return (multiple-value-bind () - (go :fail) :bad)) - :fail - (return :ok))))) - nil) - - - -(declaim (ftype (function (cons) t) mixed.0003.foo)) -(declaim (ftype (function (t cons) t) (setf mixed.0003.foo))) - -(defun mixed.0003.foo (cons) - (first cons)) - -(defun (setf mixed.0003.foo) (value cons) - (setf (first cons) value)) - -(defvar mixed.0003.*c* (cons 'x 'y)) - -(deftest mixed.0003.declaim-type.1 - (mixed.0003.foo mixed.0003.*c*) ;; correctly returns x - x) - -;; signals an error: -;; Z is not of type CONS. -;; [Condition of type TYPE-ERROR] -(deftest mixed.0004.declaim-type.2 - (assert (eq 'z - (setf (mixed.0003.foo mixed.0003.*c*) 'z))) - nil) - -(compile nil - `(lambda (x) - (1+ (the (values integer string) - (funcall x))))) - - - -(deftest mixed.0005.style-warning-argument-order - (let ((warning nil)) - (assert - (eq :ok - (handler-bind - ((style-warning - (lambda (c) - (format t "got style-warning: ~s~%" c) - (setf warning c)))) - (block nil - (tagbody - (return (multiple-value-bind () (go :fail) :bad)) - :fail - (return :ok)))))) - (assert (not warning))) - nil) - -(deftest mixed.0006.write-hash-readable - (hash-table-count - (read-from-string - (write-to-string (make-hash-table) - :readably t))) - 0) - -(deftest mixed.0007.find-package.1 - (assert - (let ((string ":cl-user")) - (find-package - (let ((*package* (find-package :cl))) - (read-from-string string))))) - nil) - -(deftest mixed.0008.find-package.2 - (assert - (let ((string ":cl-user")) - (let ((*package* (find-package :cl))) - (find-package - (read-from-string string))))) - nil) - - - -;;; Date: 2016-05-21 (Masataro Asai) -;;; Description: -;;; -;;; RESTART-CASE investigates the body in an incorrect manner, -;;; then remove the arguments to SIGNAL, which cause the slots of -;;; the conditions to be not set properly. -;;; -;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/247 -;;; -(ext:with-clean-symbols (x) - (define-condition x () ((y :initarg :y))) - (deftest mixed.0009.restart-case-body - (handler-bind ((x (lambda (c) (slot-value c 'y)))) - (restart-case - (signal 'x :y 1))) - nil)) - - -;;; Date: 2016-04-21 (Juraj) -;;; Fixed: 2016-06-21 (Daniel Kochmański) -;;; Description: -;;; -;;; Trace did not respect *TRACE-OUTPUT*. -;;; -;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/236 -;;; -(ext:with-clean-symbols (fact) - (deftest mixed.0010.*trace-output* - (progn - (defun fact (n) (if (zerop n) :boom (fact (1- n)))) - (zerop (length - (with-output-to-string (*trace-output*) - (trace fact) - (fact 3) - (untrace fact) - *trace-output*)))) - nil)) diff --git a/src/tests/regressions/tests/random-states.lsp b/src/tests/regressions/tests/random-states.lsp deleted file mode 100644 index aa550f830..000000000 --- a/src/tests/regressions/tests/random-states.lsp +++ /dev/null @@ -1,55 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Daniel Kochmański -;;;; Created: 2015-09-21 -;;;; Contains: Random state tests - -(in-package :cl-test) - -;; Trivial case -(deftest random-states.0001 - (numberp (random 18)) - T) - -;; Check if we can generate random number from a read random state -(deftest random-states.0002 - (numberp (random 18 #$1)) - T) - -;; Check if we can generate random number from a new random state -(deftest random-states.0003 - (numberp (random 18 (make-random-state))) - T) - -;; Check if we can copy use copied random state from reader -(deftest random-states.0004 - (numberp (random 18 (make-random-state #$1))) - T) - -;; Check if the same seed produces the same result -(deftest random-states.0005 - (= (random 18 #$1) - (random 18 #$1) - (random 18 #$1)) - T) - -;; Check if we get the same table from the same seed -(deftest random-states.0005 - (let ((*print-readably* t) - (rs (make-random-state #$1))) - (equalp - (format nil "~S" #$1) - (format nil "~S" rs))) - T) - -;; Check if we can read back the random state -(deftest random-states.0006 - (let* ((*print-readably* t) - (rs (make-random-state #$1)) - (rs-read (read-from-string - (format nil "~S" rs)))) - (equalp - (format nil "~S" rs-read) - (format nil "~S" rs))) - T) diff --git a/src/tests/regressions/tests/test-ansi.lsp b/src/tests/regressions/tests/test-ansi.lsp deleted file mode 100644 index 50f5ef02c..000000000 --- a/src/tests/regressions/tests/test-ansi.lsp +++ /dev/null @@ -1,126 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -(in-package :cl-test) - - - -;;;;;;;;;;;;;;;;;;;;;;;;; -;; 2.* Readtable tests ;; -;;;;;;;;;;;;;;;;;;;;;;;;; - -(symbol-macrolet ((lookup-table - '(:SYMBOL ("zebra" "Zebra" "ZEBRA" "zebr\\a" "zebr\\A" - "ZEBR\\a""ZEBR\\A" "Zebr\\a" "Zebr\\A") - :UPCASE (|ZEBRA| |ZEBRA| |ZEBRA| |ZEBRa| - |ZEBRA| |ZEBRa| |ZEBRA| |ZEBRa| |ZEBRA|) - :DOWNCASE (|zebra| |zebra| |zebra| |zebra| - |zebrA| |zebra| |zebrA| |zebra| |zebrA|) - :PRESERVE (|zebra| |Zebra| |ZEBRA| |zebra| - |zebrA| |ZEBRa| |ZEBRA| |Zebra| |ZebrA|) - :INVERT (|ZEBRA| |Zebra| |zebra| |ZEBRa| - |ZEBRA| |zebra| |zebrA| |Zebra| |ZebrA|)))) - (macrolet - ((def-readtable-case-test (reader-case) - `(deftest ,(concatenate 'string "TEST-ANSI.READTABLE.CASE-" - (symbol-name reader-case)) - (let ((*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) ,reader-case) - (mapcar #'(lambda (x) - (read-from-string x)) - ',(getf lookup-table :symbol))) - ,(getf lookup-table reader-case)))) - (def-readtable-case-test :upcase) - (def-readtable-case-test :downcase) - (def-readtable-case-test :preserve) - (def-readtable-case-test :invert))) - -;; when readtable was :invert characters got inverted too -(deftest test-ansi.readtable.invert-char - (let ((*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) :invert) - (read-from-string "#\\a")) - #\a 3) - - - -;; HyperSpec – 3.* - -;;;;;;;;;;;;;;;;;;; -;; Deftype tests ;; -;;;;;;;;;;;;;;;;;;; - -(deftest test-ansi.deftype.ordinary.1 - (progn - (deftype ordinary1 () `(member nil t)) - (values (typep T 'ordinary1) - (typep :a 'ordinary1))) - T NIL) - -(deftest test-ansi.deftype.ordinary.2 - (progn - (deftype ordinary2 (a b) - (if a - 'CONS - `(INTEGER 0 ,b))) - (values (typep T '(ordinary2 nil 3)) - (typep 3 '(ordinary2 nil 4)) - (typep T '(ordinary2 T nil)) - (typep '(1 . 2) '(ordinary2 T nil)))) - nil t nil t) - -(deftest test-ansi.deftype.optional - (progn - (deftype optional (a &optional b) - (if a - 'CONS - `(INTEGER 0 ,b))) - (values (typep 5 '(optional nil)) - (typep 5 '(optional nil 4)))) - t nil) - -(deftest test-ansi.deftype.nested - (progn - (deftype nested ((a &optional b) c . d) - (assert (listp d)) - `(member ,a ,b ,c)) - (values - (typep 1 '(nested (1 2) 3 4 5 6)) - (typep 1 '(nested (2 2) 3 4 5 6)) - (typep '* '(nested (3) 3)) - (typep 3 '(nested (2) 3)))) - t nil t t) - - - -;;;;;;;;;;;;;;;;;;;;;;;;; -;; 19.* Pathname tests ;; -;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Issue #103 ;; logical-pathname-translations not translating -;; https://gitlab.com/embeddable-common-lisp/ecl/issues/103 -(deftest* test-ansi.pathname.wildcards.1 - (namestring - (progn - (setf (logical-pathname-translations "prog") - '(("CODE;*.*.*" "/tmp/prog/"))) - (translate-logical-pathname "prog:code;documentation.lisp"))) - (list (namestring #P"/tmp/prog/documentation.lisp"))) - - - -;;;;;;;;;;;;;;;;;;;;;;; -;; 23.* Reader tests ;; -;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct sharp-s-reader.1.example-struct a) - -(deftest test-ansi.reader.sharp-s-reader.1 - (prog1 - (signals-error - (read-from-string - "(#1=\"Hello\" #S(sharp-s-reader.1.example-struct :A #1#))") - program-error)) - nil) - - diff --git a/src/tests/regressions/tools.lsp b/src/tests/regressions/tools.lsp deleted file mode 100644 index f0e983b29..000000000 --- a/src/tests/regressions/tools.lsp +++ /dev/null @@ -1,43 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Juan Jose Garcia-Ripoll -;;;; Created: Fri Apr 14 11:13:17 CEST 2006 -;;;; Contains: Tools for doing tests, intercepting functions, etc. - -(defmacro with-dflet (functions &body body) - "Syntax: - (with-dflet ((fname form*)*) body) -Evaluate BODY in an environment in which the function FNAME has been redefined -to evaluate the given forms _before_ executing the orginal code." - (let ((vars '()) (in-forms '()) (out-forms '())) - (loop for (name . forms) in functions - do (let ((var (gensym))) - (push `(,var #',name) vars) - (push `(setf (fdefinition ',name) - #'(lambda (&rest args) ,@forms (apply ,var args))) - in-forms) - (push `(setf (fdefinition ',name) ,var) out-forms))) - `(let ,vars - (unwind-protect - (progn ,@in-forms ,@body) - (progn ,@out-forms))))) - -(defmacro with-compiler ((filename &rest compiler-args) &body forms) - "Create a lisp file with the given forms and compile it. The forms are -evaluated. The output is stored in a string and output as a second value." - `(progn - (with-open-file (s ,filename :direction :output :if-exists :supersede - :if-does-not-exist :create) - ,@(loop for f in forms collect `(print ,f s))) - (let* ((ok t) - (output - (with-output-to-string (*standard-output*) - (let ((*error-output* *standard-output*) - (*compile-verbose* t) - (*compile-print* t)) - (setf ok (compile-file ,filename ,@compiler-args)))))) - (values ok output)))) - - - diff --git a/src/tests/stress/tests/multiprocessing.lsp b/src/tests/stress/multiprocessing.lsp similarity index 100% rename from src/tests/stress/tests/multiprocessing.lsp rename to src/tests/stress/multiprocessing.lsp diff --git a/src/tests/regressions/universe.lsp b/src/tests/universe.lisp similarity index 100% rename from src/tests/regressions/universe.lsp rename to src/tests/universe.lisp From 36a06c74e97cc925212fdc6c432867cde4c465da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 7 Aug 2016 17:05:07 +0200 Subject: [PATCH 26/92] tests: fix a few mistakes --- src/tests/regressions/.#compiler.lsp | 1 - src/tests/regressions/mixed.lsp | 15 ++++++++------- 2 files changed, 8 insertions(+), 8 deletions(-) delete mode 120000 src/tests/regressions/.#compiler.lsp diff --git a/src/tests/regressions/.#compiler.lsp b/src/tests/regressions/.#compiler.lsp deleted file mode 120000 index 8fb655653..000000000 --- a/src/tests/regressions/.#compiler.lsp +++ /dev/null @@ -1 +0,0 @@ -jack@pandora.670:1470121845 \ No newline at end of file diff --git a/src/tests/regressions/mixed.lsp b/src/tests/regressions/mixed.lsp index 2845b8c05..301e03e3c 100644 --- a/src/tests/regressions/mixed.lsp +++ b/src/tests/regressions/mixed.lsp @@ -113,13 +113,14 @@ (ext:with-clean-symbols (fact) (defun fact (n) (if (zerop n) :boom (fact (1- n)))) (test mix.0008.trace-output - (is-eql 0 - (length - (with-output-to-string (*trace-output*) - (trace fact) - (fact 3) - (untrace fact) - *trace-output*))))) + (is + (not (zerop + (length + (with-output-to-string (*trace-output*) + (trace fact) + (fact 3) + (untrace fact) + *trace-output*))))))) ;;;; Author: Daniel Kochmański From f72077549c2352a73b8dae603d6e4fe7df03080c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 7 Aug 2016 17:19:01 +0200 Subject: [PATCH 27/92] tests: simplify make target --- src/tests/Makefile.in | 41 ++++++++--------------------------------- src/tests/config.lsp.in | 41 +++++++++++++---------------------------- src/tests/doit.lsp | 10 ++++++++++ 3 files changed, 31 insertions(+), 61 deletions(-) create mode 100644 src/tests/doit.lsp diff --git a/src/tests/Makefile.in b/src/tests/Makefile.in index 7cc820c83..7189030a7 100755 --- a/src/tests/Makefile.in +++ b/src/tests/Makefile.in @@ -3,40 +3,15 @@ ECL=@prefix@/@bindir@/ecl@EXEEXT@ -all: show-fails +.PHONY: all -.PHONY: do-regressions cleanup clean-sources update +all: check -BUGS_FILES := $(shell find ../../src/tests/regressions/ -type f) +check: config.lsp + $(ECL) -norc -load config.lsp \ + -eval '(ecl-tests::run-regressions-tests)' \ + -eval '(ext:quit)' \ + 2>&1 | tee check.log -regressions.log: config.lsp - $(MAKE) do-regressions - -do-regressions: regressions config.lsp - $(ECL) -norc -load config.lsp -eval '(ecl-tests::run-regressions-tests)' -eval '(ext:quit)' 2>&1 | tee regressions.log - -show-fails: regressions.log - tail -n 16 regressions.log - -# -# Create directories -# -regressions: config.lsp $(BUGS_FILES) - $(ECL) -norc -load config.lsp -eval '(ecl-tests::ensure-regressions)' -eval '(ext:quit)' < /dev/null - -# -# Cleanup -# clean: - rm -rf regressions.log - -clean-sources: - test -f config.lsp.in || rm -rf bugs - rm -rf regressions - -distclean: clean-sources clean - rm -rf cache - -update: clean-sources - $(MAKE) regressions - + rm -rf regressions.log cache diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in index 3d535ab95..4ab1e8c8f 100755 --- a/src/tests/config.lsp.in +++ b/src/tests/config.lsp.in @@ -3,6 +3,7 @@ ;;; ;;; (c) 2011, Juan Jose Garcia-Ripoll +;;; (c) 2016, Daniel Kochmański ;;; ;;; Set up the test environment. ;;; @@ -23,32 +24,26 @@ (defvar *test-sources* (merge-pathnames "tests/" *ecl-sources*)) (defvar *here* (merge-pathnames "@builddir@/")) - (defvar *cache* (merge-pathnames "./cache/" *here*)) -(defvar *test-image* (or (ext:getenv "TEST_IMAGE") - #+windows - (namestring (truename #+windows "sys:ecl.exe")) - #-windows - "@prefix@/bin/ecl")) +(defvar *test-image* + (or (ext:getenv "TEST_IMAGE") + #+windows (namestring (truename "sys:ecl.exe")) + #-windows "@prefix@/bin/ecl")) (defvar *test-image-args* - (cond ((search "ecl" *test-image*) - '("-norc" "-eval" "(print (ext:getenv \"ECLDIR\"))" - ;#+windows "-eval" #+windows "(require :cmp)" - )) - ((search "sbcl" *test-image*) - '("--no-userinit" "--no-sysinit")) - (t - '()))) + `("-norc" + "-eval" "(print (ext:getenv \"ECLDIR\"))" + "-eval" "(ignore-errors (require :cmp))" + "-load" ,(namestring (merge-pathnames "doit.lsp" *test-sources*)) + "-eval" "(quit)")) #+ecl (ext:setenv "ECLDIR" (namestring (truename "SYS:"))) (defvar *test-name* (or (ext:getenv "TEST_NAME") "ecl")) -(defvar *output-directory* *here*) -(defvar *regressions-sources* (merge-pathnames "regressions/" *test-sources*)) -(defvar *regressions-sandbox* (merge-pathnames "regressions/" *here*)) +(defvar *regressions-sources* *test-sources*) +(defvar *regressions-sandbox* *here*) (defvar *wild-inferiors* (make-pathname :name :wild :type :wild :version :wild @@ -68,19 +63,10 @@ (merge-pathnames "**/*.*" (lisp-system-directory))))) -(require :cmp) - ;;; ;;; PREPARATION OF DIRECTORIES AND FILES ;;; -(defun setup-asdf () - (require :asdf) - (ensure-directories-exist *cache*) - (setf (symbol-value (read-from-string "asdf::*user-cache*")) - (list *cache* :implementation))) - - (defun delete-everything (path) ;; Recursively run through children (labels ((recursive-deletion (path) @@ -116,7 +102,6 @@ (unless (probe-file *regressions-sandbox*) (copy-directory *regressions-sources* *regressions-sandbox*))) - (defun cleanup-directory (path) (loop for i in (directory (merge-pathnames *wild-inferiors* path)) @@ -136,7 +121,7 @@ (ext:chdir *regressions-sandbox*) (ext:run-program *test-image* *test-image-args* - :input (merge-pathnames "doit.lsp" *regressions-sandbox*) + :input nil ; (merge-pathnames "doit.lsp" *regressions-sources*) :output t :error :output)) (ext:chdir *here*))) diff --git a/src/tests/doit.lsp b/src/tests/doit.lsp new file mode 100644 index 000000000..48c23f2df --- /dev/null +++ b/src/tests/doit.lsp @@ -0,0 +1,10 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :asdf)) + +(let ((cache (merge-pathnames "./cache/" *default-pathname-defaults*))) + (ensure-directories-exist cache) + (setf asdf:*user-cache* cache) + (asdf:load-asd (merge-pathnames "ecl-tests.asd" *load-pathname*))) + +(asdf:operate 'asdf:load-source-op 'ecl-tests) +(2am-ecl:run 'cl-test::regressions) From 5761230e15774ba868577d06d69d4df095320a94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Aug 2016 16:29:32 +0200 Subject: [PATCH 28/92] tests: fix format test --- .../eformat-tests/hebrew_latin8_cr.txt | 0 .../eformat-tests/hebrew_latin8_crlf.txt | 0 .../eformat-tests/hebrew_latin8_lf.txt | 0 .../eformat-tests/hebrew_utf8_cr.txt | 0 .../eformat-tests/hebrew_utf8_crlf.txt | 0 .../eformat-tests/hebrew_utf8_lf.txt | 0 .../eformat-tests/kafka_cp1252_cr.txt | 0 .../eformat-tests/kafka_cp1252_crlf.txt | 0 .../eformat-tests/kafka_cp1252_lf.txt | 0 .../eformat-tests/kafka_latin1_cr.txt | 0 .../eformat-tests/kafka_latin1_crlf.txt | 0 .../eformat-tests/kafka_latin1_lf.txt | 0 .../eformat-tests/kafka_utf8_cr.txt | 0 .../eformat-tests/kafka_utf8_crlf.txt | 0 .../eformat-tests/kafka_utf8_lf.txt | 0 .../eformat-tests/russian_koi8r_cr.txt | 0 .../eformat-tests/russian_koi8r_crlf.txt | 0 .../eformat-tests/russian_koi8r_lf.txt | 0 .../eformat-tests/russian_utf8_cr.txt | 0 .../eformat-tests/russian_utf8_crlf.txt | 0 .../eformat-tests/russian_utf8_lf.txt | 0 .../eformat-tests/tilton_ascii_cr.txt | 0 .../eformat-tests/tilton_ascii_crlf.txt | 0 .../eformat-tests/tilton_ascii_lf.txt | 0 .../eformat-tests/tilton_utf8_cr.txt | 0 .../eformat-tests/tilton_utf8_crlf.txt | 0 .../eformat-tests/tilton_utf8_lf.txt | 0 .../eformat-tests/unicode_demo_ucs2_cr_be.txt | Bin .../eformat-tests/unicode_demo_ucs2_cr_le.txt | Bin .../unicode_demo_ucs2_crlf_be.txt | Bin .../unicode_demo_ucs2_crlf_le.txt | Bin .../eformat-tests/unicode_demo_ucs2_lf_be.txt | Bin .../eformat-tests/unicode_demo_ucs2_lf_le.txt | Bin .../eformat-tests/unicode_demo_ucs4_cr_be.txt | Bin .../eformat-tests/unicode_demo_ucs4_cr_le.txt | Bin .../unicode_demo_ucs4_crlf_be.txt | Bin .../unicode_demo_ucs4_crlf_le.txt | Bin .../eformat-tests/unicode_demo_ucs4_lf_be.txt | Bin .../eformat-tests/unicode_demo_ucs4_lf_le.txt | Bin .../eformat-tests/unicode_demo_utf8_cr.txt | 0 .../eformat-tests/unicode_demo_utf8_crlf.txt | 0 .../eformat-tests/unicode_demo_utf8_lf.txt | 0 src/tests/doit.lsp | 2 + src/tests/ecl-tests.lisp | 42 ++++++++++-------- src/tests/features/external-formats.lsp | 15 ++++--- 45 files changed, 36 insertions(+), 23 deletions(-) rename src/tests/{features => auxiliary}/eformat-tests/hebrew_latin8_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/hebrew_latin8_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/hebrew_latin8_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/hebrew_utf8_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/hebrew_utf8_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/hebrew_utf8_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_cp1252_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_cp1252_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_cp1252_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_latin1_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_latin1_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_latin1_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_utf8_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_utf8_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/kafka_utf8_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/russian_koi8r_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/russian_koi8r_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/russian_koi8r_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/russian_utf8_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/russian_utf8_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/russian_utf8_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/tilton_ascii_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/tilton_ascii_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/tilton_ascii_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/tilton_utf8_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/tilton_utf8_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/tilton_utf8_lf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs2_cr_be.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs2_cr_le.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs2_crlf_be.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs2_crlf_le.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs2_lf_be.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs2_lf_le.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs4_cr_be.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs4_cr_le.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs4_crlf_be.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs4_crlf_le.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs4_lf_be.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_ucs4_lf_le.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_utf8_cr.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_utf8_crlf.txt (100%) rename src/tests/{features => auxiliary}/eformat-tests/unicode_demo_utf8_lf.txt (100%) diff --git a/src/tests/features/eformat-tests/hebrew_latin8_cr.txt b/src/tests/auxiliary/eformat-tests/hebrew_latin8_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/hebrew_latin8_cr.txt rename to src/tests/auxiliary/eformat-tests/hebrew_latin8_cr.txt diff --git a/src/tests/features/eformat-tests/hebrew_latin8_crlf.txt b/src/tests/auxiliary/eformat-tests/hebrew_latin8_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/hebrew_latin8_crlf.txt rename to src/tests/auxiliary/eformat-tests/hebrew_latin8_crlf.txt diff --git a/src/tests/features/eformat-tests/hebrew_latin8_lf.txt b/src/tests/auxiliary/eformat-tests/hebrew_latin8_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/hebrew_latin8_lf.txt rename to src/tests/auxiliary/eformat-tests/hebrew_latin8_lf.txt diff --git a/src/tests/features/eformat-tests/hebrew_utf8_cr.txt b/src/tests/auxiliary/eformat-tests/hebrew_utf8_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/hebrew_utf8_cr.txt rename to src/tests/auxiliary/eformat-tests/hebrew_utf8_cr.txt diff --git a/src/tests/features/eformat-tests/hebrew_utf8_crlf.txt b/src/tests/auxiliary/eformat-tests/hebrew_utf8_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/hebrew_utf8_crlf.txt rename to src/tests/auxiliary/eformat-tests/hebrew_utf8_crlf.txt diff --git a/src/tests/features/eformat-tests/hebrew_utf8_lf.txt b/src/tests/auxiliary/eformat-tests/hebrew_utf8_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/hebrew_utf8_lf.txt rename to src/tests/auxiliary/eformat-tests/hebrew_utf8_lf.txt diff --git a/src/tests/features/eformat-tests/kafka_cp1252_cr.txt b/src/tests/auxiliary/eformat-tests/kafka_cp1252_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_cp1252_cr.txt rename to src/tests/auxiliary/eformat-tests/kafka_cp1252_cr.txt diff --git a/src/tests/features/eformat-tests/kafka_cp1252_crlf.txt b/src/tests/auxiliary/eformat-tests/kafka_cp1252_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_cp1252_crlf.txt rename to src/tests/auxiliary/eformat-tests/kafka_cp1252_crlf.txt diff --git a/src/tests/features/eformat-tests/kafka_cp1252_lf.txt b/src/tests/auxiliary/eformat-tests/kafka_cp1252_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_cp1252_lf.txt rename to src/tests/auxiliary/eformat-tests/kafka_cp1252_lf.txt diff --git a/src/tests/features/eformat-tests/kafka_latin1_cr.txt b/src/tests/auxiliary/eformat-tests/kafka_latin1_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_latin1_cr.txt rename to src/tests/auxiliary/eformat-tests/kafka_latin1_cr.txt diff --git a/src/tests/features/eformat-tests/kafka_latin1_crlf.txt b/src/tests/auxiliary/eformat-tests/kafka_latin1_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_latin1_crlf.txt rename to src/tests/auxiliary/eformat-tests/kafka_latin1_crlf.txt diff --git a/src/tests/features/eformat-tests/kafka_latin1_lf.txt b/src/tests/auxiliary/eformat-tests/kafka_latin1_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_latin1_lf.txt rename to src/tests/auxiliary/eformat-tests/kafka_latin1_lf.txt diff --git a/src/tests/features/eformat-tests/kafka_utf8_cr.txt b/src/tests/auxiliary/eformat-tests/kafka_utf8_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_utf8_cr.txt rename to src/tests/auxiliary/eformat-tests/kafka_utf8_cr.txt diff --git a/src/tests/features/eformat-tests/kafka_utf8_crlf.txt b/src/tests/auxiliary/eformat-tests/kafka_utf8_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_utf8_crlf.txt rename to src/tests/auxiliary/eformat-tests/kafka_utf8_crlf.txt diff --git a/src/tests/features/eformat-tests/kafka_utf8_lf.txt b/src/tests/auxiliary/eformat-tests/kafka_utf8_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/kafka_utf8_lf.txt rename to src/tests/auxiliary/eformat-tests/kafka_utf8_lf.txt diff --git a/src/tests/features/eformat-tests/russian_koi8r_cr.txt b/src/tests/auxiliary/eformat-tests/russian_koi8r_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/russian_koi8r_cr.txt rename to src/tests/auxiliary/eformat-tests/russian_koi8r_cr.txt diff --git a/src/tests/features/eformat-tests/russian_koi8r_crlf.txt b/src/tests/auxiliary/eformat-tests/russian_koi8r_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/russian_koi8r_crlf.txt rename to src/tests/auxiliary/eformat-tests/russian_koi8r_crlf.txt diff --git a/src/tests/features/eformat-tests/russian_koi8r_lf.txt b/src/tests/auxiliary/eformat-tests/russian_koi8r_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/russian_koi8r_lf.txt rename to src/tests/auxiliary/eformat-tests/russian_koi8r_lf.txt diff --git a/src/tests/features/eformat-tests/russian_utf8_cr.txt b/src/tests/auxiliary/eformat-tests/russian_utf8_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/russian_utf8_cr.txt rename to src/tests/auxiliary/eformat-tests/russian_utf8_cr.txt diff --git a/src/tests/features/eformat-tests/russian_utf8_crlf.txt b/src/tests/auxiliary/eformat-tests/russian_utf8_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/russian_utf8_crlf.txt rename to src/tests/auxiliary/eformat-tests/russian_utf8_crlf.txt diff --git a/src/tests/features/eformat-tests/russian_utf8_lf.txt b/src/tests/auxiliary/eformat-tests/russian_utf8_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/russian_utf8_lf.txt rename to src/tests/auxiliary/eformat-tests/russian_utf8_lf.txt diff --git a/src/tests/features/eformat-tests/tilton_ascii_cr.txt b/src/tests/auxiliary/eformat-tests/tilton_ascii_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/tilton_ascii_cr.txt rename to src/tests/auxiliary/eformat-tests/tilton_ascii_cr.txt diff --git a/src/tests/features/eformat-tests/tilton_ascii_crlf.txt b/src/tests/auxiliary/eformat-tests/tilton_ascii_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/tilton_ascii_crlf.txt rename to src/tests/auxiliary/eformat-tests/tilton_ascii_crlf.txt diff --git a/src/tests/features/eformat-tests/tilton_ascii_lf.txt b/src/tests/auxiliary/eformat-tests/tilton_ascii_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/tilton_ascii_lf.txt rename to src/tests/auxiliary/eformat-tests/tilton_ascii_lf.txt diff --git a/src/tests/features/eformat-tests/tilton_utf8_cr.txt b/src/tests/auxiliary/eformat-tests/tilton_utf8_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/tilton_utf8_cr.txt rename to src/tests/auxiliary/eformat-tests/tilton_utf8_cr.txt diff --git a/src/tests/features/eformat-tests/tilton_utf8_crlf.txt b/src/tests/auxiliary/eformat-tests/tilton_utf8_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/tilton_utf8_crlf.txt rename to src/tests/auxiliary/eformat-tests/tilton_utf8_crlf.txt diff --git a/src/tests/features/eformat-tests/tilton_utf8_lf.txt b/src/tests/auxiliary/eformat-tests/tilton_utf8_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/tilton_utf8_lf.txt rename to src/tests/auxiliary/eformat-tests/tilton_utf8_lf.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs2_cr_be.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_cr_be.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs2_cr_be.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_cr_be.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs2_cr_le.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_cr_le.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs2_cr_le.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_cr_le.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs2_crlf_be.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_crlf_be.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs2_crlf_be.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_crlf_be.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs2_crlf_le.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_crlf_le.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs2_crlf_le.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_crlf_le.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs2_lf_be.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_lf_be.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs2_lf_be.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_lf_be.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs2_lf_le.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_lf_le.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs2_lf_le.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs2_lf_le.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs4_cr_be.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_cr_be.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs4_cr_be.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_cr_be.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs4_cr_le.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_cr_le.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs4_cr_le.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_cr_le.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs4_crlf_be.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_crlf_be.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs4_crlf_be.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_crlf_be.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs4_crlf_le.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_crlf_le.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs4_crlf_le.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_crlf_le.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs4_lf_be.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_lf_be.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs4_lf_be.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_lf_be.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_ucs4_lf_le.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_lf_le.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_ucs4_lf_le.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_ucs4_lf_le.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_utf8_cr.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_utf8_cr.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_utf8_cr.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_utf8_cr.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_utf8_crlf.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_utf8_crlf.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_utf8_crlf.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_utf8_crlf.txt diff --git a/src/tests/features/eformat-tests/unicode_demo_utf8_lf.txt b/src/tests/auxiliary/eformat-tests/unicode_demo_utf8_lf.txt similarity index 100% rename from src/tests/features/eformat-tests/unicode_demo_utf8_lf.txt rename to src/tests/auxiliary/eformat-tests/unicode_demo_utf8_lf.txt diff --git a/src/tests/doit.lsp b/src/tests/doit.lsp index 48c23f2df..ed65a7a38 100644 --- a/src/tests/doit.lsp +++ b/src/tests/doit.lsp @@ -1,3 +1,5 @@ +(in-package #:common-lisp-user) + (eval-when (:compile-toplevel :load-toplevel :execute) (require :asdf)) diff --git a/src/tests/ecl-tests.lisp b/src/tests/ecl-tests.lisp index e49a9640f..c747a111f 100644 --- a/src/tests/ecl-tests.lisp +++ b/src/tests/ecl-tests.lisp @@ -6,28 +6,34 @@ (in-package #:cl-test) -(suite 'ecl '(regressions features)) +;;; Set pathnames +(defparameter *aux-dir* + (merge-pathnames + "auxiliary/" + (make-pathname :directory (pathname-directory + (asdf:system-definition-pathname 'ecl-tests))))) -;;;; Declare top-level suite -(suite 'regressions '(regressions/ansi+ - regressions/mixed - regressions/cmp - regressions/emb - regressions/ffi - regressions/mop - regressions/mp)) - -(suite 'features '(features/eformat)) +(defparameter *tmp-dir* + (merge-pathnames + "temporary/" + (make-pathname :directory (pathname-directory *default-pathname-defaults*)))) -#+asdf -(setf *default-pathname-defaults* - #+asdf - (asdf:system-source-directory 'ecl-tests) - #-asdf - *load-pathname*) +;;;; Declare the suites +(suite 'ecl-tests + '(regressions features)) -(ext:chdir *default-pathname-defaults*) +(suite 'regressions + '(regressions/ansi+ + regressions/mixed + regressions/cmp + regressions/emb + regressions/ffi + regressions/mop + regressions/mp)) + +(suite 'features + '(features/eformat)) ;;; Some syntactic sugar for 2am diff --git a/src/tests/features/external-formats.lsp b/src/tests/features/external-formats.lsp index 25848c219..755b3d564 100644 --- a/src/tests/features/external-formats.lsp +++ b/src/tests/features/external-formats.lsp @@ -27,11 +27,16 @@ see for example COPY-FILE below.") ("kafka" (:utf8 :latin1 :cp1252)) ("hebrew" (:utf8 :latin8)) ("russian" (:utf8 :koi8r)) - ("tilton" (:utf8 :ascii)) - ) + ("tilton" (:utf8 :ascii))) "A list of test files where each entry consists of the name prefix and a list of encodings.") +(defparameter *eformat-tests-directory* + (merge-pathnames "eformat-tests/" *aux-dir*)) + +(defparameter *eformat-sandbox-directory* + (merge-pathnames "eformat-tests/" *tmp-dir*)) + (defun create-file-variants (file-name symbol) "For a name suffix FILE-NAME and a symbol SYMBOL denoting an encoding returns a list of pairs where the car is a full file @@ -132,10 +137,10 @@ about each individual comparison if VERBOSE is true." :external-format external-format-out) (funcall *copy-function* in out)))) (one-comparison (path-in external-format-in path-out external-format-out) - (loop with full-path-in = (merge-pathnames path-in "features/eformat-tests/") + (loop with full-path-in = (merge-pathnames path-in *eformat-tests-directory*) and full-path-out = (ensure-directories-exist - (merge-pathnames path-out "sandbox/eformat-tmp/")) - and full-path-orig = (merge-pathnames path-out "features/eformat-tests/") + (merge-pathnames path-out *eformat-sandbox-directory*)) + and full-path-orig = (merge-pathnames path-out *eformat-tests-directory*) for direction-out in '(:output :io) nconc (loop for direction-in in '(:input :io) for args = (list path-in external-format-in direction-in From 589a564334766e1d91d77d7ad3fe7e5468c4933b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Aug 2016 17:35:48 +0200 Subject: [PATCH 29/92] tests: mixed: random-state: improve test --- src/tests/regressions/mixed.lsp | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/src/tests/regressions/mixed.lsp b/src/tests/regressions/mixed.lsp index 301e03e3c..ef9ab804c 100644 --- a/src/tests/regressions/mixed.lsp +++ b/src/tests/regressions/mixed.lsp @@ -126,27 +126,24 @@ ;;;; Author: Daniel Kochmański ;;;; Created: 2015-09-21 ;;;; Contains: Random state tests -#+ (or) -(def-test mix.0009.random-states (:compile-at :definition-time) - (is (numberp (random 18)) "Trivial case") +(test mix.0009.random-states + (is (numberp (random 18)) "Can't generate trivial random number") (is (numberp (random 18 #$1)) - "Check if we can generate random number from a read random ~ - state") + "Can't generate a number from read (#$1) random state") (is (numberp (random 18 (make-random-state))) - "Check if we can generate random number from a new random ~ - state") + "Can't generate a number from a new random state") (is (numberp (random 18 (make-random-state #$1))) - "Check if we can copy use copied random state from reader") + "Can't generate a number from a new random state from reader") (is (= (random 18 #$1) (random 18 #$1) (random 18 #$1)) - "Check if the same seed produces the same result") + "Same seed produces different results") (is (let ((*print-readably* t) (rs (make-random-state #$1))) (equalp (format nil "~S" #$1) (format nil "~S" rs))) - "Check if we get the same table from the same seed") + "The same seed gives different random states") (is (let* ((*print-readably* t) (rs (make-random-state #$1)) (rs-read (read-from-string @@ -154,7 +151,7 @@ (equalp (format nil "~S" rs-read) (format nil "~S" rs))) - "Check if we can read back the random state")) + "Can't read back a random state")) ;;; Date: 2016-08-04 (jd) From c13cab3dc62737a404e5df525a7902b091167545 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Aug 2016 17:36:05 +0200 Subject: [PATCH 30/92] cosmetic: fix error message arguments --- src/clos/print.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 3ea73e293..cae11e3e0 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -150,7 +150,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) From c544f92ca3ed55b9e49bbd74a250a827cb2de3d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Aug 2016 17:49:41 +0200 Subject: [PATCH 31/92] tests: cmp: random-state: add make-load-form test --- src/tests/regressions/compiler.lsp | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/tests/regressions/compiler.lsp b/src/tests/regressions/compiler.lsp index 2880a96c9..94cba22c4 100644 --- a/src/tests/regressions/compiler.lsp +++ b/src/tests/regressions/compiler.lsp @@ -1150,3 +1150,11 @@ (declaim (ftype (function (*) (values T)) ce)) (defun ce (expression) expression) (is-false (ce nil))) + + +;;; Date 2016-08-09 (jd) +;;; Description +;;; No adequate specialization of MAKE-LOAD-FORM for an object of +;;; type RANDOM-TYPE +(test cmp.0051.make-load-form.random-state + (finishes (make-load-form (make-random-state)))) From 759854445cd25a430580c630540dcf73b7f5c705 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Aug 2016 19:34:44 +0200 Subject: [PATCH 32/92] tests: add stress tests system using 1am --- src/tests/ecl-tests.asd | 16 +++-- src/tests/stress/multiprocessing.lsp | 89 +++++++++++++--------------- 2 files changed, 53 insertions(+), 52 deletions(-) diff --git a/src/tests/ecl-tests.asd b/src/tests/ecl-tests.asd index 423fc781b..b692cf34a 100644 --- a/src/tests/ecl-tests.asd +++ b/src/tests/ecl-tests.asd @@ -5,7 +5,7 @@ :author "Daniel Kochmański " :license "LGPL-2.1+" :serial t - :components ((:file "2am") + :components ((:file "2am") ; continuous integration (:file "ecl-tests") (:file "universe") (:module regressions @@ -21,10 +21,16 @@ (:module features :default-component-class asdf:cl-source-file.lsp :components - ((:file "external-formats" :if-feature :unicode))) - (:module stress - :default-component-class asdf:cl-source-file.lsp - :components ()))) + ((:file "external-formats" :if-feature :unicode))))) + +(asdf:defsystem #:ecl-tests/stress + :serial t + :components + ((:file "1am") ; for stress tests + (:module stress + :default-component-class asdf:cl-source-file.lsp + :components + ((:file "multiprocessing" :if-feature :threads))))) ;;; General tests (asdf:defsystem #:ecl-tests/ansi) diff --git a/src/tests/stress/multiprocessing.lsp b/src/tests/stress/multiprocessing.lsp index 38c659565..256a84ab5 100644 --- a/src/tests/stress/multiprocessing.lsp +++ b/src/tests/stress/multiprocessing.lsp @@ -4,35 +4,33 @@ ;; Author: Daniel Kochmański ;; Contains: Multiprocessing stress tests +(defparameter *runs* 1000) + ;; Submitted by James M. Lawrence ;; ;; Notes: couldn't reproduce on 64-bit machine, but author uses 32-bit ;; This test uses infinite loop, this should be fixed. -(defun test (message-count worker-count) - (let ((to-workers (mp:make-semaphore)) +(1am-ecl:test semaphore.wait/signal + (let ((message-count 10000) + (worker-count 64) + (to-workers (mp:make-semaphore)) (from-workers (mp:make-semaphore))) (loop repeat worker-count - do (mp:process-run-function - "test" - (lambda () - (loop - (mp:wait-on-semaphore to-workers) - (mp:signal-semaphore from-workers))))) - (loop - (loop repeat message-count - do (mp:signal-semaphore to-workers)) - (loop repeat message-count - do (mp:wait-on-semaphore from-workers)) - (assert (zerop (mp:semaphore-count to-workers))) - (assert (zerop (mp:semaphore-count from-workers))) - (format t ".") - (finish-output)))) - -(defun run () - (test 10000 64)) - -(run) + do (mp:process-run-function + "test" + (lambda () + (loop + (mp:wait-on-semaphore to-workers) + (mp:signal-semaphore from-workers))))) + (dotimes (i *runs*) + (loop repeat message-count + do (mp:signal-semaphore to-workers)) + (loop repeat message-count + do (mp:wait-on-semaphore from-workers)) + (1am-ecl:is (zerop (mp:semaphore-count to-workers))) + (1am-ecl:is (zerop (mp:semaphore-count from-workers))) + (finish-output)))) ;; Submitted by James M. Lawrence @@ -58,8 +56,10 @@ (mp:condition-variable-wait (sema-cvar sema) (sema-lock sema))))))) -(defun test (message-count worker-count) - (let ((to-workers (make-sema)) +(1am-ecl:test semaphore/condition-wait + (let ((message-count 10000) + (worker-count 64) + (to-workers (make-sema)) (from-workers (make-sema))) (loop repeat worker-count do (mp:process-run-function @@ -68,20 +68,14 @@ (loop (dec-sema to-workers) (inc-sema from-workers))))) - (loop - (loop repeat message-count - do (inc-sema to-workers)) - (loop repeat message-count - do (dec-sema from-workers)) - (assert (zerop (sema-count to-workers))) - (assert (zerop (sema-count from-workers))) - (format t ".") - (finish-output)))) - -(defun run () - (test 10000 64)) - -(run) + (dotimes (i *runs*) + (loop repeat message-count + do (inc-sema to-workers)) + (loop repeat message-count + do (dec-sema from-workers)) + (1am-ecl:is (zerop (sema-count to-workers))) + (1am-ecl:is (zerop (sema-count from-workers))) + (finish-output)))) ;; Submitted by James M. Lawrence @@ -137,12 +131,13 @@ (loop (let ((to-workers (make-queue)) (from-workers (make-queue))) (loop repeat worker-count - do (mp:process-run-function - "test" - (lambda () - (loop (let ((message (pop-queue to-workers))) - (push-queue message from-workers) - (unless message (return))))))) + do (mp:process-run-function + "test" + (lambda () + (dotimes (i *runs*) + (let ((message (pop-queue to-workers))) + (push-queue message from-workers) + (unless message (return))))))) (loop repeat message-count do (push-queue t to-workers)) (loop repeat message-count do (pop-queue from-workers)) (loop repeat worker-count do (push-queue nil to-workers)) @@ -150,8 +145,8 @@ (format t ".") (finish-output)))) -(qtest 0 64) ; => segfault -(qtest 1 64) ; => hang -(qtest 10000 64) ; => error "Attempted to recursively lock..." +(1am-ecl:test qtest.1 (qtest 0 64)) ; => segfault +(1am-ecl:test qtest.2 (qtest 1 64)) ; => hang +(1am-ecl:test qtest.3 (qtest 10000 64)) ; => error "Attempted to recursively lock..." From eb1b36dc0407059926355a1ae97f9dccd470dd52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Aug 2016 19:35:24 +0200 Subject: [PATCH 33/92] tests: run full tests (regressions and features) --- src/tests/doit.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/doit.lsp b/src/tests/doit.lsp index ed65a7a38..1b5b2c9ef 100644 --- a/src/tests/doit.lsp +++ b/src/tests/doit.lsp @@ -9,4 +9,4 @@ (asdf:load-asd (merge-pathnames "ecl-tests.asd" *load-pathname*))) (asdf:operate 'asdf:load-source-op 'ecl-tests) -(2am-ecl:run 'cl-test::regressions) +(2am-ecl:run 'cl-test::ecl-tests) From 5fababeb35e1d6ee11eb2bd014e9b5ed25d5ce3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Aug 2016 19:48:23 +0200 Subject: [PATCH 34/92] 1am: add file --- src/tests/1am.lisp | 105 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 105 insertions(+) create mode 100644 src/tests/1am.lisp diff --git a/src/tests/1am.lisp b/src/tests/1am.lisp new file mode 100644 index 000000000..f564576fd --- /dev/null +++ b/src/tests/1am.lisp @@ -0,0 +1,105 @@ +;;; Copyright (c) 2014 James M. Lawrence +;;; +;;; 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 #:1am-ecl + (:use #:cl) + (:export #:test #:is #:signals #:run #:*tests*)) + +(in-package #:1am-ecl) + +(defvar *tests* nil "A list of tests; the default argument to `run'.") +(defvar *pass-count* nil) +(defvar *running* nil) +(defvar *failed-random-state* nil) + +(defun %shuffle (vector) + (loop for i downfrom (- (length vector) 1) to 1 + do (rotatef (aref vector i) (aref vector (random (1+ i))))) + vector) + +(defun shuffle (sequence) + (%shuffle (map 'vector #'identity sequence))) + +(defun call-with-random-state (fn) + (let ((*random-state* (or *failed-random-state* + (load-time-value (make-random-state t))))) + (setf *failed-random-state* (make-random-state nil)) + (multiple-value-prog1 (funcall fn) + (setf *failed-random-state* nil)))) + +(defun report (test-count pass-count) + (format t "~&Success: ~s test~:p, ~s check~:p.~%" test-count pass-count)) + +(defun %run (fn test-count) + (let ((*pass-count* 0)) + (multiple-value-prog1 (call-with-random-state fn) + (report test-count *pass-count*)))) + +(defun run (&optional (tests *tests*)) + "Run each test in the sequence `tests'. Default is `*tests*'." + (let ((*running* t)) + (%run (lambda () (map nil #'funcall (shuffle tests))) + (length tests))) + (values)) + +(defun call-test (name fn) + (format t "~&~s" name) + (finish-output) + (if *running* + (funcall fn) + (%run fn 1))) + +(defmacro test (name &body body) + "Define a test function and add it to `*tests*'." + `(progn + (defun ,name () + (call-test ',name (lambda () ,@body))) + (pushnew ',name *tests*) + ',name)) + +(defun passed () + (write-char #\.) + ;; Checks done outside a test run are not tallied. + (when *pass-count* + (incf *pass-count*)) + (values)) + +(defmacro is (form) + "Assert that `form' evaluates to non-nil." + `(progn + (assert ,form) + (passed))) + +(defun %signals (expected fn) + (flet ((handler (condition) + (cond ((typep condition expected) + (passed) + (return-from %signals (values))) + (t (error "Expected to signal ~s, but got ~s:~%~a" + expected (type-of condition) condition))))) + (handler-bind ((condition #'handler)) + (funcall fn))) + (error "Expected to signal ~s, but got nothing." expected)) + +(defmacro signals (condition &body body) + "Assert that `body' signals a condition of type `condition'." + `(%signals ',condition (lambda () ,@body))) From d712e7eb12257c8f61f0a07af35670fb41635b3b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Aug 2016 19:59:11 +0200 Subject: [PATCH 35/92] tests: config.lsp: simplify file --- src/tests/Makefile.in | 2 +- src/tests/config.lsp.in | 41 ++++++----------------------------------- 2 files changed, 7 insertions(+), 36 deletions(-) diff --git a/src/tests/Makefile.in b/src/tests/Makefile.in index 7189030a7..0a61340da 100755 --- a/src/tests/Makefile.in +++ b/src/tests/Makefile.in @@ -9,7 +9,7 @@ all: check check: config.lsp $(ECL) -norc -load config.lsp \ - -eval '(ecl-tests::run-regressions-tests)' \ + -eval '(ecl-tests::run-tests)' \ -eval '(ext:quit)' \ 2>&1 | tee check.log diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in index 4ab1e8c8f..b638da87b 100755 --- a/src/tests/config.lsp.in +++ b/src/tests/config.lsp.in @@ -42,13 +42,7 @@ (ext:setenv "ECLDIR" (namestring (truename "SYS:"))) (defvar *test-name* (or (ext:getenv "TEST_NAME") "ecl")) -(defvar *regressions-sources* *test-sources*) -(defvar *regressions-sandbox* *here*) -(defvar *wild-inferiors* (make-pathname :name :wild - :type :wild - :version :wild - :directory '(:relative :wild-inferiors))) -(defvar *cleanup-extensions* '("fasl" "fasb" "c" "h" "obj" "o" "a" "lib" "dll" "dylib" "data")) +(defvar *sandbox* (merge-pathnames "temporary/" *here*)) (defun lisp-system-directory () (loop with root = (si::get-library-pathname) @@ -66,7 +60,6 @@ ;;; ;;; PREPARATION OF DIRECTORIES AND FILES ;;; - (defun delete-everything (path) ;; Recursively run through children (labels ((recursive-deletion (path) @@ -86,42 +79,20 @@ (and (probe-file path) (recursive-deletion path)))) -(defun copy-directory (orig dest) - (setf orig (truename orig)) - (print dest) - (loop for f in (directory (merge-pathnames *wild-inferiors* orig)) - for f2 = (enough-namestring f orig) - for f3 = (merge-pathnames f2 dest) - unless (and (probe-file f3) - (>= (file-write-date f3) - (file-write-date f2))) - do (ensure-directories-exist f3) - do (ext:copy-file f f3))) - -(defun ensure-regressions () - (unless (probe-file *regressions-sandbox*) - (copy-directory *regressions-sources* *regressions-sandbox*))) - -(defun cleanup-directory (path) - (loop for i in (directory (merge-pathnames *wild-inferiors* - path)) - when (member (pathname-type i) *cleanup-extensions* :test #'string-equal) - do (delete-file i))) - ;;; ;;; RUNNING TESTS ;;; -(defun run-regressions-tests () - (ensure-regressions) +(defun run-tests () ;; Cleanup stray files - (cleanup-directory *regressions-sandbox*) + (delete-everything *sandbox*) + (ensure-directories-exist *sandbox*) (unwind-protect (progn - (ext:chdir *regressions-sandbox*) + (ext:chdir *sandbox*) (ext:run-program *test-image* *test-image-args* - :input nil ; (merge-pathnames "doit.lsp" *regressions-sources*) + :input nil :output t :error :output)) (ext:chdir *here*))) From 59c078e5765af54c2058985512400034f78aa705 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 10 Aug 2016 13:44:40 +0200 Subject: [PATCH 36/92] tests: create make-check-suite This suite doesn't have regressions/mp, which often fail to not disturb the ordinary user. All regressions are in the ecl-tests suite. --- src/tests/doit.lsp | 2 +- src/tests/ecl-tests.lisp | 14 +++++++++++++- src/tests/regressions/mixed.lsp | 12 ++++++------ 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/src/tests/doit.lsp b/src/tests/doit.lsp index 1b5b2c9ef..603d18ddf 100644 --- a/src/tests/doit.lsp +++ b/src/tests/doit.lsp @@ -9,4 +9,4 @@ (asdf:load-asd (merge-pathnames "ecl-tests.asd" *load-pathname*))) (asdf:operate 'asdf:load-source-op 'ecl-tests) -(2am-ecl:run 'cl-test::ecl-tests) +(2am-ecl:run 'cl-test::make-check) diff --git a/src/tests/ecl-tests.lisp b/src/tests/ecl-tests.lisp index c747a111f..e7cd7b0a6 100644 --- a/src/tests/ecl-tests.lisp +++ b/src/tests/ecl-tests.lisp @@ -21,7 +21,19 @@ ;;;; Declare the suites (suite 'ecl-tests - '(regressions features)) + '(regressions + features)) + +(suite 'make-check + '(features/eformat + regressions/ansi+ + regressions/mixed + regressions/cmp + regressions/emb + regressions/ffi + regressions/mop + ;; disable regressions/mp due to fails + #+ (or) regressions/mp)) (suite 'regressions '(regressions/ansi+ diff --git a/src/tests/regressions/mixed.lsp b/src/tests/regressions/mixed.lsp index ef9ab804c..418d9fcf0 100644 --- a/src/tests/regressions/mixed.lsp +++ b/src/tests/regressions/mixed.lsp @@ -137,20 +137,20 @@ (is (= (random 18 #$1) (random 18 #$1) (random 18 #$1)) - "Same seed produces different results") + "The same seed produces different results") (is (let ((*print-readably* t) (rs (make-random-state #$1))) (equalp - (format nil "~S" #$1) - (format nil "~S" rs))) + (prin1-to-string #$1) + (prin1-to-string rs))) "The same seed gives different random states") (is (let* ((*print-readably* t) (rs (make-random-state #$1)) (rs-read (read-from-string - (format nil "~S" rs)))) + (prin1-to-string rs)))) (equalp - (format nil "~S" rs-read) - (format nil "~S" rs))) + (prin1-to-string rs-read) + (prin1-to-string rs))) "Can't read back a random state")) From 481270eca7946f23232eece2c48b8c3e98fdb72b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 10 Aug 2016 13:46:56 +0200 Subject: [PATCH 37/92] tests: update CHANGELOG --- CHANGELOG | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 63fd88a38..abc948bda 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -23,7 +23,7 @@ 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). @@ -38,15 +38,19 @@ Initializing a random state with an appropriate array (element type and arity) is now possible only with the #$ reader macro. ** Enhancements +- 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 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 From ab2e5a3593214541f359e075cf6479b55a7bb42d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 10 Aug 2016 13:52:10 +0200 Subject: [PATCH 38/92] random-state: make-random-state accepts arrays Type of the array is checked. The code has been moved from the `#$' reader-macro simplifying its implementation. --- src/c/num_rand.d | 14 ++++++++++++++ src/c/read.d | 21 +-------------------- 2 files changed, 15 insertions(+), 20 deletions(-) diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 44958b658..89c483bcd 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -300,6 +300,20 @@ ecl_make_random_state(cl_object rs) 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)); diff --git a/src/c/read.d b/src/c/read.d index c5f5388f1..ba92e522c 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1383,26 +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 - default: - rs = ecl_make_random_state(c); - break; - } + rs = ecl_make_random_state(c); @(return rs); } From e1d11cddbd2e0b377361e6dd72ae40198ee53484 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 10 Aug 2016 13:54:22 +0200 Subject: [PATCH 39/92] random-state: add ext:random-state-array function This function will return random-state array. This is meant for next commit which implements MAKE-LOAD-FORM for random-state objects. --- src/c/num_rand.d | 6 ++++++ src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/h/external.h | 2 +- 4 files changed, 11 insertions(+), 1 deletion(-) diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 89c483bcd..66205ef65 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -338,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; +} diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 04f0b26d4..de920ca80 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -2207,6 +2207,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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 8e125f1d3..8eeb8ef01 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -2207,6 +2207,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)"}, diff --git a/src/h/external.h b/src/h/external.h index c4dbbf568..64aea9cdd 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1237,7 +1237,7 @@ extern ECL_API cl_object cl_random_state_p(cl_object x); extern ECL_API cl_object cl_random _ECL_ARGS((cl_narg narg, cl_object x, ...)); extern ECL_API cl_object cl_make_random_state _ECL_ARGS((cl_narg narg, ...)); extern ECL_API cl_object ecl_make_random_state(cl_object rs); - +extern ECL_API cl_object si_random_state_array(cl_object rs); /* num_sfun.c */ From 7569359860183c70ea10166f05dee42035fda9cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 10 Aug 2016 13:55:06 +0200 Subject: [PATCH 40/92] make-load-form: add random-state implementation --- src/clos/print.lsp | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/clos/print.lsp b/src/clos/print.lsp index cae11e3e0..9b9b30f07 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -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))))) From fe0fc1d4c57e407db47d39e781fad04b297094b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 10 Aug 2016 14:14:13 +0200 Subject: [PATCH 41/92] changelog: add random-state improvements --- CHANGELOG | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index abc948bda..36df18317 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -30,12 +30,14 @@ * 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 FIXNUM (MEMBER T NIL))= +=(OR RANDOM-STATE FIXNUM (MEMBER T NIL))=. Initializing a random state with an appropriate array (element type and -arity) 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)=. ** Enhancements - Refactored ECL internal tests framework @@ -83,6 +85,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. From 020b3dcfeb4dc7276210c0691f6f5851cabe18a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 10 Aug 2016 14:20:13 +0200 Subject: [PATCH 42/92] new-doc: add some notes --- src/doc/new-doc/standards/index.txi | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/doc/new-doc/standards/index.txi b/src/doc/new-doc/standards/index.txi index 26d6cfe6b..e99c72967 100644 --- a/src/doc/new-doc/standards/index.txi +++ b/src/doc/new-doc/standards/index.txi @@ -42,43 +42,71 @@ @node Iteration @section Iteration + @node Objects @section Objects + @node Structures @section Structures + @node Conditions @section Conditions + @node Symbols @section Symbols + @node Packages @section Packages + @node Numbers @section Numbers +@c make-random-state fixnum|array +@c ext:random-state-array +@c #$ macro + @node Characters @section Characters + @node Conses @section Conses + @node Arrays @section Arrays + @node Strings @section Strings + @node Sequences @section Sequences + @node Hash tables @section Hash tables +@c weakness in hash tables +@c ext:hash-table-content +@c ext:hash-table-fill +@c ext:hash-table-weakness + @node Filenames @section Filenames + @node Files @section Files + @node Streams @section Streams + @node Printer @section Printer + @node Reader @section Reader +@c #$ - random state + @node System construction @section System construction + @node Environment @section Environment + @node Glossary @section Glossary From c951b72b2d4ae0544ab7553959077ba08f54481e Mon Sep 17 00:00:00 2001 From: Kacper Kasper Date: Sun, 3 Jul 2016 18:41:09 +0200 Subject: [PATCH 43/92] Haiku support. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Daniel Kochmański --- src/aclocal.m4 | 36 +++++++++++++++++++++++------------- src/configure.ac | 1 - 2 files changed, 23 insertions(+), 14 deletions(-) diff --git a/src/aclocal.m4 b/src/aclocal.m4 index 2b88971bb..a51a38aa0 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -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' diff --git a/src/configure.ac b/src/configure.ac index 3cd387e09..451ff2691 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -477,7 +477,6 @@ LDFLAGS="$LDFLAGS $LIBFFI_LDFLAGS" dnl ===================================================================== dnl Checks for libraries -LIBS="${LIBS} -lm" AC_CHECK_LIB(sun, getpwnam) # on IRIX adds -lsun AC_SEARCH_LIBS([strerror],[cposix]) From 873be229d0db6442249f3c82482a687bf12d6c2c Mon Sep 17 00:00:00 2001 From: Kacper Kasper Date: Sun, 3 Jul 2016 21:51:05 +0200 Subject: [PATCH 44/92] fix mkdir in configure MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Daniel Kochmański --- src/configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/configure.ac b/src/configure.ac index 451ff2691..deb6fc8f4 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -919,4 +919,4 @@ AC_CONFIG_FILES([ ]) AC_CONFIG_HEADERS([ecl/config.h:ecl/configpre.h]) AC_OUTPUT -for i in $srcdir/c/*/; do mkdir c/`basename $i`; done +for i in $srcdir/c/*/; do mkdir -p c/`basename $i`; done From ed5ecd03eb1a7e34754afab27c01c3e222590bfd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 11 Aug 2016 22:38:30 +0200 Subject: [PATCH 45/92] ieee-floats: fix builds with --with-ieee-fp=no Functions to print (nan,float)-to-string and and predicates are still available, but ext:*-float-*-infinity aren't available if ECL is built with option `--with-ieee-fp=no`. --- src/c/reader/parse_number.d | 6 +++-- src/c/symbols_list.h | 9 +++++--- src/c/symbols_list2.h | 9 +++++--- src/clos/print.lsp | 35 +++++++++++++++++++++-------- src/cmp/cmpct.lsp | 18 ++++++++------- src/doc/new-doc/standards/index.txi | 7 ++++++ src/lsp/numlib.lsp | 2 +- 7 files changed, 60 insertions(+), 26 deletions(-) diff --git a/src/c/reader/parse_number.d b/src/c/reader/parse_number.d index 5eee3e7a3..982eec7ae 100644 --- a/src/c/reader/parse_number.d +++ b/src/c/reader/parse_number.d @@ -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; } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index de920ca80..317b08677 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1900,22 +1900,25 @@ cl_symbols[] = { {EXT_ "*BYTECODES-COMPILER*", EXT_SPECIAL, NULL, -1, ECL_NIL}, +#ifdef ECL_IEEE_FP {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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 8eeb8ef01..310a3dced 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1900,22 +1900,25 @@ cl_symbols[] = { {EXT_ "*BYTECODES-COMPILER*",NULL}, +#ifdef ECL_IEEE_FP {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}, diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 9b9b30f07..017362717 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -217,24 +217,41 @@ printer and we should rather use MAKE-LOAD-FORM." (short-float . "#"))))) (defun ext::float-infinity-string (x) - (when (and *print-readably* (null *read-eval*)) + (when (and *print-readably* + #+ieee-floating-point (null *read-eval*)) (error 'print-not-readable :object x)) (let* ((negative-infinities '((single-float . - "#.ext::single-float-negative-infinity") + #.(if (member :ieee-floating-point *features*) + "#.ext::single-float-negative-infinity" + "#")) (double-float . - "#.ext::double-float-negative-infinity") + #.(if (member :ieee-floating-point *features*) + "#.ext::double-float-negative-infinity" + "#")) (long-float . - "#.ext::long-float-negative-infinity") + #.(if (member :ieee-floating-point *features*) + "#.ext::long-float-negative-infinity" + "")) (short-float . - "#.ext::short-float-negative-infinity"))) + #.(if (member :ieee-floating-point *features*) + "#.ext::short-float-negative-infinity" + "")))) (positive-infinities '((single-float . - "#.ext::single-float-positive-infinity") + #.(if (member :ieee-floating-point *features*) + "#.ext::single-float-positive-infinity" + "#")) (double-float . - "#.ext::double-float-positive-infinity") + #.(if (member :ieee-floating-point *features*) + "#.ext::double-float-positive-infinity" + "#")) (long-float . - "#.ext::long-float-positive-infinity") + #.(if (member :ieee-floating-point *features*) + "#.ext::long-float-positive-infinity" + "")) (short-float . - "#.ext::short-float-positive-infinity"))) + #.(if (member :ieee-floating-point *features*) + "#.ext::short-float-positive-infinity" + "")))) (record (assoc (type-of x) (if (plusp x) positive-infinities negative-infinities)))) (unless record diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp index b98a9ea53..f70f323c6 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpct.lsp @@ -152,22 +152,24 @@ (LEAST-NEGATIVE-DOUBLE-FLOAT "-DBL_MIN") (LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT "-DBL_MIN") - (SHORT-FLOAT-POSITIVE-INFINITY "INFINITY") - (SINGLE-FLOAT-POSITIVE-INFINITY "INFINITY") - (DOUBLE-FLOAT-POSITIVE-INFINITY "INFINITY") + #+ieee-floating-point + ,@'((SHORT-FLOAT-POSITIVE-INFINITY "INFINITY") + (SINGLE-FLOAT-POSITIVE-INFINITY "INFINITY") + (DOUBLE-FLOAT-POSITIVE-INFINITY "INFINITY") - (SHORT-FLOAT-NEGATIVE-INFINITY "-INFINITY") - (SINGLE-FLOAT-NEGATIVE-INFINITY "-INFINITY") - (DOUBLE-FLOAT-NEGATIVE-INFINITY "-INFINITY") + (SHORT-FLOAT-NEGATIVE-INFINITY "-INFINITY") + (SINGLE-FLOAT-NEGATIVE-INFINITY "-INFINITY") + (DOUBLE-FLOAT-NEGATIVE-INFINITY "-INFINITY")) #+long-float - ,@'( - (MOST-POSITIVE-LONG-FLOAT "LDBL_MAX") + ,@'((MOST-POSITIVE-LONG-FLOAT "LDBL_MAX") (MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX") (LEAST-POSITIVE-LONG-FLOAT "LDBL_MIN") (LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN") (LEAST-NEGATIVE-LONG-FLOAT "-LDBL_MIN") (LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN") + #+ieee-floating-point (LONG-FLOAT-POSITIVE-INFINITY "INFINITY") + #+ieee-floating-point (LONG-FLOAT-NEGATIVE-INFINITY "-INFINITY") ))))) diff --git a/src/doc/new-doc/standards/index.txi b/src/doc/new-doc/standards/index.txi index e99c72967..9de944c14 100644 --- a/src/doc/new-doc/standards/index.txi +++ b/src/doc/new-doc/standards/index.txi @@ -60,6 +60,13 @@ @node Numbers @section Numbers + +@c ext:{short,single,double,long}-float-{positive,negative}-infinity +@c ext:float-nan-p +@c ext:float-infinity-p +@c ext:float-nan-string +@c ext:float-infinity-string + @c make-random-state fixnum|array @c ext:random-state-array @c #$ macro diff --git a/src/lsp/numlib.lsp b/src/lsp/numlib.lsp index 1bbfb49ac..8cb4e86ad 100644 --- a/src/lsp/numlib.lsp +++ b/src/lsp/numlib.lsp @@ -73,7 +73,7 @@ (not (= (float 1 E) (- (float 1 E) E)))") )) -#+IEEE-FLOATING-POINT +#+ieee-floating-point (locally (declare (notinline -)) (let* ((bits (si::trap-fpe 'last nil))) From 0051ff7a3ef61f32a4bba393676e83bd88f1fd0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 11 Aug 2016 22:42:15 +0200 Subject: [PATCH 46/92] changelog: update --- CHANGELOG | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGELOG b/CHANGELOG index 36df18317..14f309400 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -40,6 +40,9 @@ arity dependent on platform) is also possible. =(ext:random-state-array random-state)=. ** Enhancements +- Initial port for the Haiku platform +The port is done by Kacper Kasper's work, one of Haiku developers. + - 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 @@ -63,6 +66,8 @@ 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). From 6f2795e4e53075daa935fd4eaf44b9fb8d393d9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 11 Aug 2016 22:53:12 +0200 Subject: [PATCH 47/92] cosmetic: new-doc: add comment --- src/doc/new-doc/standards/index.txi | 1 + 1 file changed, 1 insertion(+) diff --git a/src/doc/new-doc/standards/index.txi b/src/doc/new-doc/standards/index.txi index 9de944c14..6860d3c1c 100644 --- a/src/doc/new-doc/standards/index.txi +++ b/src/doc/new-doc/standards/index.txi @@ -60,6 +60,7 @@ @node Numbers @section Numbers +@c build option --with-ieee-fp={yes|no} @c ext:{short,single,double,long}-float-{positive,negative}-infinity @c ext:float-nan-p From c57fcd366cf271afc9337137f93ac704cbc9407f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 11 Aug 2016 23:44:38 +0200 Subject: [PATCH 48/92] ieee-floats: improve api, fix ieee-float builds This initializes CL infinite floats with a precomputed and casted infinity from the appropriate C macro. This removes runtime 0/0 operations. --- src/c/number.d | 20 ++++++++++++++++++++ src/c/symbols_list.h | 3 +++ src/c/symbols_list2.h | 3 +++ src/doc/new-doc/standards/index.txi | 4 +++- src/h/external.h | 4 ++++ src/lsp/numlib.lsp | 25 +++++++++---------------- 6 files changed, 42 insertions(+), 17 deletions(-) diff --git a/src/c/number.d b/src/c/number.d index 51659c54e..06d1dee4e 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -916,3 +916,23 @@ _ecl_float_to_integer(float d) return _ecl_big_register_copy(z); } } + +#ifdef ECL_IEEE_FP +cl_object +si_nan() { +#ifdef ECL_LONG_FLOAT + ecl_make_long_float(NAN); +#else + ecl_make_double_float(NAN); +#endif +} + +cl_object +si_infinity() { +#ifdef ECL_LONG_FLOAT + ecl_make_long_float(INFINITY); +#else + ecl_make_double_float(INFINITY); +#endif +} +#endif /* ECL_IEEE_FP */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 317b08677..81e099a16 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1901,6 +1901,9 @@ 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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 310a3dced..8c90e3b1c 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1901,6 +1901,9 @@ 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}, diff --git a/src/doc/new-doc/standards/index.txi b/src/doc/new-doc/standards/index.txi index 6860d3c1c..e33e6b6a0 100644 --- a/src/doc/new-doc/standards/index.txi +++ b/src/doc/new-doc/standards/index.txi @@ -61,7 +61,9 @@ @node Numbers @section Numbers @c build option --with-ieee-fp={yes|no} - +@c si::trap-fpe +@c si::nan +@c si::infinity @c ext:{short,single,double,long}-float-{positive,negative}-infinity @c ext:float-nan-p @c ext:float-infinity-p diff --git a/src/h/external.h b/src/h/external.h index 64aea9cdd..285b06d36 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1117,6 +1117,10 @@ extern ECL_API double ecl_to_double(cl_object x); extern ECL_API long double ecl_to_long_double(cl_object x); extern ECL_API cl_object ecl_make_long_float(long double f); #endif +#ifdef ECL_IEEE_FP +extern cl_object si_nan(); +extern cl_object si_infinity(); +#endif /* ECL_IEEE_FP */ /* num_co.c */ diff --git a/src/lsp/numlib.lsp b/src/lsp/numlib.lsp index 8cb4e86ad..b96e20cf4 100644 --- a/src/lsp/numlib.lsp +++ b/src/lsp/numlib.lsp @@ -74,22 +74,15 @@ )) #+ieee-floating-point -(locally - (declare (notinline -)) - (let* ((bits (si::trap-fpe 'last nil))) - (let ((a (/ (coerce 1 'short-float) (coerce 0.0 'short-float)))) - (defconstant short-float-positive-infinity a) - (defconstant short-float-negative-infinity (- a))) - (let ((a (/ (coerce 1 'single-float) (coerce 0.0 'single-float)))) - (defconstant single-float-positive-infinity a) - (defconstant single-float-negative-infinity (- a))) - (let ((a (/ (coerce 1 'double-float) (coerce 0.0 'double-float)))) - (defconstant double-float-positive-infinity a) - (defconstant double-float-negative-infinity (- a))) - (let ((a (/ (coerce 1 'long-float) (coerce 0.0 'long-float)))) - (defconstant long-float-positive-infinity a) - (defconstant long-float-negative-infinity (- a))) - (si::trap-fpe bits t))) +(let ((inf (si::infinity))) + (defconstant short-float-positive-infinity (coerce inf 'short-float)) + (defconstant short-float-negative-infinity (coerce (- inf) 'short-float)) + (defconstant single-float-positive-infinity (coerce inf 'single-float)) + (defconstant single-float-negative-infinity (coerce (- inf) 'single-float)) + (defconstant double-float-positive-infinity (coerce inf 'double-float)) + (defconstant double-float-negative-infinity (coerce (- inf) 'double-float)) + (defconstant long-float-positive-infinity (coerce inf 'long-float)) + (defconstant long-float-negative-infinity (coerce (- inf) 'long-float))) (defconstant imag-one #C(0.0 1.0)) From 0ef98adbaa1613c3b0bbafe9e9b5cc5cea3a6d32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 11 Aug 2016 23:55:28 +0200 Subject: [PATCH 49/92] haiku port: autoreconf --- src/configure | 41 +++++++++++++++++++++++++---------------- 1 file changed, 25 insertions(+), 16 deletions(-) diff --git a/src/configure b/src/configure index 4a27fb370..167d6c25f 100755 --- a/src/configure +++ b/src/configure @@ -4858,7 +4858,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 @@ -4869,7 +4869,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" @@ -4887,7 +4887,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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" @@ -4900,7 +4900,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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" @@ -4912,7 +4912,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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" @@ -4923,7 +4923,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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" ;; @@ -4933,7 +4933,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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" ;; @@ -4943,7 +4943,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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" ;; @@ -4954,7 +4954,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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" ;; @@ -4965,9 +4965,9 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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" @@ -5051,7 +5051,17 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" 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' @@ -5692,7 +5702,6 @@ CPPFLAGS="$CPPFLAGS $LIBFFI_CPPFLAGS" LDFLAGS="$LDFLAGS $LIBFFI_LDFLAGS" -LIBS="${LIBS} -lm" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwnam in -lsun" >&5 $as_echo_n "checking for getpwnam in -lsun... " >&6; } if ${ac_cv_lib_sun_getpwnam+:} false; then : @@ -10272,7 +10281,7 @@ ecl config.status 16.1.2 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" -Copyright (C) Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -10994,4 +11003,4 @@ if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi -for i in $srcdir/c/*/; do mkdir c/`basename $i`; done +for i in $srcdir/c/*/; do mkdir -p c/`basename $i`; done From bc567e0c3fbc2ee816746c6179c1646d18c3abaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 12 Aug 2016 08:28:43 +0200 Subject: [PATCH 50/92] ieee-floats: fix printing Do redundant type test in case we're calling it from somewhere else. --- src/clos/print.lsp | 66 ++++++++++++++++++---------------------------- 1 file changed, 26 insertions(+), 40 deletions(-) diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 017362717..c1441c9e9 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -217,46 +217,32 @@ printer and we should rather use MAKE-LOAD-FORM." (short-float . "#"))))) (defun ext::float-infinity-string (x) - (when (and *print-readably* - #+ieee-floating-point (null *read-eval*)) - (error 'print-not-readable :object x)) - (let* ((negative-infinities '((single-float . - #.(if (member :ieee-floating-point *features*) - "#.ext::single-float-negative-infinity" - "#")) - (double-float . - #.(if (member :ieee-floating-point *features*) - "#.ext::double-float-negative-infinity" - "#")) - (long-float . - #.(if (member :ieee-floating-point *features*) - "#.ext::long-float-negative-infinity" - "")) - (short-float . - #.(if (member :ieee-floating-point *features*) - "#.ext::short-float-negative-infinity" - "")))) - (positive-infinities '((single-float . - #.(if (member :ieee-floating-point *features*) - "#.ext::single-float-positive-infinity" - "#")) - (double-float . - #.(if (member :ieee-floating-point *features*) - "#.ext::double-float-positive-infinity" - "#")) - (long-float . - #.(if (member :ieee-floating-point *features*) - "#.ext::long-float-positive-infinity" - "")) - (short-float . - #.(if (member :ieee-floating-point *features*) - "#.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 "#") + (ext:positive-single-float "#") + (ext:negative-double-float "#") + (ext:positive-double-float "#") + (ext:negative-long-float "#") + (ext:positive-long-float "#") + (ext:negative-short-float "#") + (ext:positive-short-float "#"))) + #+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 From 9874b6e53afcdf3660cc3f96c6e7d8ad75bd0cf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 12 Aug 2016 08:48:36 +0200 Subject: [PATCH 51/92] ieee-floats: fix printing of NaN's Add readable print if the feature :ieee-floating-point is present. --- src/clos/print.lsp | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/src/clos/print.lsp b/src/clos/print.lsp index c1441c9e9..939556965 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -208,13 +208,24 @@ printer and we should rather use MAKE-LOAD-FORM." m) (defun ext::float-nan-string (x) - (when *print-readably* - (error 'print-not-readable :object x)) - (cdr (assoc (type-of x) - '((single-float . "#") - (double-float . "#") - (long-float . "#") - (short-float . "#"))))) + (unless (ext:float-nan-p x) + (signal 'type-error :datum x :expected-type 'float-nan)) + + (cond + ((null *print-readably*) + (etypecase x + (single-float "#") + (double-float "#") + (long-float "#") + (short-float "#"))) + #+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) (unless (ext:float-infinity-p x) From 0fbf2a4c44901fa818493a689fc4b601e096ef68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 12 Aug 2016 09:32:07 +0200 Subject: [PATCH 52/92] tests: add some basic tests for ieee-fp --- src/tests/ecl-tests.asd | 3 ++- src/tests/ecl-tests.lisp | 4 ++- src/tests/features/ieee-fp.lsp | 48 ++++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 2 deletions(-) create mode 100644 src/tests/features/ieee-fp.lsp diff --git a/src/tests/ecl-tests.asd b/src/tests/ecl-tests.asd index b692cf34a..1738fd1cd 100644 --- a/src/tests/ecl-tests.asd +++ b/src/tests/ecl-tests.asd @@ -21,7 +21,8 @@ (:module features :default-component-class asdf:cl-source-file.lsp :components - ((:file "external-formats" :if-feature :unicode))))) + ((:file "external-formats" :if-feature :unicode) + (:file "ieee-fp" :if-feature :ieee-floating-point))))) (asdf:defsystem #:ecl-tests/stress :serial t diff --git a/src/tests/ecl-tests.lisp b/src/tests/ecl-tests.lisp index e7cd7b0a6..b5761d63b 100644 --- a/src/tests/ecl-tests.lisp +++ b/src/tests/ecl-tests.lisp @@ -26,6 +26,7 @@ (suite 'make-check '(features/eformat + features/ieee-fp regressions/ansi+ regressions/mixed regressions/cmp @@ -45,7 +46,8 @@ regressions/mp)) (suite 'features - '(features/eformat)) + '(features/eformat + features/ieee-fp)) ;;; Some syntactic sugar for 2am diff --git a/src/tests/features/ieee-fp.lsp b/src/tests/features/ieee-fp.lsp new file mode 100644 index 000000000..e91b245f8 --- /dev/null +++ b/src/tests/features/ieee-fp.lsp @@ -0,0 +1,48 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Author: Daniel Kochmański +;;;; Created: 2016-08-12 +;;;; Contains: IEEE floating point tests +;;;; + +(in-package :cl-test) + +(suite 'features/ieee-fp) + +(test ieee-fp.0001.infinity-eql + (let ((sfni ext:single-float-negative-infinity) + (sfpi ext:single-float-positive-infinity) + (dfni ext:double-float-negative-infinity) + (dfpi ext:double-float-positive-infinity)) + (is (eql sfni (- sfpi))) + (is (eql dfni (- dfpi))) + (is (not (eql sfni (- dfpi)))) + (is (= sfni (- dfpi))))) + +(test ieee-fp.0002.printing + (let ((nums (list ext:single-float-negative-infinity + ext:single-float-positive-infinity + ext:double-float-negative-infinity + ext:double-float-positive-infinity + (si:nan) + (si:infinity))) + (*standard-output* (make-string-output-stream))) + (dolist (i nums) + (finishes + (let ((*print-readably* t) + (*read-eval* t)) + (print nums))) + (finishes + (let ((*print-readably* nil) + (*read-eval* nil)) + (print nums))) + (signals print-not-readable + (let ((*print-readably* t) + (*read-eval* nil)) + (print nums)))))) + +(test ieee-fp.0003.predicates + (is (ext:float-infinity-p ext:single-float-negative-infinity)) + (is (ext:float-infinity-p ext:single-float-positive-infinity)) + (is (ext:float-nan-p (si:nan)))) From 4e45a82e2bd9c953885b6c8bfba54025274f952c Mon Sep 17 00:00:00 2001 From: lexicall Date: Sat, 13 Aug 2016 05:59:32 +0000 Subject: [PATCH 53/92] examples: add example ecl_qt (embedding ECL in QT5) --- examples/ecl_qt/.gitkeep | 0 examples/ecl_qt/Makefile | 13 ++ examples/ecl_qt/README.md | 32 ++++ examples/ecl_qt/build_fasl.lisp | 8 + examples/ecl_qt/build_static.lisp | 8 + examples/ecl_qt/hello-lisp-system.asd | 4 + examples/ecl_qt/hello-lisp.lisp | 33 ++++ examples/ecl_qt/lisp-envi.asd | 3 + examples/ecl_qt/lisp-envi.lisp | 3 + examples/ecl_qt/qt/.gitkeep | 0 examples/ecl_qt/qt/cl_bridge_utils.cpp | 11 ++ examples/ecl_qt/qt/cl_bridge_utils.hpp | 103 ++++++++++ examples/ecl_qt/qt/ecl_qtdemo.pro | 35 ++++ examples/ecl_qt/qt/hybrid_main.cpp | 76 ++++++++ examples/ecl_qt/qt/hybrid_main.h | 32 ++++ examples/ecl_qt/qt/hybrid_main.ui | 248 +++++++++++++++++++++++++ examples/ecl_qt/qt/madeinlisp.png | Bin 0 -> 441185 bytes examples/ecl_qt/qt/main.cpp | 43 +++++ examples/ecl_qt/qt/resource.qrc | 5 + 19 files changed, 657 insertions(+) create mode 100644 examples/ecl_qt/.gitkeep create mode 100644 examples/ecl_qt/Makefile create mode 100644 examples/ecl_qt/README.md create mode 100644 examples/ecl_qt/build_fasl.lisp create mode 100644 examples/ecl_qt/build_static.lisp create mode 100644 examples/ecl_qt/hello-lisp-system.asd create mode 100644 examples/ecl_qt/hello-lisp.lisp create mode 100644 examples/ecl_qt/lisp-envi.asd create mode 100644 examples/ecl_qt/lisp-envi.lisp create mode 100644 examples/ecl_qt/qt/.gitkeep create mode 100644 examples/ecl_qt/qt/cl_bridge_utils.cpp create mode 100644 examples/ecl_qt/qt/cl_bridge_utils.hpp create mode 100644 examples/ecl_qt/qt/ecl_qtdemo.pro create mode 100644 examples/ecl_qt/qt/hybrid_main.cpp create mode 100644 examples/ecl_qt/qt/hybrid_main.h create mode 100644 examples/ecl_qt/qt/hybrid_main.ui create mode 100644 examples/ecl_qt/qt/madeinlisp.png create mode 100644 examples/ecl_qt/qt/main.cpp create mode 100644 examples/ecl_qt/qt/resource.qrc diff --git a/examples/ecl_qt/.gitkeep b/examples/ecl_qt/.gitkeep new file mode 100644 index 000000000..e69de29bb diff --git a/examples/ecl_qt/Makefile b/examples/ecl_qt/Makefile new file mode 100644 index 000000000..fca1ceeb4 --- /dev/null +++ b/examples/ecl_qt/Makefile @@ -0,0 +1,13 @@ +all:lisp-envi.a hello-lisp-system--all-systems.fasb + +#lisp environment. +lisp-envi.a: lisp-envi.asd lisp-envi.lisp build_static.lisp + ecl -load build_static.lisp + +#your lisp system. +hello-lisp-system--all-systems.fasb: hello-lisp-system.asd hello-lisp.lisp \ +build_fasl.lisp + ecl -load build_fasl.lisp + +clean: + -rm -f hello-lisp-system--all-systems.fasb lisp-envi.a diff --git a/examples/ecl_qt/README.md b/examples/ecl_qt/README.md new file mode 100644 index 000000000..d37c3622d --- /dev/null +++ b/examples/ecl_qt/README.md @@ -0,0 +1,32 @@ +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, if successful. `lisp-envi.a` and `hello-lisp-system--all-systems.fasb`. +## Configure your Qt Project +cd to the directory `qt` and open that Qt project with your Qt Creator. Change the three paths I marked for you, if necessary. +1. `INCLUDEPATH`: The path that contains ecl/ecl.h. +In Linux it may be `/usr/include/`. +2. `LIBS`:The path that leads to the shared library of ECL. +In Linux, it may be `/usr/lib/libecl.so/`. +## Build Qt Project +Build your Qt Project. This will generate an executable file for you. +## Engage `fasb` file +After your Qt project is built, move the `hello-lisp-system--all-systems.fasb` file that generated in build step 1 into the directory containing the executable file. + +# Run +After you go through the steps above, go for the executable file and try that demo. + +Happy hacking with ECL! + +ntr(Lexicall) diff --git a/examples/ecl_qt/build_fasl.lisp b/examples/ecl_qt/build_fasl.lisp new file mode 100644 index 000000000..1a0ac253a --- /dev/null +++ b/examples/ecl_qt/build_fasl.lisp @@ -0,0 +1,8 @@ +;;(require 'asdf) +(push "./" asdf:*central-registry*) + +(asdf:make-build :hello-lisp-system + :type :fasl + :monolithic t + :move-here "./") +(quit) diff --git a/examples/ecl_qt/build_static.lisp b/examples/ecl_qt/build_static.lisp new file mode 100644 index 000000000..375b233ce --- /dev/null +++ b/examples/ecl_qt/build_static.lisp @@ -0,0 +1,8 @@ +;;(require 'asdf) +(push "./" asdf:*central-registry*) + +(asdf:make-build :lisp-envi + :type :static-library + :move-here "./") +(quit) + diff --git a/examples/ecl_qt/hello-lisp-system.asd b/examples/ecl_qt/hello-lisp-system.asd new file mode 100644 index 000000000..f190c1fce --- /dev/null +++ b/examples/ecl_qt/hello-lisp-system.asd @@ -0,0 +1,4 @@ +(defsystem :hello-lisp-system + :depends-on (:lparallel) + :components ((:file "hello-lisp"))) + diff --git a/examples/ecl_qt/hello-lisp.lisp b/examples/ecl_qt/hello-lisp.lisp new file mode 100644 index 000000000..012124425 --- /dev/null +++ b/examples/ecl_qt/hello-lisp.lisp @@ -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!") diff --git a/examples/ecl_qt/lisp-envi.asd b/examples/ecl_qt/lisp-envi.asd new file mode 100644 index 000000000..2e92abb0e --- /dev/null +++ b/examples/ecl_qt/lisp-envi.asd @@ -0,0 +1,3 @@ +(defsystem :lisp-envi + :depends-on () + :components ((:file "lisp-envi"))) diff --git a/examples/ecl_qt/lisp-envi.lisp b/examples/ecl_qt/lisp-envi.lisp new file mode 100644 index 000000000..ba10d40f0 --- /dev/null +++ b/examples/ecl_qt/lisp-envi.lisp @@ -0,0 +1,3 @@ +(princ "Lisp Environment Booted.") + + diff --git a/examples/ecl_qt/qt/.gitkeep b/examples/ecl_qt/qt/.gitkeep new file mode 100644 index 000000000..e69de29bb diff --git a/examples/ecl_qt/qt/cl_bridge_utils.cpp b/examples/ecl_qt/qt/cl_bridge_utils.cpp new file mode 100644 index 000000000..49eca85fd --- /dev/null +++ b/examples/ecl_qt/qt/cl_bridge_utils.cpp @@ -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; +} + diff --git a/examples/ecl_qt/qt/cl_bridge_utils.hpp b/examples/ecl_qt/qt/cl_bridge_utils.hpp new file mode 100644 index 000000000..eabca2fa5 --- /dev/null +++ b/examples/ecl_qt/qt/cl_bridge_utils.hpp @@ -0,0 +1,103 @@ +#ifndef CL_BRIDGE_UTILS_HPP +#define CL_BRIDGE_UTILS_HPP +#include +#include +#ifdef slots +#undef slots +#endif +#include + +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 +string __spc_expr (string first, str ... next){ + return first+" "+__spc_expr(next...); +} + +/* encapsule expressions in parenthesis. */ +/* to create lisp expr. */ +template +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 +lisp_expr par_list(str... all){ + return "'"+par_expr(all...); +} + +/* an enhanced version of cl_eval */ +template +cl_object cl_eval(str... all){ + std::cout<__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 + 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 diff --git a/examples/ecl_qt/qt/ecl_qtdemo.pro b/examples/ecl_qt/qt/ecl_qtdemo.pro new file mode 100644 index 000000000..8e1692d9f --- /dev/null +++ b/examples/ecl_qt/qt/ecl_qtdemo.pro @@ -0,0 +1,35 @@ +#------------------------------------------------- +# +# 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 +INCLUDEPATH += /usr/local/include +#The ECL shared library directory. +LIBS += /usr/local/lib/libecl.dylib + +LIBS += $$_PRO_FILE_PWD_/../lisp-envi.a + + +RESOURCES += \ + resource.qrc + diff --git a/examples/ecl_qt/qt/hybrid_main.cpp b/examples/ecl_qt/qt/hybrid_main.cpp new file mode 100644 index 000000000..71c1b99c4 --- /dev/null +++ b/examples/ecl_qt/qt/hybrid_main.cpp @@ -0,0 +1,76 @@ +#include "hybrid_main.h" +#include "ui_hybrid_main.h" +#include +#include +#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<>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<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); +} diff --git a/examples/ecl_qt/qt/hybrid_main.h b/examples/ecl_qt/qt/hybrid_main.h new file mode 100644 index 000000000..dcbdae4df --- /dev/null +++ b/examples/ecl_qt/qt/hybrid_main.h @@ -0,0 +1,32 @@ +#ifndef HYBRID_MAIN_H +#define HYBRID_MAIN_H + +#include + +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 diff --git a/examples/ecl_qt/qt/hybrid_main.ui b/examples/ecl_qt/qt/hybrid_main.ui new file mode 100644 index 000000000..941dd4d7a --- /dev/null +++ b/examples/ecl_qt/qt/hybrid_main.ui @@ -0,0 +1,248 @@ + + + hybrid_main + + + + 0 + 0 + 641 + 430 + + + + hybrid_main + + + + + + 112 + 60 + 121 + 21 + + + + + + + + + + Input N here. + + + + + + 240 + 55 + 113 + 32 + + + + calculate! + + + + + + 30 + 60 + 71 + 16 + + + + Fibonacci: + + + + + + 160 + 100 + 241 + 16 + + + + Quick Sort List Processing Test + + + + + + 30 + 130 + 59 + 16 + + + + Input + + + + + + 30 + 170 + 59 + 16 + + + + Output + + + + + + 20 + 200 + 113 + 32 + + + + sort! + + + + + + 110 + 130 + 491 + 21 + + + + Input a sequence of number, seperate by space. + + + + + + 110 + 170 + 491 + 21 + + + + true + + + Sorted sequence output + + + + + + 30 + 80 + 601 + 16 + + + + Qt::Horizontal + + + + + + 270 + 240 + 61 + 91 + + + + border-image:url(:/pic/madeinlisp.png) + + + + + + + + + 370 + 300 + 191 + 41 + + + + (Core made in Lisp.) + + + + + + 160 + 10 + 301 + 16 + + + + Concurrent Compution Test (lparallel) + + + + + + 350 + 270 + 181 + 32 + + + + Hello, Lisp! + + + + + + 360 + 60 + 113 + 21 + + + + + + + true + + + Answer output + + + + + + 400 + 240 + 111 + 16 + + + + String Test + + + + + + + + diff --git a/examples/ecl_qt/qt/madeinlisp.png b/examples/ecl_qt/qt/madeinlisp.png new file mode 100644 index 0000000000000000000000000000000000000000..520c4fbbaca85ca78d8195cd0b065fa9145cbca8 GIT binary patch literal 441185 zcmeAS@N?(olHy`uVBq!ia0y~yU}|DuV1C5G#=yYvx_HlT1_lPk;vjb?hIQv;UNSH+ za29w(7Beu2se&-0XOPMV1_s8tnIRD+5xzcF$@#f@i7EL>sd^Q;1q>iyQ(;w+TacSt zlBiITo0C^;Rbi_HR$-M_Yy}e5S5g2gDap1~itr6kaLzAERWQ{v(KAr8<5EyiuqjGO zvkG!?gK95INwZbTC@Cqh($_C9FV`zK*2^zS*Eh7ZwA42+(l;{FElNq#Ew0QfNvzP# zD^`XW0yD=YwK%ybv!En1KTiQej`FVC`CPp@3^%yb;8*LCeBM~|+ElrShBFR8? z+USEkfaD=aXn{q8T-@xqZ1ln53JPO8uA3{u(is>SWHMd+Ll_tsm_Sj(z`*#Cfq_8- zLNk73U~UfH%dDggtL50_W4R;phh21UxerB?||GYoXPEM|r{{Ped|MQd5`Fkdwn{Pk=8Rz4V z74we2PS57MBD2CWpm@PEhqH~dm`&N&DYL6hK6z)OsZ{TlJ$vTl?RvSaTOfEkfegBl{$a z?@k3@&XJVOH_lXVp3P?WzT9eV$!Xo~ORV4RP`+D!zxJlmkN5xX?)U!1IZfOwirL&P z=UUqOyFb=k(?koCEWR^E31S?1M^afYpM6*B)}64C?cMF|`pgIGf9n5Ft$I2&Jniwi zevGjE*J4p%YEWVNX)DJo`HBYz8hKd$U)}#JoRNh)Yff!u@{-NpUp)o|I>N^eXB+>U z$=uL!)1KzM^2^*L!8`lw>)D$A|BC-}n3%=c}$+4Ar9hJ}7xVUY&W|Ka)Z z#@-)m=A3_IvC}B~MYh>&MwasT_vXq~y;$ha-c(4@3EbkECBXZ+0k1W|=>w!>>d7etBD$!e%~Gc1SpaQXV)r zggLg~gdqsj$)eSe0|N#g z-L4}pr=D$fdXqCp`u_U!XfCNgCnMl2suNZ)_0Nu3hQ2kS2D4|ZZn2jVn4@~(i0=)a zFI9U(-gz!)*~Qy_SYd}i)O$4jrtC)STye8lOXG~sNL}apAo0u096XSC?ue>XSd)M5vF^W6xT}RF5S$ru6!hdWKWDzsiv2UN; zv8|ia&#Rd`J~(yil!#8(X`an9PVYFi^Y?2blNg2tCxQib>F)RYtabJE z)ek1jtO@$2TKsh%YAgm6Kk(w~n9ju@k}mood`-i=_+2HM2kxJotbY0T`~C6?A08d; z4t{)Fo|nUGMT39#f)ke{HOlW*rdR#>cszNbQ{zI(Nfl?Ow{Fnh95eqax|>fh7EZ2M znV{A<-@@y=)%%@u?P{$KJc!QUJ2kHE=Ti&&(pMpOKL7l*?)}u{$KUp}yiOCm!nES) z`#$S;9NrIXzu%d>@7vb(tQvRr)m96HHY9lN!3>s|lZ=jY9G#;-e%5x_(BRPCX#eNK z;gWxUelj$kxBVWYHO+DUO%4|GW5Gdxni~@ogEpuOl$5^OTm5}m?eA|(-`701&b+=Z zHuL$pxs3^`S=SbB6bQtONWEf*Gb$C@4Ckz+uCO#jvEJSP{a*FUJ3EVC-b|nGd*0@= z4-bF!+27ZhnvOl(E3}SVpv1^yBS#kJp8x-TUv}oVol^IqS)Ro}gkxIE-Q8CgV#L5> z8G#i$MU!XmIGJqDo5i&E>eZ_ZP3h<6c-sHIdH&M*`hTBG9v$f{`SRkTrhtw@5ck73 z8$U|;Jl@6RsNQAa=pwMA{{O!(SAzXn1@3H2J}&woU#zpv=J(gBsD;&m`TFcfJe$n_ z{$eS3TA?gpQ}?Ih2kXBt%k6m$R+xUcu+TYJA>vx`zr{?Bx=l?7nA!Q3$p8D$ZfNpm zL*YiIb5`2_eu@>&{fuVlR?7uf{U503ecI9B)ZW5c7RACXQ1k2M^2`2ppC)e**!TC_ z?ZS8iOKukKe_GdEgZJf$ISOBTwcNGf{5;!}@2}eada?NB@B9Dj7#!1ivrm~gx30)e z-@7jut>F9o%z-hlXyKY2i%K^zI9}&2(YP`5u>HS}{gcBSb(`4v<>pA;=X$2)aA^li zlWJc7`qLK*7@PEz*185{FK`Hucbq;^kV7mbTWy*1;fJduEOmCBcD^R_BwP60=ZWUa z%q`C)KAzh9{OL~VZRgoSucc!R(jGD3UePCr?+5G)w5%+d{{5|Pgj#v0@Gu5(Z2Pge5dfD|^ z+wYX{f8KAZ#wTvMG(OrNGijE;(&guNFaMREKI`M8x;IkF+v;glb92Qyn;5wp8|H`U zughQKEiL!=N2cc)Yw1fLrxjLLn%%n@Ui0>{^AQ&tX`vbWW~_f+@%jDM`E&PuVV6zm zDiWEvf98#}_h+l}pQmPgZr(BNcw@=5n6vlzk4?2mpBWx|I={Z>Y37;Uj`c24k9M5e zH>FoU=3_na}b*C;R)z z@0DYpwlvx^_3=FuvrE~sXA-L%Se~B!^XKX2PjBR_=ik0`GlY9<>iMqf!rxv|>uqM& z{`c~WsZ>AL<#6`iuO%a|E?;%Sd-ZJAi3XG%&zI2RGHGr9Esi{#jQ?3KQ%>FmP~NUyS2m6j&E_h zF8ACd+0u!}&s3Jn`AYX`ePS}(Q@_?K%wa|KW9`Com$u)0d@?|3T}{*q@vHqm)F%f{ zHUDhwwTV~Hg;CnH5&RS#}zdgJfBJ0+{?=_zLJ>j`#gth(R(!6h=4Rd07^?PV2N~!#+nkA6d2a7BHpY9#E@T!PkLQhl`nr?d)_vc3X3wmjb}OYCK1{`}n>an?3*y_k;3Lz^8g zEKF)lcqX30et%QWlw?j_oA0+uH*%cgX1T5#!rAz<>EMc{cbb~pIcxfxTF;xk*tC1@ z=?-P5lM!~O`HN+a22DM?L+k6LNcr9!tIJQXe){Xp&$Rx~HG&?Sz06kkYxS;qCmJfB z;yl4EW2NTYXWP3LJ<+s}Qc{Z(Wn0Lg)Su3Hf9ty6chZhyfIRottje#+mRf8I@smnY8DDgQaaXw{Q*&(n$` z2dn!&~+H326cXxC9?Divn zIJKC*RLwkeX2Qkf&olpfxnDnieA_mel$q1CTLhYFG<*eh*fXZ3J2#X}{?z?!X85AR zVSBaaUNUrh7%_kE9moBW-Kw2Mr!G!Bwx(|NyH8F2rv&fctC6^zxx!;cWv8}FdXJ_5 zoZkYQE-ZL_EhqJ^-RDE8WKOJ(yjLOj)cNM$ zlgy6QTAS|Fxv@2g$cQ@yB)(%g*!}B}F)K%z_Cnsc!#$ZA$1i(}*#37dJZp6Eab;`4 ztaG7!*LI|Ba=md!{J`VFFw0fa^R&L4)p+2wsB%(*U5(ner-|ow@4Rlo&9Tm0U`~s! zLdS$cITh)ylQ~B_SN~!0TE20Mph1M>BhmUz6Qb(ka<(kEd%NDDb!XT&IAa~_^p6rZYGq4?f*dXn7izKRG}qYJXxZ+m_T@lP4V!6Vqh&kr7y)IU^{(ri+Xzv{V?@X23+O8RM7S4WJc=Y)y zi$`1Cb~De`XLh`wd4}QOn*7=;za~aoC(YH4>AlxmIjgsz=?)j$>FS-o#CJY8xq&b2 zXY)FZFG}Xdf>YNVSCyZ?Q(d6P@8p@Sk^53IXYV}uFtz&s)a&b?M?U+W>SbHLc^@co zJlpM}y77Bx+x=Og{=OdqtEOn>a67x+eH+rd@%lQAi`g4&AD!mWaeB5-X8QKD$G0lh z+Z3;@-L^PYsypc{Zx@%pmGRndDe6&DJ8q=yab-=M;cKlI^K`l4$-T#Jrl+@iq_3ZT z{rOq@@LN3Q_n`7tO#yPaPm?Jv6)_(+nn`&&Fp8d|FQ|H zMNa*C%to}~$={;O|JM6x)5LBK?QV;CE4B9p-_tI9E|Gs`y>szp17~-}*n8SvG}I5X zUF%q3dFO;==O^=7I_~=(TK@_8e)@4?var3jO>*bzWSL7_8sA-*U~ww>a?q1{vsHmT zh3DgbK6!kM%W$Gcb5-CcbG8pHiESlY*jyU~m&z>K`0q)^{{_2W%?Z46Ze@$lb;|d}E!H!~?0vRO@u2#to$qJNv)I1EAT%UK{a?_&`77>M zWL(j^WxN0P%KftxIA`9|a{S>^Zd7FY$YQt6(clkD4b6Y-*U=9BGx5>W`H}lt?_6A& z$-!1Dv&sAxcHe!ofn~*lC9~gVy;xW< zf$7ZAxT#CdPp{r{cbThxdDnxJ7b2HUJD&c2diLy_{%oOLOWl56GU=UD^`v?Jhgb!9 z;bS|rD^Jf{)1mXMdhw1q{302G=VqF$E4Mr1bV>3MpY0@(=WlGcU6vEyF{8aFG%tpy zwV`O?!C=Sd$7?Q6QY=us_dF>2`I6TnUa2#B{pRs3TlV*5Lx@d~)Qq5WaUqo)3!*-i zwr#(-+l2dBfbPNiIlI!c>)jl(duH?U`MVj^PBmB0Q+DvS%JSYBM=kw3P zKYMqGl$+fOxEPohfr3IDtUk0x$9F`o@iO{qwu#?{9=+qf~LFqyM_FZu+ zxoj_+O>XUfY5rL5?9F`HR@Iq*CSAOAF;HF8mTl=t6Wv@(-MdW(E1ejtHY+>ri~kaJ z)BiU6=}Tuz&IoJv3!GVS(EF#6NSa>ptY3xZpI5jZ^r}5=R@IjH^n%RKbH|JxT`J{$ z#kyU`^Ih>=!?!EaL$f}`HZ?8Fj4qfda&*~;6RV&7FIr%t#`-I6pOkyzS=F;03d`Sq zb$foyy2pF{)5xahd8ZD|-{WeqHeF$cYT&cU7rh*Pjn6dBy~M*(*)%U%Lq`6=$3t^; zWPYwa?P|iw5PBn=t3Jx{)8otcZ~ngAJ=^kywv5e+1_>VnE?o|uqmS3F=odQv^rVTr zm+EyV{}l$C4?XZweI{pU6yqA3@#WUnbM8GWgz_T}Yb~3ZQ(95^qP5#h1uKK!t2a;cH4i4#Z9`^ux~r>cL-*6FG{o8&8wruJLY zbtPu|XMXmdwcO4*Cs<)c4r{xrs`)xE-;*on?hmwK-uv#U<^MpfiRSA*=HE-YW>usW z&;F-Kb6eSm>&E9+@6wdD6P8(En4Prqr2moRkB^O2W2W`h95w&_L5KNFOdXTs;|qQg zyBgEg__8PKOP>j|Hor0ZTE2^!mQx_d&nbU1*62>DxzxwG;1Bn{)|Qo*wHb~XfAX}u zU!mZk6goeskBiB9-^uw;#olsUPk()@N_oG6{o2{r`p=m*EGVqpe?tg(IDc5LlS|1ibrPqV9(t$u`d=IqfG=;@Vat(f5TQk?TcWZuu5&P(MlSdKlG zn=at6U`|N&%l~H-8x%Sx7ij1&x|A6q725agWX+D19A}O<^|giyWVpQg7n194^WIZHCff0EU|7u===q488`2&SS6z* zvGCv@osF((dq3PfwESuHjM74vxGvKpt3F)*TXMLnarZ%~*$@0?g+4HgW4pcfl|hKt zhql+z%Vu^T&pYA&@~8Ap6PBN<&T-wk=F{b@S*|a-bVS)k-txrF2k+VhCKkSp`fhIX zuYHcyjFu92|JZ3ASh!uuc&C&`y4ji&5{FCqGPf>jmpI~6+j#ae zFQ?GMlr%w)w2W!mljK<>&aw*D#T(r9RMbBEmEnlpyw`gks2yI%BiFFyiF4&s`$fHc zoi)8CSL)S#ocr#bc*px@>A{8rdc0y4SK8AL<;b2sGyC3^{?+%-$S&1U|0w-^b& zkqK_w?ACL0$GYnq<2;@%ezE<`1(|Bi@bg~xZ1VgK%#L!;nX=d1Yewyi$Bb{kUEs6{ zeKzGz80)W1%1q`p%Xf)gELnHSV)~Eum+x(woBPvLWNYhe2cEVTE z&!qg}vW%#WsjQnXxGRR}`!+84e)ja2NWN7UR;d(EJEz2Bx2bT(f<5Nvb+LrUJ zBH}BLZL!@Poqn^H+4F9$3ALK{rl6H)#@Zm0W%+YEcO5P)Ii+uW`gU8 zvY~#Nm+}pEF4#GzBKg*a4O^VDPqZ05)|_qbm{53YyRNa7eE4)R$=l!9pE(BE>59ll z&i`yN>B;gF4kzb-x6QL)QEwE@eOmdxUT4bm)#>(S|E=OKYzs(StC{OqFx5@bRWdLj z>6)B=i^|M+xpVK2d!C%PG0d=FOQK3*)nh64hvyQj$`19kvFOB?PHZqJo^m>7yPs6m zB4-<~s7Sx0y- zcJ#C-c%?}1O}2aDHOE`qUHHX$=T6BNDXcu}AK869>(stouz=w_-w#O+F+KmUM(lSd zD(tSZ+h6)LQ#60))0HJZz4nMsjI7%EWQzFu^dD3Ek83 z9QLh`N9zr%gX^Dz>lYkPbnjGPdG{!5?R;)aivOHge;|J5+K*`uV=~PjCvhY$ zvos2qTg9?&PF&qLBf*P>&5n`3HlORAsI*Qb^45>IlgjaIlaQD}WbY=1_DwF`+tjA=_nN19U3r+yZ5ZOXv_WUb8;f6sZQ_daQa|K8 z{rN-s`o2why2c6_7YhnjJTgfy6uC5e^=!-BMLc5dI`%=I1ZK6na|UKA%L~ee7pdhM z@N8~a&vE$J>yHo8e+E_xv)DP$(Eqx|PkevecAk(a4^N#hlwa*IUwf6;$}e#<|K_r; z+2O=fx#PsLl!r$Dp1%BfIA@+YlcTolo%IfmCxm*}cIlsHdYM`lrDM4vK2_*|)NJO} z-+sj$TFl^hdJDq=#^XC(f^V4#hl*YqcA5UIB$%|Fey_O`*k`<`EFZ|*E z=*UZpjm}O!Hs`$8VXd2n>Z@d57ctsdzMrZ4Ym?-a)3INs8%eB_|8R0M5BF4u-TqJ7 zE#9(xiqKQJ{yfm{sjgSz6XrW1^I0~0FS2=~Y_}w?-2X$MbE(wvxZRKDa7P7+7MM@E zG->u_4PJ}P1KG|ed~`aF7u(e7{#CPo;=9i6lD)iuPqI!xT7$_Ui35(y)Gj|vInfav z=eb{@;M~LX(iqOo$2Y&d{$}H*=TB@k3$g?DJ5ADe7yi;#Q*?jRTdUIhJ|FrQeA*_f zn%YpTw@o+t<#!!5k%{Xq*M9o=N&U~6XJ?O3u@9aT_k0NtW4vJR+uQ{?pLF9^Yzmym zIZ;#nn0fJ?BX4Gy+WmZN`+4@$%RSXXGIJ`O=bc+AzOJIWSp8Y$HXqya-!Tl1zx`H8 zN3J==`8DZ16YH%7w{Jx~=WJQC(NDZ=fyL)NqQ@txxWq1!2xUlAWn#D$oO^NgwvBHd zOfY+qw{+3PEy+@QZs|ndpL{U2yW{zvodSG4D~vAX2cBNK?&zbX6@_l!tM9~n3ip?) zl=VOH4e*LwR#eBO!KdhcO-cU3{bdg`Exi|^bCasWCtm*2Ge7tvKYJ=`q~`Qx+za`B>{H}Q>aDugdYx$nAA|XC>%^qxK5lvr zT}3l=9{#_4^nFvVrtaqyz5N~u=jJQ@*_S3c{m(0d*Nbi`f8##fZIIS-f+s?g`CQa7 zjkOVLrfs=xV5e~+s`Zh<{>r3@AG0F64{dyyF4-#R{oUtQ&Et*k#*H$*9_1@d?;9-q zcurb}uT?eWkd4BJRSSJ=k0_TXKkfY6VU*Q(EwkskfMNR!mZOpq;y3m7bp3GR=v=eP zds)e1C-d!c%Otq}RIRFU@6K56yLoT*>xEy%UJICNPG@}1sNuDD`^J?z8i@rfJLW}8 ze$V`NMf!-SSiGckskwK$dp*0fMM~YKF1e=jf7_B*&E}7Ny>vP z$9(Fa&iJe}JM>x4xe2aQOEfmOF|6I#vM!xJUwD`61l_+2y&tO{>^~orUsE~def^?3 z=j|&WU&-g|%j`vy>n_|1HJ(`}|C2zRnH7~t! z!TtCxPCO4kUYhwm^6E1A`zbOfiYrVO9_-W?oKW`hI_FV`ntz;HpEhiBa@~31#?8aI z3f5XB(jPxw)7>b(w7mGibb|q$|+4~UG*Sl+a3k=Ghy-c&Qg3uoKn^LCW3I`{m?A1|rc zh^2fF)Xgn6@7%F^xs}C1RsoSU7Z&(U`2Wo}Iyjlp;Kt&GYo~4FP>4tplelw0VNdkc ztgVakj`F|xvh+&IrMT|3zIS=Kxp@R;{Cv~Ew*Byg3Ssr9*QPDKvL{ozw27^-Qq#&M zxm5H_@r)UF(pE3{ve+(0>$pKduE9*N1)RJNmlXDXtjur-W4$%m?)a;ZUiB?G&yxDS zo7k1->%zinX)9=iLP$)2h2pQ^hcz0x}?FP_iAqS0)D_(sL=7gGP0zK)Q5aynh7_;Haj zOa7V{p#ko@TJBI6m9MW?KUvwIry^gH_9o_t zk>x3ow_zXH_rJWM&C3X40i^kUckg9mLq@;N7}uZuiZ|H;8XUxwRWbN;h{h8CB#FOlJ%UrHd%~8;O=uKclc6_CgZ{9vt&INb8 z4y!BkvWBz-)EslW=(oW2ilNuqRK{87mR|h%IrGG}Uk5uGnh#%{Y7*yIA$Ut~S{uVU zvz8F0*O#tXPPh4CIbYA|y5q}jV&a!iO}@`CA;(cneBFuTI)7aXTQ^kLg==gMan779 z`NP&Radx|5!{YyqPaWo+i+v(Bwdm;U=@EhJHOw~mF*R*}{cTNI-qMc|9;d6zm)|=# zJE+`xzQmqV{h!O4YL5kIHLO2B?dhzBXoDTQW^McPEL_n&TRS^5cAoQOv70O2{3+8| zld)i`WEAggn{SnLM5)T6xcX+#dXVuX3hCByY%+oKx+;4nMU_VobX? z|7qfr1h<1R@9#+bUoTO9Fm;{1c1mouL} z$$a(JD{Eeb^1NGb{4cv6&s1Sy(q%}fKK^aXhTrF|+$sys(q$H^Dp7l|ch!lr3k+Yj zvAL^W(_eP+xBA7+(=Qz@zvsKy_{Htb;z8025~4LEt_ZEje{7{uy6LIdtB=>Vl-xeI zrR4p)E4OydxwZZ60>czbu`gFH^cj4Ko-QNW!LXo!Q^@hA2dlrrat0o$%#^EsssH!# zU*>pl)xOxS)Xqk1?smnnd224GbR7xVBe>-7>JMv|G~2}8n|AGewZ+#7-F#JbiO08H ziHqy;bB)E zLL5aFt1Lgaob%`9O=7dZc3N3Ro=}!&dUfzybx`^9zAMiEb>Hq{Wl%X^{m?Ek)9T>K zsX9f=uYBJt5o7lAwNTpU^p@Vq@=Lxv{GD0zGN_~>-2d{iF3}fTeD#>hR<1A8ag&HU z_QGxLSy>)^*ZWhqT`K+=dh3tTp=Wg)cBt}Blh_&+<>ULszx({tZRLyp=kn*>^Q_)r zYgLqMH~sb%r*(Rp9d{mFcp+xe%(Iv0+X$TDp566q<28%s2n7$tKEL^X&B5|Z|Gmyv z*dnw4W7sSiOTMhf{}%1FD`n|gmaVL(<+gm$S<|iN8@+t=A6 z{<$8)3=e)~uV1PtTIkRk^Yg*pD+}E3FZi_9akbTL#Xh-)eXf>U*UZ^|XO@)tLZ5km z%3j%ZT-ui(pLKtqaH}DI{oAihS28$Q@@3DaMCt9kwtc0b#DubbxpyCaxMx;;ago~l zr9^6u<=k_HcNT2yzNd7U_3^1MmqI??ELtg$F=Ni%m)qA&*Js??Q_uVFe$Ugi+d;41 z?Nr|S{@&bKX7{S)yxvAXt%xckc)cl z(>uNMwmPTs_4>UDz5V#us>^N<&30~YxVmyH@9T}uwGB(v9<1D1T%C2dtU4mxjbRcS zgIB`s#&0t`H7sKt-2Y@AH#{8`ry*s(;C1bnLmhk_rP&-|s6IS$G_Nb}Yc*N8QV5mlp|N z+0}aP%k=$IcE$hk$_iR<{o)GS;rY|ao4NAo+6OCZt1>q>uCqp zMqfU(w>r4|{k|(ZzHYm+|Mxo+#vK>DkNx11J!SGzIpo9HzHMRa&Zv}5J!avY%^*X?@k{69%7hH!0isz4y5-QQM-t`C5+jkDz(S=Iwtq>E{9;OU=bc ze=qai>hg3^iS0!xLED%c?UM>pPCfj0aN+l${~}hu7xM=(@4e9Qeez-Vmv`oHbl*zZ z;WoMBEBCGTo;r>OsR(0n2Ai{ctAjrO`yKSWQ{BKROXpTtS-)t%Gt7f!FQqcxbkiN*Gpt)Y1Av5 z-8^$zqL4xO26NZUPh}P->-lXjANz3WW>e~yvJ$(}9ln2M?^d!`WoAni-C5|z!Dh`+ zZ~gLmM;1gwWZjRH(pa<*! z$UP`D`Wjzl+I!!wYeIp%>n|TNtCZf8;E5wv5PNVZFAL_l`Jw^7?$Wm?w`vbucn)Vi!=+lY01XcYDT! z`)SqMz47h`=ZJA6J+^-Wj){^k4gq4aS-*V}4-}XMe$Cy}!?3UH<;H&g{oRM` zW?ze|((K)mx5y>TZ_n&YmTgn@);`weSS!SDEdHW#Yd}w~@8|6&KF_{leeKiL%TYaW?yBvANs(Fzd)PKmV8g>hgg(wlz9i z&jp&D@Rfeh67}I|z>KHC{=QSLTLoIwY^@ReIdSFchSuoq%hYQ46e`Z&Ezt?+`7PI2 zXC+>KVdDb#j9r5BE6oEgKi#jG_A{(6a2o%vja7De`LEJ#m|3L58Jm=A6vglT*D&2M z?R$Ks^4g0Fw2HIe%cOS9V4JhYcbCbT3!)AaoHntqce+w;+^`_5$U2FUvalLyTsE`KYfRu*xN+>$1r{B@ zZ3|nT?*1xy^ZNTNj{DKk+YCc`mI|=SOyzjiCw_&qfyX1Pj9VbbzfqyLS61dz%PJ4< zUbNYzCI&Wfv~`c9-AlN`1C$ z3(JL9HXH1h-hS`F?C|i(w7EYNlWo~J+@80U)W+?y6XcLvw%PCa#{a*k2S45`thx7p zU6ggrjEk%d3bGG0F0SC3;(OsRr{Wr;XVW%yZ)z{!yZapz$D+;hRSLawRR*fo2D{&R zdRyloe)V?4M%f=cEX=|=TpZ7o_NfU>xyj0LXi=nsMU8Ot5qI@Vw@!Ya_;j%*)}4zxVHDm-m>PUn8v0vHKWPLdUL! zJ=`pdH%<_IrFJ{bdifUHh2a9;PaQ1ZDhM;ORQgPm6=FoF8g{p(+p0fPCoDki>U-r#fru@Yp^OsY$l^X^X9-q7A^y$n! zzu#S1>X-31_mZaIllIiWddEoTf9xj`d!i;}*Sa^0hh&M409a7o<<$~?X?^oh4&v@^7`um;Er26jt+1wx;`p zV?p_*>hdfDo&8T&?)UQUx0xm;S7o7lr!n=~vFynQPpwJ*aABTus=q1shWw{;Of2kv z!OQOKlE1Xr{!d(#eT4~c-Jkl4%xoNT2aVVqaz5?zF15I`^w75FG7b|gZtc+)xbo;y z^j5|t4qLL`Ecoutd}BBFYxb%8cGkLQC7ykGuR8wKy;}dM9lzIUm~T!LbPJdeYSyx` zp*z{!TWOz(!iHJODGD6AC!A}lCawrM^qS#_q1bG}efDpK-!Eo4zkI9sJrC{md*_7J z{rB4S<=nzfJ@-RH&75l>dImb(fgIwRXu$^2T_a$IK(?ZnOeoEmrK z)@ZKIQ-{rrOx&h#d$+?j_vbP5ONXxSKe^$9?3L!dDF zi}m)qbEeJvqh$5eA?t#n^u6-!P;jmvbsN||9`ms-A3_*cin2Mb87bAHONQy=aYkPyY?ZDXKgdW7U*- zKOW!bdiVP+0ZH!e1vcy%CL0_ywfRoomfWtq;~(4NpyLe9@Au7CTc127p=Is=W701V zvA;MOTG6X_QG74wd^PTf$Bd@AFYdR!%d`EHkhMv-=J)Q1lM8A){Ui=}-OS0ZU31Ec zEBfwnvFvm&KJ(nwb0zOLKYV6<<5>2p2p0pZ=Vg4l-GXy3ekeW0>TKTH((Qlf(Q?*; zLt7acw)sBaSNd%6mbTF1j>e?kiH8Lj=lpu)ub1RdR3V{!`h>+3{g_F+izchAlj>4* zt81IDVwKs%^K}E)t4Ws@)|E+IEt;{TleJ(Iv+a`?tWS5H;D{Br-QqQ~d|TkN9x2o9 zhtFZ}B>ZhWl%7t<1$G0a*cfe| z>*>vZZ*tWA|B0{O+?~DcUU_-egUyP!=I7k@TKIX>)Cp_`-?vQ3KAKpkAdx*uGxNgK zg1ET~N3`|#9=LG4dt+~)!7m%Nn&hyLu^jS_)qD3mUUo^xVMB7iOsmq0qO^NV3)Z(^ zivBD9-}o@!?#pxg7sW8NaT-`Zs9UYN;%Q~}v^z_tXUJ@Z?iQ9+E8<*{S-XDAd)Zc<(%s@-WSN=XgitXgqOw7YT18m0xie*xK7*8f6HvcGU3xH)fqWG$rE#r zEPAD%Yoso4XK~ui41xW<&CWUB=H=E{C{{Ohp89sz=DW-sS%F-#Z9OLq%|j+934C?@=eoFOofrrION+Rw zd7o^5yfx@>7C~{n-t0gdw6GV@^d+}#k1iVn{$_KoAB)y`}wS@ zKYl!Z>C@u=hqn%2FwL|3*x1;SujP0lJ;pM^oX0V{)ONk{sn2_^U;1?HZ=}MF15xvR zkG^1^amTGb`)q9OX9GRn_De55EHtTjnjrNsfB(PV*DtkxXKjkO!_st3e@!AMcSOYY z717<_lWy94D9EzkWUpKM{`W(v%QxCe<(%8C_+}qZwOw$|#n94{LqcpzrpF5ohKb20 znnzq6PnEbTlyvVhe?DnX0N<~L>jR%BMf{UVc>mQr*s4ZmwLGaQZTp?{K5t718@DmqNIfTlP#?sgrIu*SnzQ&TqqxzIR#?=3gW8 z7M5?SHTT|9gM=1?!n_zic^K zS(|KLN6o)@qv+V45Pyb9CdW3T5Bno)7`)GYpLfdPLtRzI_k@Lq)>tR5SjphHMSJRj zW1T;=9?rb3w4&9TW78hiCZ7EGs(aaQvRPmsR11J)6Ltzc(7M9C>(W-qOCcYxx`mRM!}7n)Gvd zX57CUH_nQNbsh=dz|poczFTO)`$zfp?aAhcJ@)@_oi(RIzs;}BWQy*zc^RLUip#z` z{HoT(x3JSMF&61r*dxNv=qL5 zZ23N?2MVIC>MNNUQX8`U3O09VGaY2~Yt+hV?_7NGiNsgelmM`5Apye2)-p{~^BW-&y&~CPgzjn6wo%ER4@TOM0_hZlw*M>$b>Zp9xEt|1#`f zWjMFczf_mk$D1+M)GhR06E$8!lep|lQ zBv;en!$$Xr2|};`z1_X?d^E%1vn_9#4VFF)yHz`px$e!OBQMx__e}5E?`+$__Qy!o z?$1d_sgsXiY(KwDG3)^Uzi;{43Kbe|S~5x^TfTZYL>Alb>~8qL=1_3^`@Xr`n7Ekk zys1{GSt-?!-}qoc(Jmdl-UvVzj)qC~Q!&ll330t%yjy_aX3Ol*o z$fM-SMYaV=Zy(HNI5>F+14CcGjDXXV#jvvgd>5DZGqT+G5U$COX5~1v&B;rqK<=oo z%%9_&?wKy^lOnrT?rxsgV*A5@iDmk}A4|9VnX3OFy|UP={OzGvU0=_d`82IcxH--5 zsg8h&pL3kD;LO&%yD@vLSexdEC}h-fD{u&0o3;CsTFp{k+5Ml(r1p5(*|TK){r8>W zV0m&zg#Dg^#0_^CZG3g=b=O35SASo|r?8=S-R)0TzB4xYOxn@uDJ&|G5>%g8++?-p z9+M4=TWr<@^+e7kA2!9VIkozHq5ZViM#j&iW$lZYIGjJOj$jPG$GF8Rr2pgc#@XIK z7CDnz&w02%aXJd6uQ{u*nZT^({$?hp%lg zGyWTW#a%u3SWeREQ-VBg-=!nI?2=%cwk?VANYReE1pCDe}{eJ)ahfhUP4~4c~ zNeoy7+pWN~yn`)xLL^HHCx-2VTa zqw1f}EqV9Oy>&++@8=`6dPU7of^$V36^zdb zb$vW!yx*&q;rPz^|4mF8nto;ZoVygf&COYVsX%Ia@>K?#$iNZ}|9+cEx}5c2{V$0z zOyRpyvc5=Z_7cq*O#7WGKlI7Z+P>$CiE^9SB)%gjysAX+?>PLPiLHOhKmC7-Z9-vz zk8;}*bH0>bnre4&-~CNzPca{!AEp^yY8H~dWUJ>*Ic(klMPaweS0uL&uf~2We)`YCF%#lb2Bu_2twrb4rozZBy%rN(X^0l4$@wYa8pLfOaneYF z!M2^9t=C{`?isO41u1FC&yI~hrERu+3=rb^C2N-H64kI*^;KT}`*}-td%gCK?|67d ztS-;D=A@d*k=G6K)&E!o=6mU`xx%5s6}W89ZjN4O^Fwlvx2&4L1<6~#{=Q#2d)}|pR}Nm^xcxn&7Jpcj zmCxcN!Il}<1nM@2_Z|(3I`Z(yvJL-=4)^UkT$}u(@|(MT(vpW2QMEr?uh{?bD|sO! zmSYf=RC{ImCiTvaNK#pz>Yk*8}Z6A{^iD*BIA`=|Ac+u_|HNC*wJN1IMkCGV^~KT+%-?msKRt zxv22Tr{@;U#k+i7JpGpYLx_37_L`5}nIEP7FT4vlRuad;C0vtKUGhZHuWMO@YQ}8F zj?gc5fgTI^B4FGDzBEtFFqrnba_h2ZHBKi z7%k4}t6y8)allXRxQ#;o84sUVPc-w72N)HWicLRww!}vB_%&z#CHHK1&)9RsgH<_R zxa4w%xbtgs<>fneloVv1TIFF!HQv3w|%{o`?K;( zKllIMJteNnl2_7d$BAY7lM}KQJvivkU4O7`_N1%@C$7IJTqz*-{-DkO7s4yM7v0!4 zf8h*f{?^KUrSIi*R2dwn9O;nrTk~JMY4TBx?yJwbGg&M`cWhbGvo%fWLUa5dA%h<| zQNMYwIjm{=R%DvEo@2^_y}TMC_FndOuPi@vMBV0&OO{@A;nokkQp2m}`@j2tSby04 z12@CL+V7XGoo~$06+gH4iR~-Ni$|;yE*yHTQMCH_GiK%Y6U~0Ly6%ZB=bC@8oNwvp zXRUFccFzA}vh~Bu%(<3RXMLIWbee6hw*3-!)$92uX11)o`<;PBa+{-|-sOgzgH78? z{>ydz;&GU8=cmaM?p>IM$dS6<&YVQorbI4@t&?I6(o z;9{~#7?WeoK8B{n;c*EoUQ5`P>olF1(dP0wXSs4))(vgxUolZ>QHOF~F50-%ZiR{L zt^T+T-)p_%j!*pBS3T>4ndF)Ovv`^Qv@X4{#Pv?{-`+-&7H$z$-&GeWL zc7E+q5a4;e-Qj}&2~L)cCOw7g@QW#3O5tWWnI3O zTMq;;RTkSk;Vr|rFZs!r7}l}r>bUwoIdSvC-s2xiZ*NvFfA`~yU!GRSbeB_S&X_qE zM6j)2cDTi)=(A^t-ch@KHy@{OjMm=6{hJ#`b8-5>|9ISBTPCbJ-pU!tC#~Nei z4QH4fFU@0e^q7#ZIC+UBLq*SwDG?11IAn`nJ~+tG5Q5C&MC})aLdTC zy#L}&V9A=KTugpW5S4Fqi3i z{EBY<*zb+*GgAt~qw0Pv-15VqlwNfQI7&-*Fl_xa4c zH+66I1-4mVI{Rbx7RjRA2PXE4@tnr{_TGzBkg%0}F@O8a9aB>6br{!ne~^@)baFQP z<(u>WGr9iFvpT%5^i|5M0Jhw;rMryg9~Pe0Dth#x`_ztv4ZHbU*#$~6Dqh~c&n2+q z$b~=YtW6xAAtjDcYyRXZSIVXTyB>GEe`0F#yn4;Gj*qo?&-{8Xsg$~6VgIKEkxi%e zSh|EyaW#1oBR=g{kE?-0K_U+YC;fUFg`p=d+O4vUA=Mq0XY4!cI$^ zuKu>8=eqebJu!rVU}En{q_2$t@iVKn2U^{khcAGz(lf3aWUe8(#Ahe^yareOoeHZ6r4 zPWfpH9!U%V)8o7JZ_dzNw9#(H_R|g*B2UXN6K!kT%E86*RZu2L@XdV7laq}Zt5h_b ziURsp*G}hl+*Dd780*o#cWZurmf@rYp<6#nJgs@2r)KrA_@s(B<0qdUOEK0n3-Z<; z%CYJ_%j8(~?fHF+IV_Ej53?7_R`SX_wztLmYoC#lyLj>YYXw%0Z`KUbI!%1M`uCgb zA3u&_(PuumMUW#*)ImX_RAg7OkX%Z1b9aH4b+&99XdF-^0!;dpy#oUtFn{=grr(;_%zuQY^ElEq3&KDU`awcD|lle_da) z_;PWHPaW&sZ*IPR-~`i_Bc6XAaEad)i|2V^;`K5|<4X0~mp69E##mL{o%=%a)J;>i zuiUvWm>N{Ke*MvyF<*Lz&XzeH&a!cbcFkLPcFVbA|2>b-&sXqBUJ&-RShtqzqER4w zslX&YvEI_EuI9%YJ@fxEx&N5X5E;=h!&T;#(-*(ifcdvCci&@FeR_}W?o8{A3qI;y zb6j*uH<34{;*)mb!dHgPrA-HJ&#-7d*VoN(W$Wfe6BeY;d$1;Pddo}Zkl0Cyhj^AB z)Su^B`{MonGZSPtZ_UZzS-oVX@HeAF+w<;uRyQr4^(>=W;~d8p!7u&`%MUd@v0=K6ZF9=mWz`p806?IqEUv)9i&P%4p>qF`&l5WlNqv&lb| z^tylAI!zYk_P@2YUQ24Jcb`91r`70PbfNY9)!B#jjJdwvj5;KAn^DKKaKd|=ZT4c9 zVh>0;oi&{5+x}yU0IzBDlbwwZebY6#*WA|VdYI2(|3m*<{m0cMFKyMjH|+84Hod6! z;{@-FIgbN&i$-{u34Ay(EyBt*-uH*Tz?`rTABvUCH}MIi8|kr&G!|tuFo-|+zv!@P zf9=$T@={Bp8J<|@tDQ4DU9{ntBqv9ePLtu};GSBBStT6l_tK>OP48_Bc`2a5!}7G+ z#aV9i;~$eeK5I;t*w7L8>#cUCZ1;m-tM?~g`!F#eqfSdZrTcqGwqAu^?l-$dcUBa8 zPuVUkDzV&4_|)0+^G&}#W;wPZd}`=UbleS4*oZ>Q1*)ZnNQLm zx6TSIdC?*Ldf7Dl(#FGEeD|La)J#j&VZB!9EK}_uoBz1yF7u0*Y(*~__RZccIWKYU z+1dO4i5_5_=G2hLq|%n!@ciu>$tjGwv)dSxvo2Ol%-hbxt1SKa@(!5*_BNj{zh0;_ z94x=@%X=`G!O?;1eESTK%&QEQXCoe4y`1{+-3jX!@81pIoYOzG=!Z={8Eo6|;OzY$ zZo4}9;*KwMiz(v#A3uG@h3SUVHY?tfo1A_~%KMG-@fAKTZD-x`=Oq;H=`!hAdHV3- z_De7K|GYiJ)yk&EB+Mp2erIdyjE=dv?+@L`Z9E-(-`g8Beq_yW)6kzFCv|PQWKt84 z`W=Zk56l)FUDmiYQ1rwh_31*Amp@pW)O>XJUw*Lq_{FztE^}yHRkBFTsA$@A<3nn< z!q?6nvwC*1%y7Q1b7Mo)_jyN@DjNC>H~*4mc&RqcN&Vv1^hSlbvo=nvt62JMBhMAq zi&qtTk8vfu=Ur1DF;DNW89y&Ki~hc!Vs_m>IOf^rmYK=MlzCc)DgHJU+plyvt;wTG zppH>MN)r*!|+$hnE zR+-=4_OdQ;zuulome<+}zd6sd`+E;%DMqj{wohMC?Z+hZ!E}m^(d4i9B=#CCTr3+e z*gd0D#6axpZr}9DX7^oR%DTQbkXq0klvK3ndU6w+a_A-X{y&#O*4*v>n$M!UPQ)NZ zbIV5WYa7xQ$}0&pWGUtx%8%omD<|j@XRvRBc{=a)-7LlyJa?A-%}!hr`Nv4v?fxIG zuaW^3|Kr4#9%E=NEh^-+i@Ij~)JJ5#l-+%Y3G)^)B~M=6sx*b2^{QLr7RK<}w9UK` zmrtgqT#Nfv>-B@zgn!c&M&phc%RMhY8BYm_xT+zjEB8&P%}CPK$}wI7gl5$FvREvTHZnU3O6H#M7QNd*s0ddXIUPwmIPF8Wno$-6=62p;?2C@ zPuE|*_3`mboqc`0ZOPIhLX$ggp8a({L35LgjOZ&vp8Jdvxz(Snzi6;F`D{FHzM=f} z*_G}5;URa<3Iy9eUK3{iEc2-7?E@d;oy%?=e;N31&ejtf^kRPf)W7`dH^aexJCEFk z9q~ef85Z4v=eSSK@s%=O^-|U^=@Q?A4vt)zR*Sm*A?I2}5;P}O2P<&&&*r~a@HlD1 z2Z7sH+fb!FOzp?=X%x&3l8T@mQ;|KJV(h*>268^SGVsqQHKkEj4z+> zJ6<5GP{AU9kfBL`@dMT-eS_>D29sS^$lC}Ti+K8bgsu@43#-wdT=i%P!*$-vMHlbX ziaTeY5x9HKX=R;vG}DHsk%ml`>(q2DJ^$$Ry4`1WA~i1HDI5tt}oC3zL}0|-siI`?D%tb{YD#Z z?gg(_vTIamIU3fmV3T3erV}kEmHvv)^Iu;7X)+H> z{ZE}4d=oTyMORE&mc-oG79Dl>Li)AbhmTykv(&8CNC_XscsQTw`!(3edlW5Hdpga)XLbD&63yBPMv$0EiA}!F8t`ic0pm2b+6 z?|42-(8f#IH`!y)Li?xYCx85X$mS3bzdcpAss1N(gZMxH2$tB2>l4Mrr<_~rJk#Le zsR^zwOP}OC=i)f@`GT~34TFW{JUv4bo0@*r`7@rFRQwKLYl>poS}`%bosoHh(`04a zYs_DdGnKBZl{Pksynf;4j@&0^8%;tPn`9dm9z?EA==l}mU=SSEu)sy>ve~a^@(m>) zEgKZ3U6hcj`<(Ejdi#Z!pIbIswN-32Ixb*XwXpSkER)Ua>$fVtT->tb{l6_0|MzV< zQ}AuZx$7K}FBVMJIX`1fu&PAqGOMzR%N2LGY|-+Y&&9HFO>EFq$W2#z^@HR3qKDpFUb}yIEyl6$$O%60slE~Gi(79V ztW&S!U?@HmA(6Ghr>|#4^_pOnQ?JBI!d@O&#PY&s;r5L8hjlwAHuP6g-fo!c9rKsj<%Cb_0mUyro=)1ZL&My$ zJ<{~@n+5JSbBtFW(`VPU`=hXqJN|)p6vILG6_?BJpFVMP+m;ivTBP!xy*(KDZmF@r z%CJozc1GB#Ef$v+pEA3_X=l^Qb#v}53b(K*(wGyi|F2KgaK^_cUGHt%1oh^Axa@L9 zL^ilVOlLi(z?+XdHJ6|3l3B3C%KC%)LcxLZvdo-TYC zaf_K%WRlRcDn4_`V`uJNIkT^<>AczAQVn03Re#Q|zx->qMdJRiVqrdQuM|WkrnTud zFg@LMplNzXBwLe4@oiDj^$B4+i#E$Y+VZtcfu(*0+dj5f2ao68@kwoW=4RdwpU2jN-K$=PIz&EqO0%YwY{gx90shFk3X=)bLof6-Vi-UHc>ldXOihgdG zXL;(^-Fa#Zi%NgYHTm)J{3U_ZqRyFf*G=2s=I_t_^xYE0>e^GyYc{5+YcM}OwDpzR z-!*e?X)s;?`l3oI6v;h*5!)g+2TE14p(d@p^56 zBiCPD6~C-1724i**nPtl{>)V=-dwCrQ4x=X+qSfc)MIrs?x19Npnknt}{A+ zQ{v*3&t`u%rRy8tF_S!`)KR~N!K>b7>e}voyOwf`2W;Uv`r^Oy^Gu()ap`-{vc3vx zHj00~d(pJHCx6yP{*)57PP^21(sIEl_lB7<9R>3jEvPy4XwZZk6%ows!f4$|r)vUNamtW;kf~b>Yv?Ss4;t7osjGyH4}7 z>pJJ+D$U$%V)4S{T_St0`JUDcNA^-ShSwVkq`Uux={&ogsq;npjs2gaTPnoG^rf~P z5sD~dtBpSG&pj)4dT!4dx0ol^4GC(>>uPWH?^#kkK}}S^=BqqI6Ay2;U`~)9v(%PI zg%@8|y0v%mKYacB?v@`{_$O^{yZs@od%@f*p61a7p~u!LdNEX8Iqf02k}-vKUKGni z&KS?+Hs<5*FZbB~O>R)w{P&`EbMt$HOa*>kYop1QJ~C4zBN(1K&Drxds)?23+rEz~ zlP`SO%%iYl{>-!6Tl*8lxtGr6o7yV8GbcLcUR#z%CL_z6IM>7k#wgSO>X8qAnKvZw zlY1;=B+kFDbNzSKnnll2Bo@&YBo-GGIjb(uisB&>Dt!n_s2D?IpDqa zQ(GP@ri1gc=TBl-%C$q?_Ll42(wG9feRq5BrzWc#f7r@#|IDoQPY#y_e-L$;P?Y)M zBjZouEmr3p6f)Q!2mLE6oL?)v_ezU?wvW)P74vV*F;UZy$x7Jp`PA-h4^vwXu3ND2 z*K>ga>F)nbvX@zV%q|MvJ-;clq3*Bi^l$gt?S*92<3G2YHy7wx)YdvJkMmReLY8z} zKR>1)2IBEa8DIar4)Lk#pPODc@tl0Ez7BhC+w=>)8^69h$}X^E%GccmzUxYtY&vZ) zU3+i&w`9RT*UXIs{yf{x5NaZ|=Bslk^Bm)ph1(b-+EyK?G6;|O*)j8w#uVilx9j;o z{1#B~cwZ!%e!a9Rc`?5~E6;*imvb zt@+DNA7691+y3{fY?BAy`WQ3}cC&N5u?UTlX8!r&@r!#$vzC2Lc+UUNYU_TU2W%XE zGRJP7`XJ;SS2pJvXOzpGswK(+a<5Nh_e*F8Tb+2bX@9+y)W)gt|9Av`)J55!e`8ct zZnwHSlG`=sX#1lKl|O&t&M&kSX;^b9d~<*N35Lj`p90Oizgq6C5#X_&R63_4BPQ=| z?|#kuzWaW^GdU*p`pNXAwcm~2d{(GyikPmsILr6Cgq41iZDMPJw@B9wGx<)A2+X=2~+%-vT1_jSbLf&k$f^IK;iC`-XL;M%x>`m zaAB|GPPp}ICFLT1`Z>WGt(C+eaK+gQ&V>I{hFo6RDEiMmNfL8w_2iVyvuJ<^5IFhSifw) z_;}YDpBEP9F$?0jH_A%gHR-aM*{rieJ52k?C<`n{$e>l{qU`;%j|CL-|XZYvFN1#_m{8D78c*G6cBygc-2bGOA9c&P6-?3q{hVbNO^Sv}4hMsM#vPGy^#`_YFU(rkknsDt|MJcG zfd(O$Sh-x}9a+;HniVUG)|ym@h0SUF#}vUdi^H|MYx|$K`OEcse|*}`(8Lq(_dz}= z&|-IHmf#j4BcA4Ook>C((-uf|KUi9H^N@Z2feXbE)xSB6H^(_w%*p*>(^PD+R=$3E zo78@*d%WEX`egRpNt3$6aCC{hfW{Or=axU_KUKtTcJ6U0-F~`1;pf9D`{K*DyWh7> zbI_5${qNE5mBsSBbA=@ZGFq)07Vv#AGl`Jbp6k@p;+#4_)^HxF>J$LbX(HDCsuc@st`TCLHx;@+V_mAiZ_6U{e)s0?K8{QcdJk$7ifGb-m zw|a`QrC0RE58osoy)%|vqMepNu<&a+1bAwwUSTDOX=x0F&#WA|3^V* z`du!LEWt0r#XFlF=U(2}zu<|pS>#e>b_FT63ERaEWJ-lMK3Mu+OW=rm&%%dxlTAwa zB|c7-xxPOnj_t=uj!j7i>l^ySavC2@dd+cZXH3N>&Qlh@IhL(va{S@4t7-=qi}-`t zm0T0N{t0+ADCpU~n8?FYe^_9Zm}4!=#nK2C=`}V5mJwaYCN!se^=))gYn<=JHtWd! zL#9XmOsbV&K9HQTsr0*?n#cp=ZSUz}R)KDlC}@7nv5wDwM% zW;EsL%dUkFxj4LKTC)scc?#xHu3*O{MxoOi^?P&~e_ z*YE1@mHme4A1+*Ef$t!6P*Bl)BB41!s9CM5Je_yZaa%c)*!h!lUgXX_w7qfOA%XvEuHIjmF!M-3 zqkk}Oqnt!X|2D<-w_ z?VWv8mZ!G%?d+A6=l8DsdH%nZs+5iRNwGK~*Dp7YX_O?fru+(Jla_0`*|h$hvP+ww z+P5^%(rcR(Tb}=2+#cEbZ~K=!Gk<)FzUEi`*C0O1V*0hdk8=~-TG>CaU)#XB_u{u- zSwSb=BFuOB*QjoNztcMRulzsPS5}cNUbl|w8|{l*_$;Af$E8`Kic56$R~u-*iM!M* zVsm)W@;M&%+3bA}-XBS=imO(gTl*}sYRdbEFaFx}-F+S`efo_Q^GP;4HHp5D+dRrR zrfu7}PS~#C_3rXzrMD8&*P3m3QcV3oSet*iQ3$bngLms*6 z_&;Xp;t}2-3htEeDDG9vlh)kj9I<(V;UkGh(Tgwd z+x+6svZDTD8HN9qUoQLqFTQ1dRDY*<^NWp2t_JoxMxPX_GN)aA`svY=VCTu7q?tK# z_Fe1r&+g^Bu}jWE#>B2K#&D1Q5*|O$$i%%$>sObbTsU~eO>=wTt}~(>4>q$gi_JW` zN+{pZ#p=iZo7Ly_EZ6D8zISn%wdn&3XFRL7|Ap%NzTbS#&)w;!{PO#m{}*;eWq%2c zT5MQbeQQF_u4T-g0wxMRqB@S;(JNM!OstwGJ5%ArGRLj67KaHlri6yg>JUEu=JUI9 z>muD-a=(|l+%$0fe8hMAqs7jb@_meJue0xT-rT!k=N@s@n-cNn_Sa+it9J%1ne~57 zrG%{T)o&k7uc}-*Ec*1!W>MuEb&T7wlbq-JKFUMxGO=iS4HyS|!B^Vr|$eq8YH zMTGo;-bjI~p%)UEZ(ome-thEncG#o*U3R_q+arIMZIWISJK4(o?E#?!%WRy^8NCZg z&^&!N{ku?1oXboX)0B`szqRdIo~Z3HcSwG>|9|qUpzv z>PIAbF${E^ecE3|9;`~BjM{x)0hmmly{5Xg`9mDqh)wV>tO%ZHrA%z>i67k z8@R-NP7>^Cxsbn&-o7aUVL)bKXA!;tSQQG7Q9itHRIr#zRlOT|9-kAc(U&8F9Xj0JeS6#xLe^u zYrL(_HCk58S$wTxw$<_6prxfJH{bj(vWfk5L{go~rNdv(344SkolVfO>K5WY!NcI< zD6;gI{|=6aL5Z_g=XC9T^pHKM*7(U;=km*OzSo!3N4H*W{ki1!5e=VRpD(IPd<-i* z|3y0C?%$1?v)|N6$kYcqY>+B?rxU{cevW7AgO<}i4lUcJ87QktY~6fi_gh)_=-*%W zFYAx5?QNO7{Ib@)bQva&Z8zU&r)P;Tnk<;WY!p-=vGjWT(x|T=ltYwmOmTa^+g{b= zjvc2wca1sMgq__MY4g=nCW}7U`N4-R=I3`tos^)O`A1hW6dZdkAIuQKdpcg>RnEh$ z(--Fi9d~-gVfs4s+Os(ZM%qjA45V6GFSdAcv)|gGvHZyu#(O5+#aU6p++F=_*)tx# zoWD4*PiMDT@4eo#M$3iYJ}(bul%ASwl&7#Jw!sbEL^j6B=W37kTPaOU3^=j^+&hMsX`wt&y^hzoDFLA7wch8k};WX>b7j2wAx0m@F ztUtT^J(t3cH~EPy`L}!BSfp2k9a|^yY}RQX`RTV(e4)s`=8Y%a&)P=17tXlOb6C@T=d-3a8f(1zB=eGFYuhfYcstAQ zt{{s=+Crn|Zd}H+OGbXOTEgN+vs=fHr}G>zY1>@& zcjEEYcLMYLzGU~r&VJ9cETr4_0+-rV$@cOp)&2Dq3OA$~4o=KxZQ4}Gl=Qr#{KM0T z*psq9Bt>v*G-YPp3>g8FByFn_yvkeuo!(T$k8tx(qr9QLWWmw2<~tX1-rjusIZifMAnnXVS@V#CN*Rw{nw>ekp^-PJ!X%tgVNU%C zmKf&8VbhpccCX*>D4@8h(=#*a>Bbvto?-CYZY>LjQAi8)| z^GXIEnqvNeea%GC1(mPovNS&QKk|7}i1JOTh}Nka<~%lVt2;0J$vJY-Ylq1T)_&cP&$_Zz$gx3|Au?js4D;rfXMf%lk7?)GT6D$ik0rC? z_PHGfVgidJbmyt$KYSj)g!}wIv#C3jzA!d-GhDfLKA$v#7YfW-&%;H@Ur@U6pE9pDW7I4Ms>iz|;=Qp->vg+@U3jJj)qshzl zdhOx4FXDU;FX`I#+>FVFbK9;w*_Bs4l%GZ@Z=YrG@?GSlq@2SwGwlR~6C4GWw8 zY4ziN7LHx128J^n+(gxceB*3NSlE;Q$ku(VUmkpAPpXu2Qu?w+MX>$QoNP9Ml)~5FA24iW ziM+#8s31IpH%>(6#h00zGj|ro*8E&*^8Zoy6W6A1^K3;zD&|LRH?846q&T;8lgDhE z`Tt4{XIu@{7T$P%Y2Bl$kJ@UR8$w=AVqTFodG#fUedWJgdj6O?OqilJYoBs2TaeP3 zkhV2NU#|E?x*Se^aX96@)x}3#^QsF{ES`M3P^MS+qi)xaTiz2Num1k(b%=PQ>0zHs z6MwRBFfIIW@qstfLAeBBgE@u^eft9#9Zlx%|C#M0-w-ml%&~WRgTk}^_43~if7ns8 z>30-I%)PL~MjIBi%$h%aReIvKZ$amO%Dz%q{q&Jl!10CK`8MqE*s`>{kjMD9(yZ+H zAFsODZe;!MRoDM^ALC{j2g&0J!iMg0TMxGS^^83r;&y70|OJpDV9)GO%8p9s8 z*(yFlj~Nbrj6M)5Dw$+QSK8`yNZ=bUaR^#=ydUgCol(A*ye;c0lj~Q3IPilHA zG{=Pfg!%kz6GnoIS(uX6`e- z*xq70zF#L8f-PJ)kJvMDtP&}`xxwk#fvC#Z|Gb{xPd6@j%c*ce_<8SIkrQ6IR-5%U zs-DrWHSI3EA;I9(T-Y(|&X26L4TeYCd^cvA7#N?_I$HE}&Z)_IIT>fSs#--HDir0g zvhpZ-e&M@8le2=wo4BVF+xN@*$(3 z-3w)Vqc5q6D*(X6yfq$kffqw~l=?e&fil5?Hxq*=1wg`HpM{%;cBU7-?wL$}5< z$$-n&o%EQ8}&v~X)H!bSIrAoW?I!POz?2YZc*MI((fQeY$io5$} zZ(Hv>c?th1Ghfxkn`TRM7F=H2{dbArzHc?0RX5*A7gi{VB$%sw|9ATPvHcnfD;z#` z%!zBBntE^ZL#53c600?HKE=*C;cIsD*ZzO!OS($bbpQAqb9|Qd%+~I5s<1@XEy;vd z(?~`~b>e}sH2+Du@JX2^Iz?wkPIKV=*&k&O9bt6Xc>isQ`F@7@IY%;c-zF}f z+~mBU_wA==9L2vUUOVd<{peWfzw76hT{AwvRPRmDPeC22TTPR-jw${E4@MT--m-TrmGp z*o=;KY<$0)*?uVBdcW=6{evyP7Rg5}kze@g{KWoqO&@Z%?D(|RR`dUh&l1g(Satv2 zeJ=OQ_njQ)^wO2ytIjjO-NaV(IM3(sY_lb){)|ESD`ZZ6+;>RC!~O$P`t9$aJ`dWLnz0kOKC&r3E(mLw(>893(hx+lNRj&qPMInuD;hwdVl103Za-_G9g z?^(*X?^i=OP6mpejsEsBKYm%sjp!M{AJ;nz%X|yZ*%5PH>51&I>I=Pv_dGssD3vbt zyXawP+m~Q;IO3j*@7wotUx9^0vhA^ z?zk`UDJwfTi(NUwQukxzl+PU%ss38NE_-C3mK;B~g|Gg&l-l{81Dnl0Z*@sDyuRfA z_ZqLWjVcL?{?BA`l)9Z(-?6pRRL|bOjlpN1t;g){cK)SiDJNgX|7}YU75O{*)@PWWv7rple%XjV0Nlt zY_L}PwgZ1_XRPvexPMiIC*$nNa~B?zZ=4$vs8KW7db!dL)s63pGacUDeD9v=T4(*X zt8otJ%+i}y|4*|tmCW5|S?0n&d5!Z8=UXe?SEstCsQWElCiCLo>HW+6eXsdEiJaW@ zG`2~6*M;S`v_vP&D*XD9J9m!nA;*jQE9NX%!fzM5)pSPtg?&bI61kP~)E7+SHJlza zEwV(Rq(oM)?qTFpo^#S&#kYhVCJ0-9yt8EYg(JWAocZ76$tR)nG4geNli0yyp@!40 zij*$$wwcA1Eb?~WSvKjTyY3bwPB;+W;C9s4l-*QQf+1=Di{ivrll5*L{_%DD1OAPD zx90Z?OemCgcf&d{Y+YX@4Ge5^4&UD zxk__R{l}XH6W;ItShngQOIpgx_l!BZi`8emO@5@8z+#vc_>o1Rt1?P=d71jG^K6S2 z%T-!DjozLxpS9(pyXD&pApz#oFAMSgbWd=RI_#=&IOnc)jm2E!u9<%(eV*}Xw+8z( zwMo15FFf$^shN0NoI|hpusfrMvq^<9nxi?)3aWuRs5A+&AqP z3#-l{gXl9c*BQ*qt35Q>qUFys^IMw!2xl^L+y3}>V}VrV8^;C(wLP*Nr9$miY`rHG z{M(C#H2i{}l2(sI+d<qhemdoAC?H)1RWR94OWV(6yB%~H)#*UKCi&U)`> z*yCGypY*oay|y;XN$IpJT4yQ$DC}n9?6-$4pH=?pE8UengI#)7UrFMQ#-KI>H@5dr zG-RG~{W;Ea!s%xB3is<~v!4X1Uk_Dyu_9Jd;LXd&wh1v`SxY!GBv!3_qbR_0?c(-a zi+#_|70YWKc;QvM|MD~AzO6b1&JWK;O}P8A&-mVnw^r}Gv}Z04oIjUgdC~2%NxL7P zKP6Lk_`@bqfiE(D8edP||L={2Bo1&_;=r~Y;op__a({9a6G*T)?(P`*@Ntns#P>P@ zn_QEVALpw4TC(MukxW1~mq0^;;)bL4T1v`{`{bA$YiA|#yUqB^D6k}-+jqg8$+IFm z%Punp%w4?fRjas`!i;ZkR5>0i<+X3=F6LxPHeQl1nEWIAqTC;SQ~&3;xAAIxD9wCx z@OO}3pY7RCOpcBV5;m;*D|L4FBKal<`NuBBsT`t&r>om1kfO;z7j zI+~p-KA^+J65H1`MNy!H`MYbHi`Ghpiz<~LPw=f`vH7F$bn!aRtj}R#hSNieue_2m zIr9F4cHQUf%=U2k4-9@BZ6|~Ou9P?!V_=rRGTU50=aV^u3yK3OgA-oa#HbDZn=|BGF}KU{Q_$aecB#IY$bK6Ar~kB?XWWtx41fn!&i zEdTn|Jr}=(OS`n4y7N6XWTy8ow(<|Irct*xRpmXIP&M6*=by{GBb)&dfol>rWN(mX zeW{*hov+wvS(>$ezu{8rJf#D@PYyp`EYLh>c75x%XR941WSsHUWR~H%eEd&lv+F)K zmgEhbHi^yREY~VH;;J!3NF~9Na*#}GKNcZfP)Y=j-W!c?>QWJ$w=3JX}E9?#c7IUO^zonK{uk*K(`<9w|EZ#(*$K}W!gVUY7Gvpq$_0E{2`nu{n&zjo_&1d&| zUs<)Z(@NoE@sG8Ug-a}I8WMUoKM8J5N;6u}b9C{iyBva*N!grOn(|RLVb$ zy1h~Keoto~v=frSpGp z=LhF?m%n0QaA5FsaSZ8aIljz&g<rajB}Wee_(3NFF5{4^@*6;NDJ;qJ0Ml2qVEh)WoYMX8? z{CTzd;*@8;C)KhZeKs{;-r>c^aDuze&Dd;Tgsj@no3`the?D*D-T8a*ly7gJ$NBtR z7#VGN+^F;HhNSOOGg_wS-j!q6z3sJH&8ECVoZqC*T<0*UoBen0>egk8(=IbG)La*Q zw)r4?jU10kxUAx)Gke->FY(W*{F!>`)0`zj2cjABydEajdCchDyZ+&K=A6gIL2u?P zJ9B>4lsvUvJZ(!A8ec!zyPHw&i{ZY^`TzT$b95*!pVg!AI4yG*Q<_10ZV}szNC&s` z%A4*qbLlo-V=6Ickm%KI=&gRwR1q^dYsr+%yn}1nKNm5x|97}|@nOx)`*zbx{;)F~ zeEmWHZr^{Igyfs&JEi_{36#7tZk}0wHIQ?)>RqRrh=Vb67pDYOTm4UZc_iyo`{&#H z#V+iNe*fm^`EQf2)Rp?5N=yG3XzQeVOL-+bN6Z19%PGDbEH|~-ikjY6`}yTCefw49 zu#-nOkD+&W`Q~??=_U5>7-l^DwWj#=>zNCr4L`dxJ3e3f_M6PA*j?NrzC}#0v{&ud z>2bY#Co@N(c)5M=7Z=+I0pOui0Zw&#i8@W*VH?Qb}Wc7*%dp)c*5McMsyDYL8_hYPzZoqsXan$A8k zO)6o(+k%BJSKaCK!z9BMPIecXhn+NLbMDR?J6TZ_x(S6jW+#cQo8 zoST-H$sW};3(U;^^=r$UYi}7@d~MBGn$C55J4~2%f`d&YX>Yw|d!|_R;{N>;z8DtS zZelFiRU-3$ZG807=nt}vi&o4yd5CSn`h$;A+r+lu@K=ExJ?DxWq#ukkTfv-tiitaM`;PquU)(Z87UxK0 zaPnSq+7f0oGj-XFzdzkG<`q8)IjrugpkdJx$tPfOrd|A&s`NRHXDw{YnorL5h-G@< z)il9cV;|q|(BofZ7585B+x1o3VMA3Q<5Ghzt4(j*RMYMY8H7%7xqhI#IDg+XJ)8eE zD%EfI|5rRT$ujhr``Xk*qoMZ`~@IVYa&S3S;z5-;8Yx>nBRjc#>B2e4ehW z2xt1sy(g|)WZX9YE5&4azj#u0sP~PllD{?Xe*d=nid~(iE>qBRK?BL;e9>N?V@C@U zZ}hx7C#ZJqj82~Fs-C))cMHwc%zkB?{yctVpJlqI?nV8&uQge-y^`fi7uq{{AI&#V zSF(K{a*)%l-CEwZK%0fdXu1HOtVs8-C{|G^+n07li~hdaK51LZavtMlRjZ3N&P-9g z<8D!DEjhj9&rimKr;k7P%5UA_`O8tYW>EuV$Oa#yc}imb-ad8-44nselY#4CI9G_W%R^}dpT-8&$*hY{VI){ z;l@0B*AEh0s|A1Z&S3to(JywN|KuUgIqT=S3ryVHnX-X%>ua;bbMw?5RYrT2-*bvP z$a}C!=eEa}-S61X925}p+oTE_b^cqL>ac-@!)kv`#QKQs{I%C+&Cub#al7Y$Nqqih z_tJzux06v57{8s`>@w$3u}J3BGW<{dp1d(Z zuJ>-4^i16e&*LWVDe)8YV}4c0_pg%Ck#+sWFKl+ajS14Hec3H*|9#)@FYB{vY342k zpQ2xCiM@^A9t1KTobl(*X-SQIlofOBOEt$WOi4v zL~Om8YrtJCX&fs`4;~J9#7fa@hhP%t39o9J@E!mj+)H`B=0dKiS zt4aL>hKPp0E(#f1D;Wj0#H6ciyq@bNUsS`mRwX2QyXMvHIljWy+ZnzvHfk`x>AC0j z=Cr856aKtqj`Ou%pK1Ro&dqX`aalkv2TSRN&-P3knVLSPmpILJy_Wna;?dJbadUp% zuhLdkD(fo0r&#oS@fL=PjbRBtZZc|oH7Z%i!D9OQW@D+E%SNVU2Tm-~4YtTTdcw^QznQxt)C1tRa-63F}UW@5`EnV-$=Y<%yR+Q&wB}>`;o&7xM z_tbD@!D89_u8|gLtaeII%#(}K?bI%cc;sJ-DAZ--d9qmgps-NDr1KM``-`Wlcg#xJ zEXZ?hA-`0{Y|~$En>YO3bl|7k%#dkJv*xfpx#Km@#KFUn!DX_?Bex$@9kQ!0aOR#B zeYdA!(!p7r46nBc^DJ|X5N!!>zao3K|HM-@ftuH)XNvR_`WE}L^Rfx@hcc)Cby_I|Z(WxtUmKyI|zTmB-|3OKmDfK!9)?cmr6fb<( z-p}#J@%AZ(e@t&&YsAj)`yjOJVQ^;M{e2+}&rA+xiV1{sXdPQ2FiAPVH+}Nm>gb;L zH){DGTy_^RwyW8idwET%gSqtQo6qBXxqp8<@amA$#JhF}h0NyA=`#Lzx`seA0Eg|IGNBaoOb^MVB`mRLU3lvii`&7-@!s zjdL6>t4x35^-QeC;HilFvIL`q@7~w0MNUdB-=}c&%FW9wZzc&pDX?R`{YGBL<@Q_K z6K77hWgK0xcEPFBZZ#*iZTL8mP5ri2YiDM1)J9=>%^5#t?Q`FF@u>OVZ=$l{jR~gF zGXLKvv#>V#`5*U|4>2!ptUA1>ilJ`x>XzT!pTjH6n)YwnnZH{;crIsT62p{fvZie7 zqk>mH`>@lI(XYB$(7PeE?a`{7D9@_RZ2#6iF26TX$mniDlgY^lcITt!*-jekj_+E- zsqmwD%A^H~a(n*%ca=LhY3u4oeQW1Lr~11azPI_FlqGLF?VQbbpRDtTSQha-UA|8t zSETpoucg(lsU55pHwES99NKkYR_JT#<-z-st9RJ>-l?fQRW>V&T`l)=)w`*CSKJIZ z+OtoDV^*_))v>>~KHog)&C=9#Afx4oY0* zaL2^uUfYUi`eGd04*xz~BCv+zdi!48f(PLi&pu6>8zAht!jU2D+$PN@1_eybGQ!X9 z6i!++&*IcFzm+mF6IhzpS?}J|{&-bgnVj#rSn0-vP3v+KFRgxiXygB5u`g%Mx0@$* z;nS>k$8gaHP6Df6R_Dq-Yu@#&$L;i`Ahup}dwcQ9^UpN;FAL0Jnssi$Pn|c_(hlWj zEIvFkyW?gWD;9k6OSV|I&aGjxPf^m}uPe7_vO2Z=ZY|RLzR2((+crCk9(_R_8y2onx8aySe*WhI8}#)5m((H!JR#$=k%xF>$`FVCxz89n*c-Z_e1sA)P6n=kmOC znP&Qf2342+4h$dJbe=q7^?EfU;HQ9ydEffa`TKo;N&H!Oqvz}A4e~Z#XD-zpJ?t>= zo>7s?M3LgRclnifc%(bm9Tqa)xKi-d>#)rNH|{Vv{CYR5@93Qx4YT`|Jd6)i4>aDi zKg@pN#YMea*YCWpzGQh|n_coO=~oSfe?3H1NhFV=H`04I8%b6lYuP#N z;I*ENY3-`#4VQ}T<`i?h80~jz#j$U(f}JY!~iirXr;aX_AhMWnzV{ z@x7aHXc1>|`2I5ASqkh4R{fhimi)cRUpOUw-?xd8rbeV zAZ1p;*|EL6OWd|3ZmX4kr(?4%&s+QbKIwYpqKj))%V!Brt}Ev}9;)!7BUVy*h3Kib z>U_U;Hh7%isc>E>@?mz3W#TbimJSBt&vD--Ed9(L5W^v*^ELO{qJu4^=b|iE%`#lF zwCQV+oNHa^In9CGsX?KrsfZzZFnXqxh?xyLu% zQr=OxrOuOc=gh+|Kga)5D(#awG<`Qypk?)z&Wnz|8@Ff4opUWJ<5fCuD#KX5W3|Zk ziK5J{>k6gMoBIheY_s&;wC!!X9{0qd9S%1 zy>#cupDyR}2~7V#9+`LfxM}7;maCBmRG&Fc<^5VU-AHLe+3yWU8`DjMADidR=Dy>W zWiZpUM!I@6=f6j`?~{*Q+C0aB=eF6>2KH+A9nUoQGmi8#b8x-gTW^}}CU!|Rp}See z?;^()K0CAYn+v4h@10&G>3HDO&Y8|H?@W}u;k0S8@j;d*=DSvAoRV?rUXz!&xIRoU zx%?+8Vqt8G-~N}sO5O(hFMD>SWYxhJ3G3HNc(NUHeZ95aAz+KXz?J_8s#d>L7V?=l zf3eE7lOcN=*E77eTs{9LquEC8=ZqSgLjFBIAt-eEf?VQ>uI!7yrcFGRcKKb1U+}X$ zo{jw0SL>eI`fQvZ)G&9+)VbYfUY0E?$!9pI_J-Bqx~Y)EhQ1Hxp+1-IcsAVJ!e{m> zf4<-24TZ^M{lnJ|2FoP4LlrW%)iG|s zoZ}nEyx=>>pR-yfyR7D737>qukau7FvlVx`e#+fHdyM7xam%cqkD`kBBsUcZvXM#^xGx2LV>=_~KkC;~)vQh03cRsJ`ruU{osm_njf= zQ?JwJi>gcq7p~kT_D=nf{_(EKpE^qQwG#iEywAM7gViz7-7?L2g7><_wf0Po8+p!~ zzUE@;we5&tRCDG#d094p(zm`Q);)Q?PZ^r#tXkXlvT@ETruc-2kHWtT86B;A_la}t zT6x=2?6F4Zeajz8&~i^6dd*4eM7?=LROL3+hQl5~g>g zR=iQpk()W0N%)M69Xnf>N#2c_*Z!ULH+=kIPKgfZ1c9ZOB3`_UR@BRAnEY5sAmza8 zjJJQ2e_T#HWn29r;}nP42D|r_4I!^zI0|Jjd1ZDVxc4o6%2CY{x#e{k8z;UJK7Bpm z+Fs+Y+t)4?Vv6GZm$CM_=gh)89uW?zO@}|3DsQQ8=~S#<*u61AvO_}QLQJV|mg@Ht zD@7bW?Ee!w>p*)_(r>LpxO7A;+oamAHGY5 zT73(SmPp&|vf!)zzdQLy6kiKYo;uki<@CDPd0y|*-#Ys*edhM+>b>s;uQn#`yjith z&9RhmD$^H6ft2I_&pm$au;IHTqtgaW+XMR?J{+2TrQn#U0#}o~b(@;#Wmd5%)v5DJ z1dJZDUZ3Zpai2xw-_OOKmv43bUTJT=vvc2J^<<%CefLbVtG^3uvCGN(e&pnpy7YPj zb8$n)vi|c1j4un{HEtZ{u^N&Y?yOZAi)iyxWgF33+*S~qQm^pqLQ99ANIo1Xp35xJRVAh3>IQcr=kI9KR^ z8JD+dlef?OU7vL$j-2N#nN|J#?v=x;3uYX@b?AqcQ|YprhPo#w7I`iDG_jud$wr1n z3$`R5tGT-B((SFyMT-n>_IzAreezI)wnJLNNue4R{Z00z{W8xA8(9AQo;aI@)jz^}7n?KoI4g8~<@P$iSCy%b zv2oMl)9?4Go66TIJl)|gQZCfNae02CQvR$W*2aF_j<_#AIj?J`=k+*O?me-4TU*J` ztKH#0F8^t+_}$v{eCO6jE@#t^>0dg$!R%3!NrRM4nCgzj*D=tkVnmnf}aWo3Z8l#ze!9yV(s{W&W$wxET5LPn4W%dEsbFM6{>D z!7Q^SFXyTpUc$sav0?Ar;63e!wfUYtHP(M1Qm?aAe4gjs?&l}^J-!&oCbwiYK5Hqp zIM8umahqo3!A1G0ypsdjlr28puk)*1bvN_LvDt=^Yo2zOFx~ImnS6L=blwrW+~*f= z+mv%>%{#19^F$=|>4}R!o^cyAF&yN#^Wc22ls}ex^G1f#?+-e%Ih4mue`C8fyW>>M zena0sUrvT>wwJFJ;gwv=>loR{zW?ao@YfB+2JWk-Kl-Kil(&%~X>UlT;pY8^8d@$!=YmnUYVRrp;o=b{TxGr%NyqhO& z$a_iU#f9kn;Dq)LhMdn@J-w-mO_JACeObOz)4J+*>8H7@Sm!Avv)t%vN>X1b8X!pv&$b2v8&v;x8J<<+c}mMMcswP&$ncr zk#8={DYj?365+dCWzpJg%~~=)POtkh{~z}<@iTYK?@CR4w=iLIq3MnlwQo9m7?+#> zcpT05?kPXt%Me$ETXWxcJyr-m?CbFCG?x==^6V3@SHx$%*S#aOqWJI2+bqqsJ=IKJ zUXHn$ujQsUEH*e?p(MrO*H!j4K*5_;zagin%VC4>>=~112PsXi=QX~qp}F|W<16z| zw`}Gu<9>c8NaEnT>@)l#Hj*;!%Iu!6X2_WaO_X$7(r?%Hh>_X$+X-eBb46Oy{>vJBO^YAzk) zQ8;kMwoLrZ1yhT;@%FsI6}CKkO1r{?FYh|#uwX{sqYF=zPlgrn-E3t|X@8yD@;Ua% z+GA0NKmY&zpHaB)rPPF~i;FHW3CSs+DR%6dJ?YsR`P8+EH!_uDlQ&(;mwNk|^R8ck zy~3gG3J&Lj61TF;`>^KZ@+Qn%xaL)QEt|rP>d(0~kL>&wKij>xL#cUBv9{ri1FTn# zxf*9aS)n*Fxrb{F2U}Z&--p=4NVWXtozSe|p z=d!oA`Ob^7pV}9mcuKi$PgH5h`|$Pr8-4aXJLDEu`}5>O^FMFZ+unbOVSKrIkI3^6 zO8efP-e>;j_UkbDr_UnhFxkpCE?+hEUB$1b0W%`MAMSV0O}`g-j`#M-`Hee|#MTQs zT#$~s#HjRgZr;QRa~irnUwF@O@SJpYkoe`Czs_f>O4fYY^6*~S5{H5rku`Q*-C=Vr zuPq6&=G1cEp69!Dxtuqf#S-5qB76E;d$NKay}rn+pmFGV$~iy37Y)`izZ|~sKM>bo zN-xe}WLcYcaW*4Ml98IElzbj5!y=~WSB&4XR$qK^J8HA0iW2{r_`!A#>MM5c3AfQ|FV3go7`bRpRl8=vYk6V3i7RY{C<amIEv?t3huU+t2Q?+G<@LfA2?=Ro=gMJ=tH#o!K zXqT?CdtZ!Eb?uFt3{4H3=K~cwcK>Lqu=Q?QTlM4Qhv_nV-@XfpJN)$n@7uKt_h~o? z{GIf^Ml*$p!|gavgTnd$CJrAA7Ia#k`cY>sutb;P;68^5l@a?3-J?E!|G$%|$^3qs z8?Q&nxq4m>t_ACPIKqk&MD8DmdAUe_g&aDKL0W?;*pt2~KbKxw7(K zyC&|kro8mparWhocl{+Dd{rmzI(gYB+{xk79`zNX973MfJB!5=a*EHK%rOtV^W#nL z1Mlb!mE0oQ3MVRbSUKh?OvvJ3c{wA(kHIlAI5ynmb>zAt7KI3Ajy|E5Y148OK08jE zV>|WIa`~k^pCj6fV{B}kr!t*m|4?ez^Wbu}!wjy*qT?xhrZXRORjahK^PF%aYKHo{ zLg}9Y>kqDC6gX4Jy~qSx!3l=hx1Vni8$2Y0C=MemeY2ET`IwHMOF_fAa6-+8L58$6g;^u=_nz(;T(Fx`@&krk;fdatbcov8c)9*zm~oT3=D>OZM;w zDTRFXEw{VWzyG=O^g+`y3*-D%o8F)1{+O0?<(=WCBi|-He{i~ao5)Ame{wQS2juky zwgig_94el_Trbo4+#Uy2{=a1&#uFD`on~OM$yV^gVfWs5A=RHE1R9GiB9u#o{w<0$ zU!fDU*s9&Z;Q7x_rP0bl+jh%Lo@YE|{k6LZ3{81mMm20*S8nuJy=U^_=(Yd+>3#6) zwc?z;?F+36%~V$vNc^16$nw>=m%XI!ECbU_r5anQ8KuWK+u!@;d)Yd;%#J#u>R`Zd zuK0hSBu}x1T7lNSgKnEv?A#zTWqVNQmj;pLvb?{Yb*Fqb{r@a|iR(c_xy^C4y6YJ; zHlK)$@O27)UGTZkUsUu{TzGS;0oN%# zRz*+YRdc7`z5XIy`L-0ptIp-~6uioe{{`}Ij9^UMR5a(_zt0ADd)((s8|Xj!Fd@9K zao2+8y63#-&iLm~VTg;^|BwAg%)Z}d4j*!Bj51ztjAUxfke(R*xAIq1J-40Rr9?(W z3Et!D*B_hWpnFP9XTr&OUkxQyw|e)V4cXs2uhxBb%(mLayL*$Y>kVW7*#6{9Prs1z zU$wN;!`wdcpqmt<{I*kHCAkA4yEmk*o4I?H@095IM%CBko{Y15Kp zThycbPipMrDM(+)|8B#qkU5u7uR~zGnck$-ci}M zRJ8v4=aiGn*v=G%{9mFN756p2=#|E@X35^?|6;dpt}6TKA8l{La%T7W3?4Q=Vs_p8BVe^w2lcS!kySrh(bP$_H)J{pJ!yb>OK28iPF}%X~?{L&7%TFgNT~BqCy!#;d zO?1l3oAT2HMGmf1`R=o;XR50D$xkoinOIgT6}_7&ely+9)6z0(YFcAt?BO%Mb*|+Z zx1QD?-MQw_bE&1Zj~=!+37Xtkt&nA5`2Fm!jUu2$l~zf?-Yqqz}z0mX0RA%q*8DY0FzNXjz-M!_< zGw(pJ<>k+mp6QBNbsHR>x8~*vUc2ovQx+6gMN6r2mdO5}p}=D$WvXG7K*CvthZ*J=E_(0wPVuI(bV;va-eIw?JEuKfyz{cF z$4)M*srP5R6#Mu!=j^#<`u~pW2hFaW%AjDmtg!a-p}&qUCK<)@V(tPjB1#x7#rUt= z7ySvFv%B+|%za-kS)X;RZ&$u`X?XmG`_BWx*r>mJx(4&YawTkJ|D9U=Ut}&ZHcJ=|CZj~ zs*69`OFB#V54H(~xLC{BoO%Ccet*8zk0YtaALxta+?>7q?oJ=JwHLQqh zrt6<$XVNR)E%;t+@wH#>kE8G5S{pvNVhv)-NNnm5Ncy`D9&c*?C0`upa*x>LTj zuhFR_`Al}otWP@MHfC6^zx^$g<xTFuwj3B zyo;*j#OtqKX++6>WfXW5!^V>RLwM!h*$tMvXYa{3usr%DBx)zKvCuvXRUf`<2P7Q6 zA5avC;Zf*_=Pzad9kZJ`x$xQa^GmMHo4)YKNA;Zy7K{NLIzDCGCEN+Y$4i1|yLI2* z$9(Ngo`Z_J z@cPPn{bqpjTUVguOm7@ypTu|BYs(*%X{q^1ou_pz>n*f@4}5w@+&; zL@e%qVtTis`ZcH6j)_(bR{&?7s zAn0IVZoqvYCMU^x_Pse_HjEvOwHvnOZWpjxbb6Pj;S4VA%P+q${EU^G-gkPIt;m+? z_dat@UVdG*qRY5NUPD3Mi}BE$6a)5yR)>4G_9d9vR_nzs_ zwY`Y{`u6&gpT!yo{w9CCmyZ zX60_KyW8*dvUA$zWvop<=0z)JTRIdxGJF^67NB5p>X%y^|I=q5zCT!f|Htdw4GF5g zT9%7+5*rp9{z?`1>rs_)-uYcMKzIqS|A$b87wNht50ifg{ywnPDrUKA^~BFwW2XFC$_>Y9BxwNQG= z+T3Z%t9p3cj-PcoFgv7>Ty0L4Q(>?u7oQ%_xn6nP6Je#qi zi&e-z*lS&JhT7b}=}g=oGL4#6ter1)znhUQLvq6#gT4a-S8q;vWqyB(RKGokN2K#C zaTD7uUg5d_c^oD6gUzSAUaos+*>Ymzl|zyHTKQw5o~#q(d8DG=#`lWx(VT!g9coIe zmzw15R}S(vDa%psJ@a*jo8iyGUXA#}ESF@o)J4B9S;@CyPJ;5Kh0ZU}>}J1|X}0{2 z`F_PyZ+TW)eJFkN-~%`F6xS^+Np0DJD}y);Zr)MbmOO9Pyhn`69tv$Qt%}ZEQhOR^ zaC3)_)6O^i%Xaj-FF5s}Qty5c!x2IG^zY0jBDa1ENYu_)biN}+=U$cZ(17jJb>-E`MKae&5T_((Bg4%f?mWsoy<(r%aC6)5Z5R?59_VT&Mo$!@r*uFmJDa zl)l4Q!=S?A=Ud~tT6yIgH>)iq90Sjr8#cLV_dSToQz^G>l$2k(Lg7KilwEty&9-_| zsxDz1b?`6emJEf2ww?UOp#ePil+%6{@I0P+kUy^b`y*!qRu((gpZ4djs`5@*8N6r` z@2Qw$5n@X?wCq(AEiA8pVUAVVpUmI3=Jb8bzmK@K`K@=au(-haP3)7=9WEZ9St~YQ z+QVNHrY>L0^MTj6FX_th@~aFJT_n{d?^wtyTrmkc*Sd68+kRP&MKO>f&uH}SF>Qnh6+g+_#nqJBNx-P{kxvcbB zf1Xn3oD|mY#(bx5?*D7{%(kwX;ht2nUhG-I*30ncJ(l9!XQj{SU3(Pj zHep}NygGGd3l6c9G7P_bvz;v26xccXX86b{M8t15>^;a~Hudcf&Swn;Q*W8Avwb`H zN28F)m18b@9H#Q#l|ALWIVZ_u?KdS$&CnB!b_@qML>ZazM6QXweavfhj33MN3BrqC zb5u16=KTHg-YGG9XR>y&+;-uV`E~32^x_vUb=kVw<{-zs_C)>uGfU*2J(M@fis<&5 zKdGyG{+y00TAdzGxzF27w^FxL5(`I{r_w$-~W}m|kc6+bi{rs5v>N1{r$Mj?O zC*9ul=ji+Db#K1SnjUMu&nUy+X8#-8zZG96Z{xL-F;AcIddoxZcbYy7GKEP_KPFi` z3;O-@w>vM(U9M*@<^-x$9!$G*vz{U9|KS@4e&;i?_!=|qzMyt}!PEOy@8&Tptk|4- z^=X;XTtBJKIVYCnNZHR@8{KRe<$U%=lI%-~vipq}L>f2G-N=~PG)dSnJYwI8XRZeB zKUb$Op7Blm|CiGt34NCZD<)peIkIW~TP2=30d4dB56v-MF)`x4uU7YR`PSZ;vrYF} z431AZ8S(wxIl;d^s~B(H|7RO&+$X=Vh;5ci-?6{l9K2#CUMiE@JWtg=aopZ`b;n+* zeIjYQ&G$#tW@$0JEmBrtwA(s6PnDN(;_3}*ZMV36n8QjK8W`5Ph_-)Wd|7^?xUB5{ zZ_WB=KQ)BvCPsDL*>Rb7;qf^v503SymMAf(Ib55De zpU)o_B5Ubvra90rOLXz zI{{B?PS4M~@I`Y&^T(E{O0Uk}n(G!3&mNqtKXR?Y z<|u@7UJ5z?{r?n)4FQ4@EZsdeF8{oy?3ekLC-O~=Pb}xV$WQ&5$+4gM;%dIH?U)o- z^Y`l%`5C-r7j|vowOc;v;js&jY!ClQC7t>COzKs(+A;PWCo6wPZ)f<&5tH!O|BiD4 z_PI>9;fdZP_Z9o^X|0O+KIU`9I%Fi}EyS)_q#QlkCNN-sH!p0I^TMg*raV-QBS<;mb^SrbFx2 zFXXYf_wW$&gAMIBCQk6*bK>_|yNj>>$jOB_D#)6gTBh*!?p#Y5Pit`onolOtc}Xd3K{IjkI4sbh^iJVi z{;u6u$Zd4?-m?X>j!k!%(E4?+gMgU87HtiWh68qXN%IvQPM0TESDx9sbAHrj1Fei( zrz178{G?7liuY%8yIW0&*)Hm*ef8zDPLTDLavJP^LVVD*de+IcLk7v=I9%>0GxuY1J$B=6F`Vs51W@p_hz|I&}_@;<$5 zmrOWVzm?ge$j@pvGl$jxc83YOcO@xwte+lu_#nrn3HBzu!mYg0*K7W4OkiQ=cx0|7 zAY=Srx^}JGO?&5nn>#N*)URl~)TUMaS%2T8ERE#aqAIKPQX9059va-9p{CRF?G& z97guc98%A+_H&+UbC{6wYpbb7?U(NsJqfaxH}oVV7v9YSqPaeuz z-&g*#Cqb`6G=KJAC-d2S)lHepV%|?@KIk{U*1muv?5Lg5uT9y1Rx~cCU7lGXGGTdU zv0(74L!4fF&zxJf<@?W!AG|Rj12*%SPEpR$) zjjv=~9&65tRmU~H?QQ&%{N09Sb@NLO-h)n$taf-Gn)!ZB%B0m7x6fzh5E3l?6~5p1 z>*DsvjST+lwj5aSsh7jgkYf>B_l}&~=S-Ng&5EweYSw=;+%i|xKqACG;I~7n{zulF zhxscaw{gG7TuLA!Lp2F)J~O(* z?v}H6AHNgazoaEUBvN_O1kSkU-bPB2Q~kYO&6~!t=wJ2wWuJd=oMUA3y$~y;u#w~F zd#7IJ3z>eaEG``LDVz0}dF!8rzb|W?yXgB%Z~ieCMuoSJZwGdoTyvGLU*f=1H@TNP zb6Mo-*6&v5845F+l@$Mf-YMjE;fjJ}t{0b&w)dM_`DuLhtDGA)@^@;rPK|DuIM=~y z*K$^YC;LP+d{=F~viw8vot>&*|9#uPOl{f2Y=gNfH?G@#zn@xo`rNH{#n``Z<$d^E z%>M7n{8&6^ry=w9^!_C>#eJR2#P3z;o|S%h@-?f}`uKuiafc(v&OCefu)@WQMW)${8iuKFUoq=^DSf?J@5s_->+WY&d}l>{BJLGb|C;8! zu;S)JQ{xi8#5q$dt#SftnQD1noqFT{Z`!+W{~kNAnOoRi*1L7~`eNC2k^Bd16nArR z3+?>6LMVhG>3QA^Ki|)pOnYXV2l=uDWZyhtmaQChHg%R(;Gd^yN0vO;XrgdKamI@7 zpd|v&cot4DT*@$Qjpnl%JqeGC+ysi(=7}V4GruFW!*c4XZ?1naNx$#zk*UmVUbj63a;q$i zXG)z}thH98w>Y2U!I9uu0qVSw%{%Aat&IOs-_K|_yZq6)Cwp%1(G8k-Qm$-Ix9X!0UI;HJ6f40=QB-_p90vXBzXE+b+{P3rHV$$0~*1v<=isrwZbZ}0Y@9w%o z>C?Zi*uUf7Hm&ky-%p*~pePXYO`_*PGXJDYTnam~-5CzfIv6yaQOU3PCC7uK@$r@O z^Hd%eG3*!mbhyMwwWZ0?Vb_Y18{EcczU*?eJXfou_~p*h;<%HOy{~^g+z^u9E!OSv zaPgXem7nu(pZ(F}AxZF0VY@PXr_x^4!7JX^X z<0f-f-nCh>*N|ENLG+f6`0%EqhPO7{sppvX;jhFKxfT0QKPpXdlgMbBSue_`!H~$> zttWqc&!)oUQ_IYjhuSwDJa~LXS^u->BGZkYMQjWT!lDKb|{Dr_}d;1ZlVyGSE%-KNsh<#!#NZr^3mW4It!JtL@iilC7Y56hDj&9C|` zC*K@8GF5)h{9Ek|P3?S2Yfer)@wMuj-m^RR+*4M#FIcUrw;|g6)e{X7jzW3W1?qyH z+x|HIVNGN^E?2MBkJDNQbuVYV>jrfl7_u_cx}xc^tW0zOYYlBDblb#KcFV0QY zI%d{+xqFL324haYP-fVDwhr^{x6c1BeyZGYQ%BLlG`#%cuIy%4DTfQMs|s=>^-mut zy^xW*YE8H~h` zJ!ifgaWmtM*nUm-#{;33rTHsr<+fH7{?*tye+SEKt-F0bPx%7gb$Q5tUe40A!fbV? zRNWOr^^V7iGk8QMGA+2aM9RtK_o1|u84V{?cm?M9i}wWzaxN_r{J(Jv|4r9-M~()& z2mcq2F*ewG^~1@Mx!g>8>`kvy_vJlpl=7Kaw2b{lY~}gdl{@Ffl(@~@4m%5AX}O># zfAG|Y))5!fIXXiYRfOzxl}xgFq9u^B)o}SfevVh0wE~Ju-MCg1o?!m9SyA8!ugm2R zH-x7%9!&i)gPSGvTI#$4$yZE0YjlExN)~Jv-(U8m`t^s0Cgl$pyoB-uYnC03Qw=cK zzC66xFhp~!MSK0F8&Wz2%wn37JUhDnGRJ?r$gZfLar}wz?%>X^>RpN()?dA$oPFYS z@o#?qCRe`y3+$SjRIrkkZr@kg5K%uuJesT<8YwHAV4^RddoSVwh6CJpRD()5rcr@x7~;j{I8||Bfki zCC`VL6#g@ef1=b>?w3dk^60%SXj$cKAV2+iJHrJt%f3y$hd-JIguXud;@ip)p^__y zvo0QvN_jdfu=b5?^}cpx-h;+-rr*x|vcKwnVVvFP#XMpgS6@|E;Htk|z7VrQIKcKOKVdiM`3S49{aa~U${ z%Bm(aZ_9FSf3el9uA`RW{Go%AEth#_U!48$$o*^eiXl@#qE+uZ(wx#9l7NSQS&)tu~B@$sGbx$?4r`>gx7Gj@f>KmYPo>7cez#ABT` zx3=kCnQ(8OTiw6;N;}^_S=P(5r$=B}RhzwpqqX6>*FFhu0iOdE9$AzKuyMWPJ77Jz z*S69ow&LN8WGN&7R#63-vi9nI5wv5fmKEx+1?*mT&iv!15u`o?` zlkc55aW!x6n*9GKcPWJD(s7=~1%i)ijtA8^E9^MI9VYhCE~G>x=AP3svs2kdH!oVh zn_?quQ~Bd|+KpBDR&7l`wBLUWZ4PZd_(-W%V9!n!R%PE6y0@QQEEayyU#9FYtb5I3 z{zTU`apwziANZQ@=zN;^&ty{2w$ho&=a${r`*mB#k~N?A^e32BU4F&$F!=aZ6W!|S zycN0*|2;ULxLHPYW&YSL=_rwYAmZ^vE{<9IFR8p<*1vM&%2YS&OY@pe-fRE+(zxyO z{J9Fg=Q0<0-S?gQop0H_lap6gKiIpa;)%$=CT@%0kF`(d{=N_+cZ&b-OA9L{w}@-9 zd!+O<4f;tcX3zj|7u>`@;o^G{_d5oS~FdR zuATpAlm3UhW~=xLy`{&J{yD4{y`Fs0`B_-KVcNS$F^dxgrW5wQ&vCz5|7GKqJ3BOE zi|;e9^sg4m6Oz4IG(~rD$@#tf0ycKSS7+8;NDySQU~Q6Jqsgf-gPG+yLz8a91Ic&B z50x_x%xzjTNo}gDyTA)xqp5--U#2_s-|5jRnjEr9$~ddyF`Lg}>kk}`oFW>vhYNSU z*(syJHHD>d*|gV_P8)CuZaDW$qPg!! zd2exX{r~;?hTEr{>pNfcc~&(u$1O&l0_pji_!12EvJ0p@Sk!EPsL4kvV}GwgF0aHv zL$;ecpBziE(&FPmosuhCUPk>hF)^vj+gd%(4zPUBF=l1%CyjGvz+Pq$6Vo%o@*W)$8X$z09PrjL39u~MnrDomT+VCsg zZ<3vO6iyUmiUTT0RHTS~KBAt(WO(!dn@>(yug*c&UyCKx z?0nZYgxy$w?o?{#)5YaWpM86q`Skw3zpCkv^y*Z28x^`YmNs2s+c2{`W;J_8o~)hF zvkPAo*JwGcNO`{UkIIY-KF+VXv|E&vE~@O!NT2L)JJD@>Aa}8?UFEMSjxWm%op<`M zYD-*=lHmuxguzSho%)PtBpM6sPQ)1_L z_Hsjt*fl1P)d`8NTV#2{#6O3-T{!!qO|zzCn}BXt{tah)W|1{)ON2sCs=aJ_$zUa= zV{)*6;c_e99S75{RG(qxToiP+JZ5nY;}5Gi(k26gDFE( z;2D{+V1*NAhfOUu_fM$oW9YXx6qq9T#4B@QSmQ?^S!;`ZM^O zNrP;U19Ps`eTEZ;?$6AGwBFD1D}Cm$Pgb>i!E~wO4Nu>l+$l2WYl7kr?u47|58q#U zUaTQIS=Gnt`z8^E8+B8ICiSfUeDYxjN1a~i%(njm9DRqUUC#(^KXFc|IDo&^HTB}p zXp83zpLQwfoOu+%uN}WhZ}$5=Q_t-!@0e3OsN&1gXlh1rQ;!Y(#~4SX_bXHDttb?@xb*z(VsaswZCu@ z_M7!(PN@7Z7v9qw+^&4M-jMKvy0KtH)i^`Pv?p0W!T%}u;bI=zblW%ZS7#q ze%HHKV~2WhpY<7;YaEW;6BK8te08Y3@uk01?z!Fey?YE9C9ce=IQGCIM$qj;>)yUg z(^`EjKI=|QzO-N+6JzzmX6KU~5AX5EWbg1gb3V?-`1GDu!Im>SK0NZy6#P&srtre% zdhMwM!EKvn?B`wf&SBTle~a|j_aq!L(NVTIxwkjjakZxNN5P(iiA$Lr!?H5($0hu? zC^U-My~|)z@p|DEUw=N&WR(BFbUKMofSq%R*^!2yP18#h_}ki7UP#(w;Tk?a;oWta zo$svQar4gjS@e6|loj{3ymS0CH*dZl>$MZ#x~@j>DwLkkVLX1|&P0WT>5Hs?yb5(I zxN-1b-#Nw$S6?Jtjw-oOVZ~xsqNikXznQn@v#i&-y_28C|E_)I^u0{{y!%R>_EMK) zdgl)Add6yQ-KcQKL(6dC7e-#~x}y43ntNEAf`1%3cxy)7Vm1Mv&o^Fw49=FF*Xf@B z-+E0pq;iQ+G38rM(%-h6)M z#f=O-Q~B>tbYo~b{ZIR1YVhUI4J>COeZSmLlsy;t?lH%A!{+xKTPHrSnbfceU)9FJrLgnc04Ec_|;xx7$6B{gS#G?Q!V#!JYf+8mA~P zSZF4l{M6%oVuTKlx< z2)J`vf=^EwL15u$5cN zAdq@$&J4DQ)HTx0JBwzlV^Iz|@Th;X_xe7iN&XKl&i~P$(R|>q8&H38!a+ypZQ)*K5y=k_?%}F z2lG_C>pyQT`6fF>phzQ4zTQuMb6mnK>xG;l$;tOD-Orn9-hS}sC5PXRyu|o73A_wk zJTlRh@9%~xT>sUpvDHoPl%9e9w*y7Ns|rE4LWE{Z)IV>XvFA+sxxA(_^*LgKwG$5W z{I}paEA0Q!eXr%!$lrmc><&SP9{q~U<6X@hG*$ha^krR3fm4lg4_YJps=4MTKYlA~ z?>Tj9dhqWjo<(mKhRDx7IKMBZYf5#9rg4EssP;3p=c^RgHy)aCVx_3Rl&J4LUXisQ zrSlmza=aun7Zt^@8r{0=va?wB_#creg|W=1{>@nN@Dq$0WDfz4{ zZ{6R|OuHcS`fz%LO_i~G5O?DLY&u-#_BJ|C ztNp9P{J!78WvbsE+EqG6pIO-@ILA{wz9KO}s;*sT_mYz2_l5VuORpCC7WT-<9*bJ! zsGzY>z(L^WULS=Y8V&+(0SYrL>!)7y>#}%r_tj1#JE_Ck2ls`_KX@Z5@Ftewio7kK zz>!TQ4BJkG5coSrDYet|FSTe{PF7LwX1g>NnPHvId+#${mXYHFBkkhym->% zQ0ZNF;x&5z$o=9F>xpLK5KCyvmQ((&f5fZyv`7kh6NANE(UCVc+XJ@NDke>uAn#_M9z zOtbltpMQ9nFT7|f^&RG%!uaP`hsQ{COI zoV)@Zz6Wm}uI=ckYA`t)uB*1xPKEooz0c?Uzr^2lXWZ-eFsTiExWXZE)2G|}ILcbp zyEM6k1UniR8_a%QTK-Vy{MSqWf7vgedi}mwPb7QWskc`%R+b3x@@`0#-0HgM=CcHu z=NG)(?G$fuAH2Z0gI7UV&E2jAQDmIXlhoD>yv9y5+~O)hjC|d&y6^A02ZoabhVB2A+8Yxh7LMktzhxP8!@K}qQ`Sx8q@=V3&Nbh@Q**MG4UaDrf zo6&2&z&q*j6`DRWu?~rK9U|5<%FiTb#(xutvs-oO{haBV2aM7#7TYr%+)}EXS$g8* zj_#dXruJt2=FQ}lZo8UobV`F&MC!!kg`5roOMb=$n{E~OdB!1K?ED3{ z_D@{@caZ?QaE;LatDe^#GmYfbuzSDfTeHl^DW5Zbon=VQQwv-_^ZVZUR)6nuIvh@a zaekuAfg^6$Qh8E0ohh`~^!wQqMz+tg)`#Wwj{BH2#lN{BQMdBP$)&yqiZ$Q6`VZ=D z6H%y8UG~tMb17q!a&*Tk^}WGS&a<@442ylU`uhGoxMwOGxpi6Z`=IZ}*Y2GZUitBN z`sJ6`IV29B3V85hzWyPRKaA!+T>&Y-JCIc@?C>( zvSw~`wX-#1gze1~G-ftL`z>SgozD=?A;#FD!0jHs_zC|fjy^lb+K;nWe=*!y+mn=W zDew2C!{Q&u=O6y&`NyeWn5R6!>?+?|@1qZEUnlHgy_T1P(kVlop{6YKYO=VKOohE)iuYP=%l682?^}O9h3Nw-~o_e<8n`=VP z)3DQrH?REu=Y5d)vEp}c&6RHW#V@crbZpkw3hSbL0n0b{V}BjpDV8%U;rs&Uh6ktG z<$X`jC^l;1EMFp59nF7p>h&ChYBlbYEU&LRF6X&c;`}o&zHrLB<2zzFU3Rpw8Jb-E^pqJYZZnE5X6*}jQ1LaKSm4yW-(Pu{bUSEoVy^pAL3PL3l@TkE){H;H!D^Zu4iN#FM@cH7le z`+m;7f2Oi9E$+;h9o2WX-8MU^7OBuAAf%C}szi^>T>Er@4*QdVkU%k1Yr>!|>$4U1L1=sA)-$It3a>HZ7TaS4Kh8}X-w#(_aiQr*|154-sSNYn%f9j>3#s=Ixx0qPossE9a==W!G zT;M(92-l}WYY%@{aK9V#?`iz9^>0+wl_t$m^C}klx^p_;vj=9+KJ$e}a(&X@rdXzy zy>9cw(siaAoSdFWm`mIj<8kxcouVVuW3fNGeAnB~{N=ySm~ou{HDk8)-^a@egryAx z1bSabMsIAX(AcWG_ft_+4R8GR>v5i?CakQb4X4f06=g%&&wufam%41;bJw*?LTg3O zWadqcmGO%%vaiYV%6X*CeEoA#;lG0QVY7oyJzkjU+d1u9!s(9_nVLE4*0NgHH>6zC z-`7&l$@1>4a>$+^7Q7P6rNU~C#~9JjhzS!Sz5iys#_3YYh27}!} zxzF#FoUX0D$d)7*wwiU}vqy}4P1ir@x&Iap+I7YKtXt2d2c6UJuuuOpndxAgqpd(h z@i|f9Wl@PT5}Q}>znRr{aPo_lzK`cVR@?fRV{OQuNB#1K2iDEkSnSf?T=-F)Ib>P} z^BUGT=L&AF)9?3)w?};rzjD3j`i#9V`p;~0bCuf~^Vm50@+^0GwOJEBrtI7O!{g5LMy*%B;{3mdi1w%Es_V6iXP{mD<6fV2x5>8k%6a_^b8$SK-0)VndgbqV@;@Hb0= ztknd&H2<=Sxrw4L;{S2D|2~~5Cq9GW`kY%1lS=JgF*veLYgubUhJQIq zO+TbB7+oqf@$9@h=cd%(7s*BMWtuGK&-4xdfBnC0X}^rBH=~{gpJKJ+^=V<#zaHP} zC6UDYEcNKjRD~0De|QvTyj;b^QPQmua&%jQjPKH?yEP&`v(_AJ|FLbpy2FQDhnpA8 zFS#;Z@@itueqTRDjYajt8a)$-ZzJdBm^m`W}!I6isv%8F+vLj)prHWb89Smo2ZAn);)SsNKHH162) zspU5FcX0=S#FhJ>UAy40?udKAujqcq%jQcC&b=+z^U#^&yXk=i*>+8D+8hkNG1MG6 z7_>oV(kFo;?q8u!o2xf()--%qyQaNc|G{H_k?qSKGIdYpnl$mk=>m4&qCNJUEE9cY zHTLsWE!E#TdkI?tzpmc??+?N%LVjQBZ(4mr{r_bT;n$(r|BVDn*4SNNDEP$OLExCk zg9cRwfivgkdFK9Mw!ZN%)bn-A-JcB&9AYc@cB|dsVLLz7`Lew5sg#d44Ux0+^RLF$ z$iN@lLeOl%y`8T`rb#$`(8LS`TT?Z-@<0({$6q5tMeRXCe6e30r%UjX74@j zCI5i^f>OXj&RhBC7&P8HMz^-yd$O5xOPJtObCxEf^9)Vvgu>z~L%&)ryDjVzYx^^J ziRGVfJGQ?&{<%aZsb5WZ(ZwD82Ae~_%-Y;}qE&HL^xJ8FGv;5&__qIZY=go})(_iH zY|lCB-dUZx#)@feINvf?x#s3}hMD0ETN@nAdd|41KNl1TQIKTT$S!-GKil)>xw#An zV>9n2_p86=NuQCC_w2w4x#%NC-fTP-`l^+eyZAY$H8$ulu}qI+zcATj*SBlg7C)s9 z9Q3vFlljueb|cHKQttTv=g}**IOQ6P}`KQ#e=jdI=_9~t@>Mp;m@)M_C!0QP2$3ndeIum{iY(2(g>$o(G@!+bruN@|Q z_FiWn(XUxM>rY#>0ek*(F-^~9*KH2eB-jNN&lG&{IAezCJh4Xs(ZaVJj=B2wTyZ|} zrIpdq=WFNAttOH6ybI)<)^zUoYFfg_q99(~YNycfku56XZ0ngki#?&wlkFsfj&1RJ zan80t{-=_H{D$BOddu8asW{f&QBJqKCn>$Tes0J0;A)9QK?aj$nEC~_5j9-3 zA#G~@e#vuRnGQ1Yy?y%I;2Qr)%l72o3<(b^u7BVzi~S+9^ZXsrj4+-ff(lbOa(zu! z>K<6IGUb)Uee?Ib?R)Q+iWm2)i)d=^%HKEb)Mkc*|G5N?q_6EheVT(~m;9_ZmZnk4 z3O6Fyn%=M+`)k~gz$eghd$;cm_D|yTB#*y#5QyJ$@T%pR3ns(>1uuSDw7i`Me%w2I>@RRTX`{sA4zc-pOuv}-Dr*?s< zKXK}-eeQj?B0qB^85%2aD%?26zq@`VQ&ZMbcLxJ?&HpS?2S0wyY{@hUEx+I5w&C)z zpiM1FF1-qSSQKtlf6{Dt@biPa?z43*Qx^%fh@>pIzb-tJ^^3zj87X~-yw0sEheh^& zn%%!N^IL85Ww!*4x9zmvP?YAnWxC?}fWFR8~8k z_^+MQ$luu`U|_McI6F(h)Ayaqt9NpfR3;ydogBiOnb@%T^_~6ycqVfl6m7q7N%7^B zA76BpRwm!=yl2AOx8SXZzC+($wT6`&v&+4{-w~eJ=j-t7MwE)%fvC>?6EY(g34d{Y zBzW9rXYaZB>7VEMefIw^JxS&aL(|>b>2vA@1eLp;!_W3VWsmsxXx^H~tLBIDXJ(3) zYWkMUvj4-8`gz6f?wyPJtgIfs&)D)(Na)rdZ~f)1@%!goTAjb>VH4-Z&fB#eA%Bu3 zz0YKv_ci}Gb?e0SYuH|#DtqH$sxm9oV1~@2$qX~iix+q--p}k4ol|#UXHZgOd;oj= zLMHWO#;o7EO0WC&OwDRYXpYv>H2Nl4%y-%Okr>Cb45sLe4yhS!$KT%--?`N&Zu)A) zE{0iZk7aHto#TwxQlGn;yNJ1Q1H&U>vz_}dzdp~KlM?3_@3mzK_pi?v<_iVfuq z?>d*hyU$3n^DDhp*k-??I_!hCv#`%^w;Icn_x{b0%8qTWF{td#pX)jK&C;*;m0j5n zEc5*GcT#3z#O!;LY(8!t_q{wn_{zky3AiX+G_hgekoux@qRl15+;_h2{TFv;NSkbY zf4BYU($6nn6`EM=$SS$-5?#V}y17Z=(TQtnBgIl{Qrz&wm!bJoW$E{SUIt97%20eBR9} zb~)?#{7#118pSPo%#JNnr5T#Sdbt!%NNC+Tk<4QKYwgat%I!-X8#!EG-m>|Z^~}R| z*1hVv2P_;BBR9MeP4~I! zrss_v9Dn1a9WF?H3wBnRv0`cL{0DLyw_Mp7|1)IA69tYq`*qxt?*)8anWxXSkdcLR z!W-=z!Hst-e_jnqT9z+=Jf=?c9+$wGi*F` z5OrPM+H=Xuhg+ANi7srju?b~uW}H_S!u&#y`JlZJht*HkWjYb+$)}E`%u8xs`Brg$ z!gSv&2cPZ#a)>*$wd1nIvq!g66Th>$grp}fU(S5Is41zgu+PXad;XsQ-kJweKh%8k zj^2NK@UO}ym&acOcK&D4$yoiY?#JUTE)34n>i1iY+*5Db$(wrp#LBYlp6^~yvKAlP zzl(p_*8a04c2jPj)>+NDMROv4_# zw{m7qJaMG5X!_axU%b5Tbi1fO-}QNkRHxxWTPx0oi&7iTT>?)ab-|HklNn2t* zC*}SZZo?by@-ulBS#L{jYnT)IL;Ib|B$2b+e_!@zTe&Pg;(YSl&9GNbLiob@j<6qk z#cm?|cGZ_pTes)zJ2-1%n#HGbeTE-~XTLMn@8xFsw8GX^W5%weN21r1pNl#xWH|fE z)wnF?koeK`>dzcuiAzVO7ryC>y>kAK)j_`3LI2B&J}kU&$dtn*VD(weHQF&+3zq#_Gv(P& z#?F*gc9OeqxY}4RGF)f((^7h~!v`(JX>1Hj%?n*EYWrT?;MSD2ZM`qeIazUDY)$r; z`Ij86Upu)-TJyZj+;>c_!SL&{kB6N$-%Z-P_V2mvS_&2K|9udg^7CnruCdH@bAcDj z`t%t&vIGS<(zYLnFwB0+!@_$BUH|MmXA>Q^#s9P=z5PU_vbCES$dSgJzBXS*g-mfA)I5tU~* zOf@+tud86W5m4Mvv@j)~=bYe{#`m|5XQb-7hc8a5;_ZKG#;C3yJMC_qk{cU(R8*6TjC4%=lz(dz;IWH z!)&_mVZQUvZ50~)!V0`4Cs#9gwsm^W@V~N1GUKA%f?MKS>L-1#F+1=kvi-oJyyQuB z(j1SjbZh#Y_1!0TR&vspCu&}-wl0=Cd^0{M%=49)E&ch{|F7#^RQ9t8*tA^MoO$x5 zi>yzjs&sskjo6XNy`B57S_oALFT1+q`|6c0$}7UwIo^I;`sa|s1Gdr`uRQ~lR`2Iy zNnNnw{o#|}TA%NbZ&ZkCOjc)9E?% zwxE#xdyD)M$t&UsXSmrJni_7ooRaRkIjpzSGYGH7ExI3SuOniZu_;2 z>`nVVwA^xh=gE8NtW5D?%Z$R)ymJ;`Ehsxb$D4b`!H}!dXXyGkUbwt*daw4aa(UN% zCdV>aSafGkXIP#*qFTO$CZoyXuWg(vR zk9EC0iaM5jZRP&s@#_aWUjg$4{|(i?3KrAV);pcBy#C-+0s98ubK)FcvwSvRN{?OW zr}#;9nN4%ELDWIf`>vCBeY|!h{4$S&xp>m$3RC@a|08Z)w3lqSa^~v6X4QA!?|k+B z$}m_o`0B0gB8mCZSOQI7wEa(7|UAJ(Re(pTpL~4ZLZk>7U0Ct#DiH}la8Vry&PI36&m+w$FR zijb!3FLC{)r~m)`e`J!=S2>@<>uj%2uU3v{Yx>bzFQ?EU&{ZJrP_RSdrqlI)hNe&2 z74Dt;zcn;$v3vF)`$uzBnV049+&DW`Dn@IB!*7?Wd7B&TTJj$O`7hD z>GSULB^-L2@=2P1*)=w;HxrKRJ0Q37aUB;NjozmZ<3b?(h)|i}o4WR= zdJPI(?RH`F>>2~_9?oagc=KtO{qlZ=TIZ8fp8rsI=Hg$x?`_q>11%4F4t#raRl}P5 zf$nopPv!;hC$pVeu)gEhyHN44#THgg+xQz7m@H5{5y#fF_~B2R^FGG27exJIaNJR# z(&px*Wx)77puGH^Yj*L3CA$nhn63KoP4JJR&#lT_K`~*me;&6L<4aHZJX!tigv+!{ zRp|sK_t&@0mL9uq$e+JYx7Yrc=^4KqlO-Ru|9=VoBl{u#u*n?Vfd1*PPf3TWhf6t1 z$VYYY*w6XczJJ;=IfaJC;|vB7%_~iBq^NzmD!JQRp@HYX=akJ851-@pUH-*+^MCL4 z5B1B1dJjk*(6Lj=Viv!Vuq>S8zt#G)Ri8a4Pdszbi_3S(p%b!Y$9=Ny)wze*NZj74 zy_I2?8f)B<7Q5x|rH>vE77QsB+qf)BS=iR(;=%LIuholjj1VO(yFEX$F6qR@^-kzyYe|4 zJGC!UDNs2>p>64ttcLx+tbB|tgw%ahBYES6_MK zY&PV0vutf<&g(vtpKsYY?nKUK`@YyvZIw;?k87S;b|Ptu<(J*vpu1P>@9*VoO{xl~ z=1dCMyJbh8VT(a;;NP^P^}nRA{mVUhDYPl#cYx;(K7m^trp*io=NuJlrcwdI5pSO|XTI~jq`2_vt4Z4wlkL-fM2aytZIG}xz0H%vaM08A%NcXu z&F&2TKdem6Cg^{d$bKZzgBGzq;?j%2zXs^M3p=YIxwYRPfBjBmE5v zQpH%=jM!K6dpetln|(34*<|g(pw_vL?>|VVy`Ab3KfC6~HusNeWCy+5K3GP~U~ zXFo9JFe(f`y!XK7NQWD!0xhqrq?J8|sD&J&iGjxTFSEVp08X288pJTOq+ z?cS1a((H?mB_HBnd(fpiO{Zp^u71vr2`OqhckHAO>io%DaE!V9amDJ)8CtS`)XwTI zIc;A#NuljQZ5{*AX*rF`qqa$sUP`(ec#^Ti@;Hf6FiBXg1^L zj;NRrhKmOs7yaW@h_KxMS(ZEBp#43^k$uHKdbgN#?~E3H*|=)g(W}Dghw9xGGBz|x zA5wLXd!Qi1q+*)#EM7WC?ZeZu8f}AzesAtgkBUEN-YdK5!?%kj=OuJsz2=ArTbvc( zaQ)aK-P_MhcW+D3344@r&t>w4M-TIt)LhP;vQc?1d-CLiTY4Vtn#t^(_+|RrHhrF- zM=q?<+gByj5uVfa6b9T1ZU$b zCb8WiY>#H|ocZ#@@VN*(0l2z$LRrn_bB%B1h_wtTYxA3LM- zxWcZbQf%u~1$Y{sm#X&hOmdj|^!SaB$M5r8?>!&-MW*;j#p~%S!%X*9YMkAeUQ-hP z!?bhf$>Sa~4+nY9+ADq4&EfmGeDBFs4)w=Go8H{o+Hy@q>YLO-bJG|-sTrL`KI?Q_ zgf+CA5AEIIp8xEJP{V?#YX-cJm0#QomtOGq+R_(QZx-5pi)V1WHd#kEd%@AmDICr( z<7TL4@ED8T+U2wGtqkA4j0x*B-yG`Mm1^yKVcM4E85w3&CQ?WKi_FOw@YsK58i7Vl606I zGy0VON;()E5BIl9naZL3;c2j;<^|^OlT)Vp9=);Y)J=QS7oL8iGrt|>X6a5?b!2Pi zyQ$4PPVaGN75c$5Z7q-d_d_O57nwe5?=M=Hx%lC~l5>?`9$GX1@Xv44^8T^w`n5HR zVY#~5&3`lgnHVX~xV5x6N32^|q0RKzD~E=J^_$A8uNk==;8L(~UhsI|><@w|B}^P# zKAGmr?}z_;FP}J-nd9GWf9DSdytBXS&)sldVm}iH8$UbauClw+YJD$re4qUN{`@c- zrw3}1V#mI}TNJ_c-KpRV%fW88e2@C4tcFYGGc>7PmSc2`bF!AqZ~4X1QIfy$-Dd9h zffF0A|46mkmZi?FF_Wvw(rbz(SKvkO7hWF@Nu-1^e4mi9xcE=VEce+Flb$BOVR8~V z)hJi9FhYbQY)g)dxN}BX{>7PXVLfkepH$hz!!q;T`RWs~U(c>GyTLGjX@rZ;!bzO3 zCf!^n`I8i>#Vg90-IB{bW&7Lu&oh(p^`CQOf3NG27Ip!br3fu zS74g_{$eFlRk<9CX3;-8+aqr!KfK7lR5Q5g#FOaR?>iV~X#TpeM>JS(dZfiazbK1C zHxA5TS5ISf<6RYG->w&&|kJaH#j z0=xt-61 zIeV`Q>HSSo>NNP9BUB^Ia_oGmLYYiOPv4E6K4bY4FBS>!+4y8eh-dGDpq1?nN3IHf zK7FI*lzdXsx5~de9voQ6xlJ-!hwDApr1PJyFy7K+ynp1^Ce6QoQLi~l5_Ht}x8DC)MY+yTliczz7E(iDSvgI%L|7Jh4 zK11jN$1Zo7SswGw-mr+vN|FtdzbEd0HNVEt#!Y``FM~BFuj7A-GrgtNylUY#|C3yF z_*R?>j$srqTK7jtxBTj~&Wno2x4hpo`Mp4Sml{tlQ*T+{GHYgzZTr0T`P&J5xEGbZ zSFSRCb(GhpUeZCJ;q9Mis~LW)O%~&rv?*aq((>+KH@>o$CjQqlGpKS&3s+N<5MOG% zJN^99cW-u1S!}BBfAGLZ&D~AQHl(Yl99oeyS<1XFiSTgVZ*ft54nEGJ&3xqWy1>wkK^BKO?~ZKvc;J0UwIe1(tAT{`rEacQu9CX zgf4nr%)+vjr^lp;@u5sQU*?Q2u1#;|1ui&m@ba1jw~*lSH&RkgTWc;<{>)@#)X$hb zBkjeU$7iaovz?zvuF3wjZ0@~6b6<{GMp$V>4OlVoCmH8!e|(T}E1)0wyIZZ|(TD=Isr>$tt%#_wD{*>9EUrbK%#m z*C(G_&&seY^w6KkJqKDdT-`7IvUtEP-`itTczMdPnLD2UGjaTT-mb1{+V)Gv+fKUf z&1?6&9{4?cS)z}X5brOMtrH{HSaxSMsBNegbSwB*b85n>TLP`$?^!sVv<`XyW`^Fs zN!J?{dgIug1nSJaYMJ&PsH%DK!BtwhYD3xTWhSR8Vl5_j1uqX?SkJ<8+;>3<=f2L3 zC4$#^!~$+_uT7s-^`-NQQbWR{i|!pyRCe2}ER!-Y|9iVhqtM>G>cqFZ8iBhd{|jn! z*Zg@CyyQ=%TFu9(J@Q)uH!fC;WJtKJzp~xodgZjpQ%17RrV>Gd-)EmPzWOukvW~O( zZ+kt{s-r(X*wwxHtlq!C$7R8xp0&Q(%%T!~>kN;ydpw)GKa=ydipW z>5=ntaiQgc^G%@ydV8^hYscMnhTG)`i8D$>G(InN+nRM*u&jQUILqBqhLFh%X3P9P;BvwF)@E(r$2{vft7pCW^J~ALn?%Wj z@9X}y+x-w~NMIHY$Y9a^xzsIS{>6pL^Uo|?EbsUyz1H~Jy-y5ZOMZxK6yu)ZRVn#j zuW0^Lh88);khznOUv}45zLOMn-m`k*>*y0qU+=u)&oxm0bv$b7BHrFhqD#-uS?{*t zEXM)O?Qa|k)YeNc6z;Z*h*du*Bz;Us4!$ym;((u}w~2;A%GCWuf>ljE5#)HMsTM z-zhyHWyk!C<9`E<;+cH3J9;ehGwPR`ein|2mpf1uZR~gDm)9xjbqcqx%~>-e*IGkF zCs9KqsCdn5-wYPU9$lZ)$qXmvI4qxiiNh(Ir|MNfZ0l~R1^ExvLylQ7Zut9g|Do)@ z)^1-uj>&$%0(6yMo@Ln5$1Bg;z5RyMlK)NLeVmn}f9U!PLaaP?9vsYPp2|-X>!S*@9;Qx zdC#p7t2vKP8Mfso@XgShXFox2?+30wuamO&{49F)Y39mTyNZ9r7V+xE@0@#aNoBpe z!v;GO-s|7>vsv1i|69&mQZOTUYSCQ|$y?0^i!X*KK040tWN^c2wTZ(aT|PO_;`5U} zrIwlLzKU+|x;r&ZbO}S#7Qw)ICd*WEyto)+n>mu0mCmGInR7ET*WldT>emKZU%O|_ zy6-Ri<*@UKz{7JUFPyr{_t2S>nd*mU)%C>q{eJKJxcb}jf7|Bf`20Gv>UzuTrpfXw z0$*z6*z9-6?lOwH`Zw=a_lyR;xCK{k{xtc)`A_V*-V$&2`#!uf$5c6DKZ*A?EI7A~ zu}hI<*4Hn$rPyn}UC%l2eWDlh?GuXI#FUOce_B1Gl_ka{1!r^ZX5dLz2w)X*Gm1@{Z+NuVMBwVtBS#y`U0uV;(vd6*JD#5r998-Mdc^(LGiq+!EV$D?{r{Wg`ivacwki4?3dv@2taZG~ z!RNh!ljU|6%gdFEe3{#x=&oq(_!L?bxXSnF$2i`~x@jdc8K0*6$#_qnpS=EoRnT$K zw1)LrDzn;edfd)g?|wUQ@wKg|tHW27LaEo$1m>$TZ}qsNZVOlW;`sB(r`!lvd2 zti4e z$zYXbdf$TYVbNM2=EqtU>0H{AvR+>8=f~MB6%)>1ky#eeb>&g(gj09EJ<;S~OqwpX z#q*#a*T#<74Yd>0*Q!m-(~&Y<1geUNl%3?CaBdUaKXLVqOxs!XWI@ce%%p z|4rDD`IqxFfAvw#iE-Yad14s-E^8%g=0Ch@%06T9G0w-InH+V({O#xK+5Ki>_WWS39GINtkHJ8m@nV3?>9e7K3>mX@=PX3v}JK`SkQm7{tJ&jzKIUb*O=(z-Lvf4QpQHD=CijK z-HBv4cv?P4{^#Bg7q!1!O?r4rJhZX8&gIJ^{YkHlcV^r3?S4{ln@OPN%fkx?ru>k< zrnyhf!QkA3CDJxkv%(nJXYK#plm7kC&MzM)+xvI#uaXk}SDo1vQ*7k9Yw|M&hFNQQ zQ&xWZywg^3lYzJU{>9Ha?ia0QI4CDQ!|>_c)T=i0*Z(+t_^>>0|Bd^L&26mp?M!Za zdu5tE^GH0%FpDqO;(RIF?G{yse_IwT>pk}PI|r-T`x}nGA5UTvWEJ@G>tDy3zc+7) zFe-07q*y+@BgM% zH+@DX#}g^WgL+ZC&yW9J<9wu2od5HZugjMQaVkfAocmtI^oq88or>zDuIQEQ>X$Aq z&42UrG((f|?ZduH-0r{rk#~}1lcKOE`c?!1|YC0~Fe>Drc*WfMQ-ZVCG& z(yIP)bGFqU+a@Q6U>1p@0vkZ|(>E{}JeOUuA0BcOC&N zlj%C1A%E;;nEiNm2|EZF%&2AEpLKbjBFnm6kNd9NZa>W>*0`00RjwB{ycN0AY^0Qb`UY znfdQ0JS<7foBHIi%cdEtI$X_UErlB@J}iox^{XSHyMLXKWVOoH`hWi)Z0HiH{iMUt zmEkXzbL>$;*5B~pRY}T`k5;{WvvEU}&J2!)?ypWvoZ#}sZThxOnXoKrg_YNLZsR`b zxn7Z#m&3?&w%HP&VgbH)+V3kl>P1;PJ+>+J!>8`(Eub#Qs zruVG7njB1PI60F$JszqyY3;KAm#D?i#I3(~UX($DkA3UGny4-Lb8bBPzUoNqfn0M5 zcjk~pgZ4|ov7G`5;tmt4UpR17Ez3W+Q*_p$<}ZvoUoWUQop{AEXN9c<1DD!-h4$NT zUGnVy^rnQ&Sy^VZrNr%+*J++-8+NOyiLT&eiYihpzxF}x>Kv)3S6y23G8gl`WZ5<4 z{AQMmkBar(>fAcxIW^0c<(hR1<@uNs}?Mls$jaQDkNI#RQ%L=LJ{aUtJ^_i9XiNeY!y(Ztk zt@N^ zHk)EIzYW1Ew&|~$ybRmCKmV|aS8)7idB=)x!hhlPKXw!Q-Rx(DWpyer_!eK4d?CTe z+?pqPW@EP5@{ff&8iAcIv)T(pnZ%#F7{#m;eE!KqXx*P97uRpRFYS_}KYd2>{hDcR z0=L%hpVe%)M64%aE9>K<%m1!yvt!x1?jT!;*un!M&3ym4;&EP**Cxs2 z-gAWcBXY6AIGM!tut1nFwWdmw{gMVUs>d`tyS?Gdua$22_+aUC z0U

?!uW3iq`A^mT zI4sZi@1y*G!@XaxMHenyk!!u@#rt`0ek;hB++!$MbI3lA$^Cp_^6zhNz3>0~w*7J& zuk@u;_ErnGL`@SEcyh>D;YF{`#t$K%oc^8o*rvSI;e+X>ZU1F_Z>@a%GI`0GW1@?u zP1vxuGeUPS7l+hC4S}4MZi{v2E;~M9N!Bm7Ug7Yg#{_x4&B$@HRoiXG(sXW%gMsrS zFXQdWX_wh~+OMs*n{kY>aqY~tD^;q(b>})1Fy%=x^BWXshDkT<*Auzt%*(_vOIqil z_VyP2<3cX`e{ZhmRJc+1@#~cagA|Lk-+mQmIvzOa&)O8q&Ez=U?mL^nmLwV9BnrKi71{(f)Ymjyu)mvnu|~Ub#_H;m22YPyd8d zGae>=on^x{gU_FlrM2-}@|)m>1r6JmMmBwn|MP+AiqdG z&I>H(dfA-GD(PRw(zH;g!NSe(GeeVhyF-Dv!-x0ESwFTnDlC}t_klu0My!Iw;j`-I zRU$tmqvF=J*9ZK6qS>Gz+Q87X_xZeK$Mn?vF0qxqSbx}>U3jk3WqBvxCtKGX+moOl z6{q$4)UqvHjZ2`>4t$=7zY z{D*KzN%P-D{#q?H4cDqZD84kcyW;{Z6 zC&bJ5{%HH+H|cd!^MBS=aIpB^-OR%>bIEz8rWuCJ9DQu>H_wwSSnkBNXy$h9dZ*dT z?r+qyDQ3AelVj)KL)|Rb7cx}L-;xnKNzyz10smSVg%kVb-k;5R6)4Z-cyPfr*~?v` zm%P6ft|`-7;UJRG+$r9`$-=$X##!OUu1JLwOIe$ucI^;;QD%O2^YODR8(rSree)qO z=tRJ!w-!s^3H;-Fz4dbX_mx*z&j|nJP{`QE(2za($wf~2td~!(tjpEBUoW5f<(>EH z^0!YmcV0Oj+G721QAVukK@W$F6s7Gci){-{Ir{qi^KUzuLv{jQ|6 zaXqu6lpu%FUGLw!r_4I5KZlVc$+h~`%M#Xx+tuRTcV{N2Olpuje4F=CiQeJZ+$ThrAocTU8s_dZP96=NkMkg!#lNjt$;z(>8bhR;_#(6PHc zqQw7ihgG-wrKiH_!T%KPxLg*gt#Z*2+}z}(Tp`QR)sdn7iH(z~a;?-JKr4N^qw6*7y6a967&%ao4+v+m4=HmSUjTu;si#qVJ|{ zN(cEm53;fDx|6}+cts`llh0P&@^5GSJ0(=2t)&kB`I0G<&)F0C%R+a-+z_iP?_(4m z-Oyn)y8FSh;n2U^+YZVv^m}eD_ERshtW_{%hKP)B{@xP`EO)-MEV%Z?VA%_g^7sC0 z+vPpK`buB^viEz~(;p$HC)Wh83{tT0N_oBc`tx^6zJ6C$JdK;OV~_j$?XJJLy|=_# z*3RMiKErTgQ8n8`flw=l&53)xjvsl;6218Sm-CE{(o51dGhSZL?53;e{<0aXNQT*$+gg6zZ+ZWHuDQ|8-?Pr%i#V`nkw1rBp6!|0LJN5e7V8}B zS3JqnxBR2u27{cY6}%2QkE3tz(!Kj>?)zoe-bNQHSJ;Tg@8tDe{au5jh}VGY%uMB1 zJb$a%nikd;&0X|VVndtt`voiAwRe1YW84sNN90^!(8L2A!U6hD7fP=e_^vALYkXYl z@-8zh;C+kGAzCf{|=Z z<{47^JQXq|tsLEA>kfxFoVxo~$4Bi=bNNZljxb*C3y-`T`ZkMiSPXS6Wf>ir-~3Z?m~eF2wVm>_`MQoaWuKpy zG4(%a4?Hq?;ldW$thgcm!Q-jT%g?UL6gu-GUN_F=7rCww!*z=6GZL3hmAS1M8M5#2f^q1V?1&tJ^t z_Q%cX9os{G>D3P1mz=dD_WbZsITTYdbCsI<1(pfv>x-WX3I3c~a$*|iGsRagR(yOo zKl1TvzfVsEZdAoj+}*p6Lm{>2UjHl&VYcfGmBJp0j}0O|2SlpxEVXy!y>r?^)8

    2mN^-t_U{X+HUsv)NGIL^?Q1zbevb^EUwN| zb4Um=NpP>S`pw15FD>K{l3b(8;al_S*owt5vlpb-^O!pE`^n#5pb7J)!%}*@h__4emU>kJKxe~qYv?0S-<%8Cvkqm9G>mnZaemc zWb5ms-BI_J@D*IAsCUYvTx9$I==xQHE3f^@uRT~5%hq&(QSj&d2xX14llFzY6Zhf& zEOI+;R6@?fgChEz|(f@Ke-8Yd-6-K#2ImZ-}6GgH(i;_Y5OsRJvL>mSCv zN@g{1K00-I{YiaBg*D04F5z%K_DlNyCc*66vL7Y( zOWV1W^}YMHb|wG%wG+Kd);Km*diZ=WdT-exdu*GO9NX4k=e$=Y%Gb&$i{dhYg>w*H^K^MA;GUT*gIYi@M&mfX*R zk59)Ri;GjLzbbVlf~~3NjC|n>_7g_kjB<>QiPGy<&UlnD!=3y2OCDX{%11K)O!oV{ z-MswragXz?ts8!O1gf6fexqVR->kg}mS-kAOqgECq2tDVbhY8}!X1u#r$u>)ui7uj z@$8A|s)IepB50PFx+|29^)iZ*_yXWL7skaJ}?sf}7KQmd1oH9e!o)2b3TGv)R*T zE`EA`H_MC8(DTO&b=SEsx6wbovUZY*@MD+sYu5$mmY(1HBv<)tXHWU>Zy%C_lTM|) z+9K+Fc;_}NcoErNh_)mWLv_9Uuc{<;Ql`B41NS$qSw3y-I zB(yEje~CTwUwzNh$uBp{xZS_AOSLzDuA=N|FNTNV1!v?K9oH#}@)r5p=R9KT7i`$` zuh{=tpzTgO6`@~A2Elixr_H>j`gg0|(sPk#O7mr#9VaVy+e~Bpk-6fOeq^bWf`&}t z6t5+vtIK#!^ltsNusyi=@iCLH51KPKMIWJ2SLea^Wr%Nbi{^m8jcx>;Dbc_-iWIqHsmwksH# z%qliyYA@a5vD^`ERtRN92{2ip9D+;Wv*I1XPy6@_3!&w zr}ycC@F_{`bd(y_{t;#qU@C%Pb0OGoEzq$>~Hd+b;RJ z4ilyry%k;_EdH>vVcP9l3C$}H{6BT*y}n}`^)}efAcMs_K$tsJHgRX!@33E`;WK)= z_m(d!`MoWKS*Oo;!ljUy)5mO5d1~ulrW@Y;q8PXP#DxV{3$x}{ zi5%XZIFq0AeD=j@YR4|BaVWep-OJ|QaPw8_ zpKIsW$|SyA=cyFE+;@rZrx&;Wes33=7- zv|o9XYM43H-|y9bYF#dL(0kp%x5g8FroMVVN7=D>?dJ`FyEG>LEN5qVxmm%Y!g>ojkfn(?O@f^SUA=iOS#9)E258=;kJ`wlGWJ7%>e-s=3`%MGWG|9*Co z!RRxi*Bd)tj(_j!B-hsa@$!D#WoDg3=a}AUQ~t_-|3ABW`ZkaLB})%IJe77py0TwLSo+w7*^JNP=9oEaXU82s zr@elu(Ej6$%O2j#?6RF;yCfw~A!3Vq?_|5v)!IIbOfS|i+r}Mtvi8OPn|C%UZ=Gh^ z)N}2*-5ixm#~mc*p7L2;iRFKB> zUdG;UDu;~y#jKCTw;m;0`-I5oacqs-^Km`*73D3CerxTYb@a1xu^hT$erH-(-RvW$ zU5uX12sC!^$|y5n{l>iXqLB2GsT%`rDl0Ujg{&(x?Zr#NtY@^YGGh){oge!C$i|Qd z;#&&dRA`;BxbMFDX5D82t+F}CFACLsvYTMNhl%~R$1_VCx4&W*y>@FI_@+NGXT7ym zYT3z;*6$Qd-9v9JFOy%ox8Q_%!IGu_yJf#0FB3kOlJW0D*baL;?jwi3_XytYch*f` zaqgyx_j-ZM(q}chzHJr{{`)ih!X2S5dw0c>OaE9pl7x?$J$hm_DQ@m0r>~|B`*z>> zBhcKktSIUGx)nMXZ*hce*C4$HQDLWySB%w z9&6w2op1Gio|}`+Jh78Muh##v^ja3V?FElz)K30);l4h8t0v5`yxxDjO0vzcFqr$VU#y_yP&{I_jNZ{DIE2gG0|81@JlVT02xM>l;1t8SNsa* ztNXU{_@;h^<`XAs1(zk3xH@hwY5ywaS1g}+(KPzNd><3JtL_>TtE0n%|EoPB zRB!3`udCf|PBc8v`)8^*L+FL#Yd&X|_Bw2;S?=)lwnM-PC4nhgJI!|Nw`by*b$2_v zz#P9HFSRO5v;Qm?=hC~d@!cEFZ&ua+#Qm4c9V#wN5-aE~6FxmRbT>;&)#nu(Wt{R`#H{Tt*s7f&S5vb;~FJx_9)8O^C8=}-D-K4Zmf_z z>z(0fT05!v#^fK_S{|~ z;8NL_fX%xuxN|Q3>is)b!J~tpMM%E;X8EC;We;;ttqNR!c~Y9JN_w-95rZ;Q`Ie__ zJ$tgs&YhHPa#Ef8%3iwl{M;MEZ)eqmcojTml(3|~cyFpO zN6YNE0Eb)i;iK=Kx;b39zMq|C;tQ6ly*G`2C{M6zaE%m*Nj$gr+re<9tqrVO-5oB> z4&;6myOYJ9lVz!q-nFdso_DwJhpy+|qN{d5cK_>jTRvTMKb#Y}pMSH#_enDsF|S>) z_BdyN==a~tnH{5_7!~$!Id8k;Cfk?dk4K*?a6M;eI=}oDH+%4``O2&Rg?extkPX~$ zXktU!)+U25&!kiiY<+#1rS*!jLva21xeZPY!aJp+rOhr+-Jv|ES^K27fd$*sM1g1CsE4;(P&@?Gv`vVS+YZ3v=4~p2zGPQf1nQFV`&@^A^;{AW$-e0=$ zw)rwKQ4h9;7ZG!q9D|lsEOH3QZfuuourF6w5wKK1kokauPS>*vZGj$-fTsLsAN)_P zyfNW|PsHMFHXN}(9{k<%MXa>*xxwj)a$dZPuJQf3D|vB2+PVW-3U$x(w`SKrcRrqN z8PO8>BdK9QSP#>z)FZiD4=r5ntgymuE$2s0b9SEzpMNNykKZw6S=^7pC)58j{4!SH zFiQM;>I|>PlEM%C*D5c#s+BOz4V&^OsBr;Pk3+z7dvo1}4Ho9zrtc14`KP**_3L%} zPP5>+W&eMhHoaX@BrNk<*kQxTf4mAF!nO^u-CK-wYuTQz{l)dT?y8YD`})~GqSAL{ zO#IX&qO-&+I&~s@OxLd`=UUQEbo1zx^-9m>eV*iVp~va8w^H5JIbtq}*A0(Hi$2v- z{k!WkgWVtI-^=}$^2k4XqtWo;jLuHE^@&>l8m9Dcta)?#;DuA^)oeRic0b@+_T}Te zKhl2p8Cf{nqS=}RUf4f#uoB=XlMI*}|M>&!qnZ6{BNiT6&$*(F)2R7Vq}57=Ppb|n z?)B|`P^rAWASkxxac{`sdc`eGI(*MN{|DGitlgT)#KZS{)vp^T_r6O$n7`$BHQ#i< z(lb@d!Xy8N*UvpRZ$(1_Tkv|uoGW$$k6J_YCZq(X|9H7$XS>fy?;57^u!QE{S6F6# zRzA4gu0c}pJnO%P?&lX=WG!ZR6|v~reLbDBQ}6R9*Z(;^$xLe(?~T5+z(xJUCY5Uw(8x&4lsoTAwlSB16D8rIN`GWI?duY5@2~!Gv*?!u+dS7Vt{E(`ukFq_DNZl! zojoBcRgN>|$C^coVSYy8DYO4xsuJEG@Zzkfj*zU$OI5C>dzOFh-waj`{?HK?In#Y= zK}1U1>*JPdosTblQm@s!U|ER#<1H(=uP_|{ASZqOcfoy8`BWAFXL|i{c5k(>CENQXo+nFHVpEpBc3307^A zKbY@miyh$YmVealSzr9Y>9f-Ml?!v2zL)X;V*OCyKkWjqWwvQO*ZeQ@4Z}49Wowq7 z-|n#CoZg*%x~AXX$M#9d^_@FwAIsjPXTYhdm5}CiJcM(F!Ue0PmdpB2yk%w3JUJ(R z(xOGDm(8r_%e_*`a3%YR>7qNmeE~y-;O-`>}_Am70rT5`5f> z%3($KR;!dPdcp72C!N{l(R+sVi|O}w{;NH6FR|Q-;!SXqYPv>rhvb5zWH~s9}@{5r{^Po0s;37-4hZh3;9yP!Gdy&0yLHP6uHE{|OQulY* zA8<02+*sMJzxU{?1c6;wDouZ_t^H)e=&3Kv>%E~lGw@L3jE+*7J*qr+go+siL<}xp zl*>M2c%A3|p(%mPG3NP;**@0Q7@1F6^t`%$;-zV8GYf9J{R#h{%;0#LZRe`h?BDqm z-#&bozij4}@&TcQIuI=b7*LSh-&)veZ zdOOo1!Ch+m{f%-O5^`@(n{qa%kyD`7x1gnG%KYQ|0*nQ_UFDU8=N(-7Z%#wP7kAxd z+~@49^Blz!Ry~{_^>x2x$~)BueHlg*44a<4$$2$l{n~E%Ywr3s^LMdKm}0O=hPOSm z!^lB-YtszYhU2Adp}Nm6-jDdT*nECP+%*m(NuLwq%q*e_o$sdJH@GkO(k_LM>0p=U z3f6O;M|z@J5B9yhB3Lm?s?^I=?n3#TKQ-@VTKC1Z&3mNpSN(DR@?AkwOoW_d)xzR- zv8{4BeYI}VsXrT+B|ehBAM+6#8{T|KsV-?2~5TuW|#cG)@E?pZ7s*My6U zi}@OV*@(99VE=tj-@}mg{Dd%{4c}^0zwh1={_?tq1-H$-Y=MCA=&e$5-U5n@DZDS9 z-k9dw;PgsG*k#28U4b{g2bCYh&gxvx?073I^P%#>Nc|N#OTsoVPvBGFkofZ=mdS8s z%a$b#^_^3EIo6jpRLJY@X3A>c$z{C7qM`0o_*ZsuhEpoOs$ohkM-RHsYGG~qX(aIH zv9MS83eVnz3k6~`SKa60*i^>kqw!*QiO-ve^rF+Oi?Sxp@cN^6Wd)|@ly<4kz#%x|#nN%Eb2vX?dOX3SuZem1pu{Z0NKRh`S6dsCMFe6V@8joU53 z`R)z{U;ga&{c4zby2ST+z`kEmKXSyDctk8IiE=y?^13-rK3mPLYR!y`>je$Z6!-7U z=u^h zref!g?23QS|F?xDn=K9Je7CD>zi`Wz-fazYZ-< z`5gB1xB$mOX0GK~hO=huNfI<%_bX&)yU~`_cdzq@3m(zm=kjv(<{yc1M^YdD{V@I9 z#bf>lRn~nJur*z6sS$Jtkka8a{<-;xskn_tw55-L?W&wBP0QRb zC9U?|TR(5kqz|T-*h}Zvb0(A;e)=pbKS7T7yY$()3mFoGj@n}{x7y)d#bdur@As|W7PLGouKuN~tTC|}$2FI+O(109rdsKj z$^3q&d`*>^8aUi@cZ8F9{SEI%T{IO9b)hL{Nk}t?Tg2%?*b~t zeQ&LMcj5HvUC)*=G^i<@WehF7`Z8z1v3=Da%m18aXj*%>JiB`p+Z0z>HS6PtdQWWT zzy1BfoV(@b1?&@#ccz>!_#85aaZl2%caQGG?fK+0gGG1h^u4E_9iN?N(5KTmhr`7E{zavgx(RF&VW*8960Teq``E~;HGR$UN}t=c4Rcc?W|IEl05?tGdgR)J~oM5!=os9<}+^bC1}s+FSPT2#Kkj$EEUqo+7KTR6;ZN zLrvEGQ=2O6Sae(dW##^T*{HCop0(}E{>OGpp3idBZhO41ng7(1!kL+;*Dsj(_3-)N z@;Rkde_~$ATlZ$pHkz`-WJcLBg_E4OF04wLZ*4H^!j6MKxNlF=>rsr7l5u**@wZ8O zb*IX*6Aor|-mCl_AZ5M)rl0q= zTBvYlb!5hjug6wM8Eu;`lO}!fnawBOSBgw?K5Txyz%_fr%GDvF0tsU49&A1Dw5k4A zAj`q6_y72*SM2{_EUq2?*>}&kxwR&W`EDm_r@whKt8M+i7td#0Vo?0SH1!AntPeL< zDP|e$4eLKDpQ)15J2y*yPn$xx!Yk)^Q(@EV2Eo^^=P&ZPw#%e1{=t{W{ejFARpwc9 zTnbq8M22(faRxZ`Rb?a&F2U#swQcYA>)`ptoSxK_`iTl}A6W z432VTTDa%hqJPiCIazkf9GO=7V#ed7fHU)sc*=iozP{qKcbvKKpKt#2pVdWF_i$GQ zo-YtediyJ=EWVtNcrIcLn5)e~`Kjf_c#*Xu8b4kj(mxKcSg|EYG-EWuDON%k>5@k zRWeINRi>G3oqxRZkIhtJJ~^LUpLezlkA#w6Ut7p+yUA*Dbp~6_9vW{+6rOa{bj_NsujgNIg`wwTbf&Nj6wNrADs%t*xk>R;|GudD5|TeteRk)*4{a}d zuU}e_ac};|$h}A7l%=YFeLQ~oM*04J{%g~wyxk$Z%dqh$uWas}a8?s8_F2qjl7F}4 znjQ$e*JB>#$;QSSYcc=X{Hj@>GT$#-dOcp<{hm&mdCk@hGB5a_w_0CtJ?{ECdT!a< z?N9BGduE5K*Pgg>{hj~hHCKPBJ(FDRxNqJ9Gac6CH`8}W=5y#y$hl$499be2?-yp2ym`trv`W-!iTKpo?*%%!rxzRbTK(y{8n9WC zS$6Jo_A|MTACeF5JKw)&l2y9K{N+1mG;9<)8~y%GBunO*BMhrrG%Ho?qTZV)^FHxe z5+?tf_uT3VyKEF3OY{)<=JIuRqi% zc(-Q#yp;~shTD?UXECU+`SVVAW!Z0@b$+uw8=K>ex7ammI&}((Kk+|WHPimt>24nW zpI#3HfBpWyJL>Ra#~m}%vxWH?lqF}UzS}7tByM2zfA#YXzxPki67W0J%%n5xlXF4h zyZNj>Maelb&lHM|A65CZ>l~Z;gX9NG?s)yMs%u#LmL=p(+s6mu6{l-|cc$Drcqn3` zRm)E9fV(ZF*COrDO!F`jP}|-+^J(6*jK}F2_YRBg%g z`}q0=_aL3lQzgy2`hI;0KcL8aVdGZk^qRW~&L%Isc-gKcKE4v3=)|02Y9`ph*f@9J z|92+eHi!o09gWYG=DrZ?af?e@cAcxZ=_^h%fiqfmPq_EJf3!e9@TEaTsmksicdH78 zsmJ@4e>&1R#bf&=Mw{9K!DajtHmQUOuU)g?_PMVHbH8;4$UXS7JL&edDQ}lv`0=m$ zQq`}?>*skL{dF~?fzhyJL14%&Q_F0&%~FiN+KxQvwi7eFvtXm$v%5-nv~Sb$_$^s%2~bbgKt#tM&FWo_*=d zE#5V%4Lm&MocsOR_jgt<>6;e5f5Rs!Mn-XkIpO-jD_c!GpX_)gXE#UBIV3uR`It({ zL5`W}$0UE+TvOSiTy*#;!$D84d#=a+-Ti&3YyVG2R+g3evcX&%1FPG#EU)p(8CjS` zoI5$U@Ugr4pJ`vNJ+?8MJTtn=#>@1n!J2=+XWU@bu}D5ItMKS6OQq4r@>lch{8u^^ zExFj+bf@V}$^i|A?NM2dhl{m3pJc3&dh+f{{EEK#*IyprZ_<3ceRpkj)RCN=r3(2o zLuGijv&}fYV|kb236Yts*X5N}e!RML|I_30U^eHhJ!J;Ef>W*rHyn{)t-JZbcU7%c zhNe3~&5EZ4KS-^GXom*~U(GTSoBI7j(7VI_Ol&I;J+~4u z+hOf}S@%GTPHXD9opzSbejWE;`g8ew)eQ{VOjl!GeV%r$EUgEgn8g>bMG-dNALE9!7ie^YXT@M@X=dSCi1&R!7f ziT;&dZE`0--t*P!gRRAx?>rk74pwsotV!19{#tlUesS@obKADG7C-oWfxYQ?#oJw( z6JvHX?*DM)`a4Drq1^qM$zCC|Pv+fqnXk6es4?usZ)v}(lhX3%_Lna&wm*A>H*Jda zn^)%?=db(w>u1Qhc}f!!&2)|8p4$A&dY^pN;BV5FgEyFzvJ@tq41FEUCU8Pv+U)zk z%VsIeKKNwr?S+9~Sa_NLD|(y^!&AIAh&R zZ~wC)D>+xxytep!Y3Hto&9yNymCYs=?*$EQ>{+&)jGcl zcCPSCJQ-4Ab@*x1)I-ZPGHV_MXlVO-H-EUya=>>J{}<0UYkzV*c8q`UG4}Lzr6W?A zHVYQGCiU_7y#28EcXH=elfDOglkWf9@@{wk@;P(%a#l_B-8{|2eEYIT<)M*b>&_m1 zTPMqX%t)Xo^G8j6gj#@zgGhJwLxz`OdNB$`Uw=;NSQl($dTa9qbH_ARj)@*+48FSN z{L8cY3YlzEQcvX6Fjn01*p#}ZX>xh4_tSmsi+3GdRlECR;4DvOvr9s(n^n{D93)$h ztue?r$Uo(MXZ0~bR>UOuYMHcguOmH=N-(>Z?n`m{BqlZBatunuCRKp zwd`C*QLK5p>kDg}J0X+O#kZfDAa`r~v0GPvgeK(O-KgI1;K{$cnScJRcPns{e_5ZP z!uEX29f5UTe1AW>v6S_=X}f7{SktiJwubvDKaa}0@pjHvz6GA@+B^A`y5GYuJ{5K> z+OLCx`g;39rw5iQ3vw9rmAGE$nyP$FA@O_pTi@CIuyU(eG zSABj|$>8{lWny;Lq#sTEHX;fQ28m}lEDw6P?JtX~SB|X?y1-yy^CfK6*2Hdu&6Do0 zY%TENI_9gSR(yHC;j^}VW@hJGBJ2K0^DpaR=(uHe=E&~vlPsh^GfO>l?PzJ1cM$kL zn{mPZ9Zn5gJX?-@eQ4yc;lEnyZ$4SS>nlo>cH|juV{TLs&+Knl@c7VgN8v7(?dOjh z&VO@YIbYkZU+n)?8y;9V6c}9MShQ8x$IEA8X{7bk!`sf@d2w+e@9Nc8GF%wm*InvO zJ`nN1HTVJQUei`QMI$_UuotDd3$@Sn~l|a$f zoO|tcPRs5Ja;$S}Hr!V(pDI_roTJ{A;tzT|wK-!QLvRL*Z(*>}j5&f*>jGuptU0{%LW`P1!Jm)EgN4})f4(peO21vk zGD|d5%HY4Jf<|zW%~if*2Wwy0fBDJx-75Lu;(*N$_XMZk-SxzF(Pz;rR?EAK^A|4N z(IK_9`LXrER6Q$o_A_tT-|sfzxAYxHE_DZI zUR^ig+@4~E2lI-pi=I{FT{tAbVRV*}C3F2f^`j?$yG)p;+&V?-;O7h$M#k7nhLMqJ z3<5ceo{G=WzI1ATt;x;Lb2xcVUsBO*;*rU=Dd1>+sA1OD<@?C z3iuWHdbL7c!o!9}ceh7!k;Zotczb=tU$+GAxZaVZ>p%a<+cqsZ^$Y6~FRrLx~2#e90jwq@K70=!Qccz@j}-#1guGvCy6-Q_KO58rl+xy(#^e#c?Yxk{567cPC9 zxLt5lzrnT$H9o_6PbA-Ls$1*w*yb05+tJPMYu;Z>m#JD)`_qYcZE1IHia_+CtDc{i zrUpm*he#ci(aq@5R8MC}W}Mn?ajDff>fFbN>3<8E4>fadnQoh@{#bV3ABGj5?nE9C z(TsX<^;dMXL1Kg1?vzI+<<+6`Z1$_tx~mu3zU*4Rx;C}F!nch<|EV);>-?SfoTX3X zmtI`??$FXh9EHMNoG<>Z+Ger-V69X^ko(TyP5hH?nqFY&m!5O%wMpwT6A6Xuzc_3f z1$I|-G|V$!>5?R+Uh`PC@c5274!if|rbjg7{XDl=^S&9gz#XRE^t&7^k^Aqpo3P~_ zvkh|yShbsnW#)$S)jQl&>o^~5`SNN-gSi^R7PHzvyU&!xEig23T;2C{;XhUbR)G>m zUf+vmpQRN#zU*h+YOo-s>U-anyZ=iMT-minXr+O2Pi=!+_R7vJXMQRxaLi0AVoU|C z;JbI`VVRkCweW{4YEEZrI>PI}+BgUt>-@a7v!Z&&fzX}Va%D%aGZgTyd%5uayiytM zTO7{QBrff5YP}xgzQlla&t}{2L1B5aE^p6WX=1p-kj#29LU59I^?p{COwFS27oSZ1r5X^P5Vpx(hW`FX3qf0i`RPP zWDiVLxL{&sq+Ga%zm@a2`t>7v$_Mu6KKyXe#NtEtslZsT>3jQI&9)Xh-sPEQoIB~7 zT2I&^EoXhHJIoA6GWO(rowa0U>RI9YevdPZu56mtAm;t+rMyYktaATDzmq;p{j;9g zaY>#jOBPFaKZ9=sPuBW9Li>)|HhBL|WtzhfaBk+o;52aoo+iJG92>4*n9*bZ?<_-8 zaKG&*PK6b26aLy=;pocw7viwt*2Sywmwh%e1__r>7t-y1Q2K7^^q|ITOMi=P%{o7K zJp3n@hM*H z$FkpaD+;u<7{wXhVPyH;Fy&vRNz?ucHIpW8ww*CEcokN-ZO~L`E#6!#v#P?R&EY~& z<75?q^$id9J`tB?axCs%cVEU~1E)YqzUO0>rmW8_O_sSF9D7Q0jU1g9{Jv|z>+H|J z$AYD4dAmb_;AibGQ}*rt_QmO%)))I5)#vqg_q~qUUiPNLr9pvHNacXaB(7<1A1lg6 zS{>i!w?qE@4*Qe)PsG35@tDnXTmNF6o0}%7su?IgzmWL+w@vZetegg4Azi~2S2s6Y zt!|Cly6WDl(68$()6ZV|<|}(_yR3^ziZZu$EZ#<I!dZ9>-2*&-XJq7TubsWP5o}+JUV2V7rXt?~UyC)c4i?YAJrB>@&kCF5|rY zlFL`k=g-l8b?%tseyPd@Nv~68WTqUE_-5STT64er^ow4_+WFh-XO%B_v{Wu)#;ohf zYs{>!SFf6R^VgaTlh2Er`9FUOHL=j2)5$7vOMAxh8)1UA{RQ&R4)M?a@k{m($7bD6 zwvUya&(wa)X-(hr!0KGQzWTo3Z`(L7xqGri*MyV?L7G_4|X^{=dAvaovYo-RWKjm*1SSepT)xiyt%H;x7rTS8_4}Brz|I12*mO8!Mofu;)GfuP8}DW; zOWE-Jz!yn&n=(^ z-bq@JbbZtIKACjc*ciTt3OmbRapsf+SpN}M;Z65Deqg(+dM?+s6pyebodRWoPsYIwfZvfVcA#Yq{Kn3+x?6*+%GRhMvOH-+r}e#twPQ~KcXf8YNz zD^+N5Oqt~3?wiZ9b>qjq7owM%HPub>HQLo>d|ot(8U{EFC_ z2^{x+-HT5SViNrGyq=*^!cD<{Tg)f^eTnt|~O0)d`4Z@?WE@zBup(NA;$iPwpwRzSTdw*YuHr*!JM>#=n@t<%3FJBv>t~ zz2o}I>S6QJJ*~GU@A_)@*xY4;>}%_DrXdT3IyjAQSMPXX`6+&1@U{QH>)n+qc5R7s zH0^P@z*yATZ{NAVCqX*q=#uu=i_PBctzkMVx@6V`XDdCyISwrEYx?`uI9?y~&)EHb zfzX#`8KoPoku#WY=RV1=TQBdUr@yPITEITy_x(Rb=815v%mc4wr9Vu z_W8}(mK$#Q{F(mmsP}c- zhunRUt5~HSRhzW`_kLUE60muJx&l{mlgpR$YCI=+e}>0e9l6_;rnK&%?cb;CA2Yu? z_W!T#mAm;HOm6Mm)HYlD{^SbwlfJ?G)4KPW6)o>g2;OFv8**uLi>BA>so~8mdX5!g z|NiJdbD6-u_L%5NK5EJs4x7ckpoBI{D>|Bdns=2=TBZ@*NYUhwXHm)h#{b9L(&MD5Njum5DqakuzPP@MkhA3AR*tQ1R& zRJPmZHsPc7nP>Yx@1J1c%#}W4>J00LFE6d%7MEl?W&Quc$~XG^Laolve|VTn`rzXg zZK_Q-c4RRmKK~r%;>7-%&59_me-wW&mBI!IC$<#S+29}CbRXg4lo97 zd#PV{l1pn9TV3q7!pKLz+Ji&vh4!jSYh+ofivLQIz94z5AWJKU`>X(K+1>GNtg zmF)W|ZgS%IhvO~$)-s=`ZT)H#`}}qLdcDh+FIVqz`ImS*EqSJ^N|i~N)H?6*oh%VN z(|p1-^7kK4D481S@-P0H)8ER%(&-FjeYOq;Pvs5YQ+y6i4^W@#w^Y?VWH@9ccY@r`7|6N%Gn}`h*jUBHuX$`A5o|KlEsBzMc19#N5gLf9A|T zkJ3{=ul=6nAv?_e~PNr4(0#C_A_*DU#tK6 zRDkLCLqVbQmHw6w{uV6q@Cm!YoTPZ*fo&1XJAHwJjVi)2Rx9$YRyAx8y#0fr+{XTg z-K90(PcN1K-^0J-_R_;|b}KaPIiq~*)}(EI2`{WSdhS$7a%YoqToS#;br+vw#P3h5 zQ>RKke>**Hf$V0LxvwH`i%(V4%t(%xdUGw+>e1Q-vVoQhf2q!YI6>0L^zrF`-|i`zo#pON$L~LA{=>@ieZIzK@%iqn?)iva{8>A}VOET~ zTVUCWWT}Qo4#i3Co0`qc_TA1mmA@wKQNP@4nS}JVdzI>+f;a5nR_m(I99HX*#vWQB ze)YqfC&H;+b03^4|7ZO8pm%Do%@pD4**ZyP-(+Syc*Nf7y*A4@bN_O#ibL(&?O5{{ z7s)G0%-B=8Zq15SEjGOZ3K6P;8s!r#E`3No^6%i67@@7pSIMtT;Gcb3?v?-Vrl3^UoOx!Vc)6;Zb}}OnX9kW z@2Q`%JF%(f>Lim}9k)wnn)%vp-|#l}kZeqU|IV+^=k@nL+cwK+OImB)&6BbcU508O z`Bwk6>_2NJKjHfflZxl{9}^GGuyNzQ7W~<sbiR*dU<~)?%-#0U? z`Ll&t+R=#xIo(eZue!Oo?>V{UOKPV=uX>u?6C4G&GP*a`H%lwLo* z^E6Ll@3SsLNJKt!R_!~blw)`_OP{R7ugr~~9F~{x|N_HkZ zpZ(vIH4w!b{_8moP7MWivz?Y{qekEeC+M5P-E+JYq!lR2`Sh0k7Hf35r;cjnW% z@BcCgbzFXM{iOc4lCl_~;J;FCGY^!X5%1rz(X>upLE-e)lXFdN5-bl(PU2VB>NQZ{ z6V*84?*3%svSo8cmQDyLkuXTto13D(#)WTd#s8Vt% zgfjcDyk?lXrEJFK+vO9PlAgCn&*rq?pONx#%^|bqzZ@$Y+m0*0YI~?X@8y}@on>VL zj@M1z&9y!4^ddfK?VJC{&J>1RoS^>p&>M&7DZch~HnTSFP;5+`?VKlPdPlu!g|2F$ zna8$VtK$m1TfCRnd9j)4&C$QS|95nnKz+cvf81&O0*~58vIb=x3e4;({r~2u z9qDdsaoXI*sr7w#&0T)IxP;i3@=gkw_qW);K3DZb?U>9GqZQoN0tc_=*C?ln=>0z_ zKlRfcZeGEVL!Tmr9n}OhSAN}_@pWbXv^P?Zy^cigY_(he^>y*ncjsTc&X|07{vUxN zhuKT*7k4%1oV3?H$LGn)!FfTV)AzZ7cZDMh|KF4H)34^&&;FDs^Z$|LFUNb~Y-aW^ z66WWuko@bRtQeXq@5%DB;Hu8^d-ks!8~Sftzpv%UGFR0rI`8ww)$*3LDs2}|9&@Ts z;+JyyAQIL5_>9!QW_!)m`tw{>drtYeKk}cjUST<};1-*6BHQ2RZe#CU(46T$`*pE^ z#;fYz@&9`}#oixJX;pmx$%Rw(^bgC40ZEBLwQR4<-Y31^sD6rNp*AnKWbGzlX{kHJD zZadR>>g}HEvs?pwpPc<;n!6&n!d!EG?aUdGX|`+@OFUU(-%UQ)@lZnP#f^1OdLxgg zPW>k)b7z{uA6vT@*Urt+{JZ)5bg@+rPo6$+9HuDRrqMR9t$gWe_A_6Uq@+&VxApb< z$0#iRO?}IHIhAmw8?MEn=N@!E78T3=u`JD@XLHZiy~$goI~C*&pUiN0r_tAK2d>co>zmb(73D}FOc z=cu1ZJNsM33+A`X9%h=23)JsmSX1kAeAM!R%nf92&@K*=x=2|~)%}L)v zx7F8fyy&x7Me6RY9VORpRtYW6-e#8I2zg7Lk1><86 zDi$7SHo3Elr>$&@-NLq;V)~|8^EH3oe6&i(eWaxRZA2n3UP_*9nGBpOV^dCM^g(`+(^sbI$8qHr|WBG4@4%JsfVA z@Kkcox9yTIraJK{vKlgWE!R8SxnQ69TLx#-lkUFnue^M8%HnkWr`{Fc_2y3gej{#c zwPAakVYBVur#ANsUrqe?L-4Wqp6L0Uk%AuS+&&c@F-$cbt~1{)^m@6skCUl89g61PUzk{Uxs#{B@Xa%*e+EMby?z4E(`q-d{dvEoy&Znf;gi$5y?tK{ z)OHsve;W~Qb1QJCO)|G;^>0(FY7a;0YSZ+jEN2hpS_dTw-sxp)zO3EVZ&Y8+X`N+T z?xFt9ZL#69wY?jC-`?4M_?6O)$a(vt-u>e$a*&?;k3FyLh4`{B-Ml9|vpSAfO=c`_=9-WTHG#)?4$>p!;$^Rmyl?(@R=?~B}pjG3RU7wx~Sd%D9)`tjG~ zw4EDTOM+HR{`^A4px^2Cf!`apc-H;o<(&03NqE8hxffn$Jhz@YBXR%h-z&eY-`!+B zA@oeiyo5cLEeB67G+lDOzi{678U6ioaU3OqCP(FVwnkMPtM$?BDqq08Eq3Yq8~gje z^#1z%pCj|xlSh>*=PM>G`2V`=>&eR#_KVLj__Q>_Y-?%Lmq7c~p&1`H-V$(p)ls*q z@TaTy()!MR69pre%8Iy}H5be8?XBJ(v*_%-CqM0f9OOTB|IgX`Q$BBLG{5h%HE-_u z_aCp9yxLjyX8m(NqjxsV0*|&{kJDbe|JUmMv;IDf|Cjo+b(OmV&&3~q7T!y!un3m> zZCW_RF=whBUcxFtJRzz1#Pj=`|KCaBNLi)|6PD6>fSkuR!`_ zbJ7c^{9!sDgaYkj`!G@pI!&p!LQL=9Kq z%J@jfZ63b&0i4@59@O6RCt2z?$05T-f_@5} z`_?7zHwaL+*!JRPjJVN6E~V1HLPr_i>%^F=^_2MUmtYPr@9k?i=$#}~(%N1X-+gb< zv;CPKXK%0HqE^&)%Wuh<7ZXwssjUc2yHVS7-mz;#`s`0v&u(J#oqtez;cDrl-#>0` zlZp;+E>oyv2H^&Sp&uE`-GfKKrcDq{z4R z@#cv)ES-{;MX#CC*y8-jJT+1&cEOLYR!iok2|1?uc(E~D+{Y=Swd@LSPt?^`yHiyO z_nQUy47K8%LU%Vksq8tTdEr^$zbt-BmsuB=y^B3wStI#!s>J0&F)@$+GCy~tS;7Z% zr52wK$=t3ranWv7#aj)`KRb_mN9X_1-+Ss(?dqiu_6KMtJvqNktY>=qrEj{MZpSqp zd-0LaXoi;IHrd}5>S-OU%TI`>A1stMEqMLu_YcK`FW>Cs-gs>JtJ2f2Z_Q;s;cNfq zf=ts71BI;tj6d_V7dr9Yu{!t0t)r>Aw7*Pbu7!)*y3aOe*_R0~VM_ozd1hBJ%o2G#Ak zY$wfLZPqjHe80C`@z=h0zn@E_&pdFXcy5jG`%Rr5WhWN9TqyT8GF=q={l|hg3b~~x zPoBHEIpH+Ji}puM8&8XqTYhBk;}eG+j`E-omQUo!A`#ITkNg; z`$u}1CfyG{`kq}l_gL!Dq_z2%UR=oku`*Ns!a@DTo14S^9(d|nM_(~g(5UOCUnxk}~smfdE}t0wRNqOvgfJ?D?3yAQ zzt8r*^ODwGo>Gas44Z!Jn00DO_AiyWM*I9rU%EzKl~|i=F0Z!jtH}f?2h(V)~8YxJ@@yXo|(GCdExpQnNu&#Af^*#xJBr28^^g*xhGo9o*2IPxT)vG z9wp9ujeRZ?+%7mTjrtLlvHQqX!L&P{KAn*WIm|KtS+04E^gQ08;~UEEdA^y-vFLVp zp>xnG7H7@$_VqpAO5=*G43EAPK4o&PehTlz3akA&-oI{?S6bAnxOrMUU-Vcpy6Mce zh(~MQE@@moVcv(WtG9m%n>sIGT7Y7sgN5SU=ldmXJZ|(I*tE-&<*al9?~4oS+Xden z&+seY4V-eUYp4A0B^Q@X?KdpxbBrkneEv)IzFpT}{<&GR*H`b~wpBCvoY-WSAE(-P zc(Cl=E#P>1#oV?><;w&nKS-C+aW@gDTWq&sXH&y@1H%Jf>(4aI{k63##IgUY0r#t( zz8O^wY$oQnHLFvkn?*WT>eu)$&Sjf*a`Txx)qg4?ot&&2d88Npe;WSD=t^m?EKl>_ zDP;>@rJQm1`@PGo(&~@zWPS z%9NXK72bLn`DQPRYUMueZHw7E6y7h1C{YkumOZEO>CVoq6Mlc0)oy=Sw=LtjGn>N6 zUY7#SlYV#DH8)5t(skMrx_{PxCdMm@JG(EJ2VO6;+}@V8L$T?|^PR#qO$yHU6q}^> zd$X)mSheKzj4qLmwTF+Neo|{)(($r^Q$^rlq|a+%=lhzhLg zm^}--`8VHt%Kt)n!iGvmRD=KX86_WNQ=|)gSU3v+ueJlz5lCfNK3Fv!8dN@ zki&KgY1PgwFB_#~CLZbddMYratY*uW9|f}>iNxPYR{O&zctk|;!yIA9c$UM=E)$+# z{IBgRrEHt6+Uy5%12Rx6hL=6PZJCSbSs z7VA$xBiU>s-G28+{@ChccVT01Zj0_+7R?6|POoPuaL%dpnfrU4#@#Kkx29&#mpZrP zVC3@$iMJMC5e=T&bS1k==H&FRdV)3tvYGuh)uvx^Uz%%rZtKOKvvABUJz{-webDzGzqaLR z+|OzK*s^cOf`hLwOe^iW=g4p=a`B!C2k)(XJi+0_&4;3DvkaL!IVEl|&x)5ydg6ck zlx`UJV~u+=<^J00iwEV;*|E5^KV3XhnPyB(!=n7X0p4>BHn!Rd%e5M?1`Su z@nsjDavxa#NHgBUd5(;HlI84QN4>kh720IlZJ6A*dg6_&ESY{QlQp)iY*x4DU;g`7 zYg=&6<86x`UpMWIn`HX%bOwv1gx?P*rH`811oZ0Oa=(x2?)v=JFLZ6$ONWw^21$FP zWySn&Ui;9jw(x8B2F;E30y6J94{WYo$Jw@IhLPololy;Dw&&(_t#ApCvQM*Aoc=*u z+I*&M_ZKefsUI)sYsIM^d(-&jMB|hr)ja$59(~C(yeD~&kQ(nkj8IjhYS>jg~c57MH#>+LF0^*syugqW1tNtC$ z6IIqH@IE!?)fdam+4rB7)p{7s34DHsKSR60|D7ja`q^5otf~EsDh#@NZ%^JYncFI* z*3=RFKk)q$XW5%ZcfJY5i0Mixre5xy_O0Zg`{4JlR0r>-ntT<_O+MIq=Yo~eN*@FpIdR|QeOW-D>lOuO-sUSl8>#an{y;y zeVSo|6U$V$2&+@OJ^xMF^?k$E*IJQ|MjH(uTtCMklP=_WV-k~rYSOi3#;cb95Si^D z)V6~6dZbQhbVRP<>>%@6$1|5y_0AqU<{Z1RP)0&C^|rIb$3StH8IHGD#cKPGu94%G z;i+va>;JBBJ@?jWtyecDa5OD_msqoC_RA}hNBGL*Uawo+zTWfgqb}j&caBWkx8Aq@ z(xcNY#|01Y-C4tbxrixZN_%bj>_bKOy7vfwi&VZcH7O@H{{p|YVgAu_&!R)`%i6bj z#xK0J=QY#kXPqp|Jf5z(oN9Mux5v{rn@ePa6xt0>ben&_eay;4M}FnqM}LZ&l|Mg; zJU7`~U2}z@RI=O^CH-~ctF12CA~lG7~o=GmN>y7!mZFMjviC|vS3`t_lkPxajMumqF1LFrJ?G1lQ(CcaUfuRM@Y`SRaq=X7o?mgF881CJW`DW+&y9HVM3%~} zKV5a~zrFQWsN+hF*_HPqq9Ol`z={Ayuc^DgxvzPZVlOKHU-#C!r_cUBtFbCk7JM@0 zM?pa0$CdkL=WV+f6PXexDF54dy)L^zbNfYy91S5Stux~H&+6ZP@n=i@2VTQ~-K(zd zxqWbXH+R#z)ixI#)J*0*j9R}Y(>N(6f8)`euf1RD|8L@Od%SI>OYCJw)8B=U0{=Ov z)N}~BhnAFOd$n7wsC&8gq>8L~%0<<$Z5?;__;vTK&nbU$tnnuj-CZ@KyBh<)}E^CgPr zCa*OPMIv@)e9jVLzw;u>r?D*Wc42?Qzu6 z;G1PvUeI1QLqq$H@Fd|&vKv16tXQ?vdy?GORB5N;1-c&79c^Nc-cV;sJN^CMH}6Q> zZ}Fd}%@h^tH)H#D#E_fqWWW~x4F!perny4C7z-Bw12lL>x3t z|5vW) z)Ao}5Y?quPX(pKo%Kx`%Iw!=Pe*S#g)6cVVuN(4D&ll3WJxRW2QvC0|5q*4=PLhN>RH&_ zT+z<;TH{>PAI+opCT*XwZ2M0(HpVB{!_pTRO%=bf=W%YP-&>Ov9iKJo+jwp)5p@xG zIpO8cqF)zf-uK2g3h+L45whccIYIwt*EtcVg&`WJ4%(I}Jlxk(k?irPqtDJ}#pD)#O{0_AcqFqjzh^&D&8f4+F-Rmi_a`p|9U&2==%f{c(DN&2;-K;&I_uT}s|9S@T=so&1GPGp*9-*7uD+ zm;8RKu(s4GK>TV{d*ma#8OO^->V;z*7cBglV5{DA?c_YBxruKz*&RDxo~xaI;9S_7 z>E9k@Z*~=1bKBJV{7&093`!CcCYE+CILjDbIx+mSw7h^}$Jz5&=UFakQ1Mti?Mubt z_x}t0bdoeRt@726mZ)#pePCJeyTa~5Ynv3#%mu;|Ll$p4^pWv!ICb0*{Sz8SuzTlv(ycGkpZFxcF-nV8nIY|d@x85)LLc@x`D+&+4_ zV*ZZ!Nip_PKINyZ>-s<4IKNiemaoaY{&;TqS%qXi%^g1rrkALCCMRT`Fnty9i{WuZ ziT#{rj!pUk-#ou@I&HtBSASo8vayaKInCm^lp#qYlHGudmw zy+J7_tE3m*?zEdGbo=;?d3$AJ7QLNxO_n2jPkc=CB{$0{)7%$7UhipF6 zc~1?p5^qb^USZg*^LkgeHmm0x$D<9?RP6F@mK~i}@JsB-=byc%+bri?(BJ;zyRY;8 zS$%Vie}&h^-TJS+_nrQV>)SJ;muWAnou@msW6#fq%8Yl}9)A|Od|=zQwsg}8*0A8y zCzV7u`u`IB$gybehWPTIy=8~AAMeA%zAEH6P_NJaJE z_1nJXh5sMEkgI=jvwNc5e-wZHXT z_su>3s)tKd4hm%5uG(jL^~v>O{^!v>uPsl$wyCoX&0oKNe#zcr-S?yFpViLWnbBq4 zc||tq`mT@1j<%n_KXKWYZt+K){C`)ztPQdWn*BU?;ns;^d;c#?5jXyF($l`?^Su6S zJ-ND&xBjdd&!c*M?!BMh>HhA)vAW*P#gijHsU*A2$=0(esI0p?V}9KV$tWMo6%YTo z6x;4Z|zh7y8{#xwkjb`;`$EWgmvAj>b_Fzq7=Y#M2|Not1x~C!iof=c8gVF>J6%e&y zyq?}PXG(kCXVf@}a=bb!%Sq4NRb+8;V)Fq=W*{K^W3CB|1G z4~y%^oryfm&ph=w!f6vY{_Ioy5a{wjEnC0-ef53s?}q#HMdv;BL|EsNAlT@|Ca&7# z$s#Uz>MzvIV5-hv&_n4*b=1blHDEr}3wE51uF?m0m%kUwWeHaL;kn}JS7hlret{oz z)tcP&WttPGv#E8P)t^F@#n^^ZU5iB|EH(YlE3fgGv<%-=Vr*P zv5gPES>iv>CURcovzec6Wv`!lE&lJ-__O~$>HpvK=aKmS4ws$>yxo!&6^tqU)qCSC zYkm|6988~IyKT>pN8L}ShR1O#z4-X?@o{BdV|xi6Igj@bd7c#_2QRy9qZgBEF4x6B zU+)xH^gMq1_N_wGsR?gr_rCb`z;qXIQ3YozW9Hzdehy!?IE2D z)_nT;e7?T^-Y-Ev&z0{B_M2-ZD&)wWcuc23a`jA$7ou~Y`lCj}D$A*RPEOaV{2b9Z zYfe^n_Uf2@H9PO@Dqa2OvHic~pAY%#Bi6<247ykQ{jRK1#Lj8o!-F)$qiz1L^kDJb zBjnh5f2MKzshgYAPn+-mdG^zj$^O$8yZ2AKm?84!%Kce0k2*cCL-tvxL-T<}T-S{! zZFf~#k@e%&*6gR>-rj!dZvQLr=g0o~n00Y`qt4B@|Nm3yU{vC&w&~NRHT|&tdL=kf z`p4AuHB0AM6fTmnD$y`XjhVUP%$7}etLpzD=ZXm&CLAXwtJLMa3(w68<<%CP!jhMh zGbR4-tMI4K?f+MxuvVrb$k!E%*NK6gv3Jp*!hWR>T%olf`XO9a8G`!m#`ePW*B%3%D+-G);{@ zxjpN{o;jx;ls>MGHHxU5S;+G*%rESG<-Ol_rkx3A?>u6zIgz(8t!8_6r5?C=0BaX& zZ0>V->h)>WskL%y6{5=LuUAaked^?^()Cxryt1sH%%Qhv;%}6E-KVg@A7@27IFCz7{SlGOF**FW5it z{}q)cwFu*2;q{WMkAK~@|7%R|G$({dpUHvJ3>woB?=Rc*i z?ynL$T(xgir@g6CMw2P?SH`_MOXveOB9r4to9jaxCe?jhTo4 zdGU#d9v0p2^}}cJB)9cfKhKvERQVh9d}E2~BAFk?eajVfO`Mh+T`7CXGt)7Kzjv}C zifIcR8E%q<4N{vQT7hSrnAgvuK$UAHn+B8!G78G(JV&B56?8cxO7?)TD(Ci2Zl{o1RTq~ zA|=iLXm%(FnXh4%Ryr|np|4DsaNl2}-x^9ccFZzNTiW!mF3V-Z!&Sa=uj17VuHRK? zk!y*v@O)4kQ>2gVW>=O4{+ClT<_m505rnjE!KOS83YU@!K z0nY`}?VmK&pWi$BChx>YU7wHZ3<}Go|B0@OPs(fxKl`Cc;9Th8uQ3dNGCf&7Rz_6V zX*~?;Q~GG_d2C)nb>%J1{=#MD&9P;hc?`?l7{uizY?W7aAcDvz+e=aem40AP@1WkGro1*X5?L6|3?fCQK&7YJz9`q_SO@0u4ig~WxBiZ?uf^VGv zZ4oZHbi&wRkMRk%_y(STAGd_hYZRC_;oH`2i5o6&TA5OC&9!7^h``JaWVq%~ptUvIndSCVzvbcQ7HjW2JoEbmj(_%dmlkn0SxEaoi1gyyDw(6w zA#~8q?8LbkR~i04CLxC}S;pR7GwH18xAU9!da%W-E&jjruI71%AAQP#DSq581z~JQ zO3S=A+&$s?54ky|AXvfBsHxrRaqGjjOLC9<{Fxm)?n-bz@!{3>{7wUFcGnT0tQx=-h?m72!k6mdGSc-baEDWc*A&oZkw-vWwH2WL;)p@v=;?vIFc8?A_UM}KN^ z)+)LP9DM5MSgej*jJZ5;WJxpTj5a@!kZ;Y>tn)JZ)ZKNbiwq)J*w2a2oLks@d!PMX zo&P)LcPx0vZ;Tu(6FA=VHMkTAxoqfm*NfLJ_s>o{-TK#w z<+mqG`RY$L(;@A0aBK2_3}X)CVYdyz(_(s=gx!;CU3n zTOafE`Brc~2G<)F7dUJdNVzF-aE54E%n&}PXx8+6qu`#CFZa)LWGR&2oUhVkDEE zxCB@qe9Ee{!&bd%F{{##+KvbRZ~41ym@IVg?>fbZmO#hVoiQUxS+-AM;$sO^=EIVW5$gXWT;B3~ktFN$hB74V!HR0=m zMbx|h*uG1yQ~$%U&!a6S>7D77oBu_{Z=8R#>Bt=KOG_s%P)I@Q`nWte%&{dxW1SaE zwVvVgnu!Wc+;uF4^2M@FUz;}t{;T`ND&#ob#`0L#VeOP>kz&qut&i7l`ftB{?I)IF zz3sOy8$A#&??|mY5_R}ZI!RCO|k;jnTHR@QGgwc>4O|y+uO$HAZC|+1}U~}cd zXt^`ab5@JLI(h%&{nj_v=R`GKJ1%9H8OWN2pwdOcp3S`<-vE( z#*;ZU`z_w`@vID$diP{~^;@IK;s+bk-h6R$_PAp5=i=jz;ErTNFQuG(z2PrYyPQQF`1 z-Xg`;aEq9e0J!2empypw7lOWu{<> zK$aU5R5UsSQaqKO{}glC(8-|Re1J8wi@R`|HHYc3KjqJt-^}z}^6dGnC$pRVY(2Sn z`JdQu`YBJc{yh7UBzOIeC!(CIRL)i3`F=fMWzOW9y$U;b%UfO6JU{2?W}nj~v$o8N z(B)Iva>wa6mDt~Ucu+gPp@`qwEkMk>mZECD1msakm4;MCH*T!-= zxnE1L~1CY*b~P*?LC6#^#OBDwhe(J5!8Ij+i!r(~S!Q z$RWlchy3kkc(Oe3a1_hTONY$Vn+n$nGO*2*I^5P{y4*J=@7ogpNoy6RxlKrJ?Gj&k zyUD9`T|uA7g^e3$LvErG3*{I+<1LvO=66U30oBwcU$lZqUKT>%OP#JANn4-=F+t&Aa1f z`dGVe>L9ydGhzqZ+({q6&spP zjJmR8;m^$$6OU@Nxh;G%uOs3dmZU4mBy`YmePV=TjY^Y%{`cF)A_x9#+n~tv%UInl z@JK?Oki`kP+blsHAJ+6Jcpp}XS$g7hz`kQFlTYpt-#*jD`J~h=NtOx48HvyLtU1}; z6Syg}X89(M2X|&2-{!=*MrXt6Wh_P->E*K{PY8G@m7WZ~&%5l#XPNJ1p&7wyr_-$N z7S6BzR@1?6Tu`fi=IXIccinvR?ktnBE-V7Ie)()bO@bO>4+f#ezugWKw(sN@KN;xU zC9>k|426X*0!>H$EvhPM_bhC72`GIz!`H|><#v;g-;VqvYm+;swiH;rWxr@_xqjxR zDW`jb3;DXle#?a?&MhvvJDsI!er1T$a^3m+g%0wyPIytO&@{=edozo4%(L>Df7TXk zbzkItNag@^#tdWX}g`6W=-gJ2v5(C;M%m_{njCRMIuB()SUE*rd5K z=LI=YlNKz0BM9K^f?F} z%;5rgWW8X9|AK_#i4QoGET*wIeT%SXDQe?Ybje~+%sMf>on)Ec2(%1=HDJn!FN>-SH!L%pNA<*(jLiTq0w>oy(YsNb93c|Sn8I5tW0 z+`80t6NQUsx)?ZsgZcvllP8OOgEGHRqf5el#Re7MX#1;sZl~1EzOU;s@se%lt+^++ z({a(9juG1MCxii~&-vwVPpPszFb&LO}W0pI@XBIhWg>DaEoqg=joea6_ zul?*^9^kSReOaNmq<>C;)QzW-wRNiXr{_%MSfwTx$hW?-uGd#{!R^4jOK~4KZYzG9 ztFrgV`_E4@=N<{SjB{+-;U?7{nUvr9+?#8oLP`gGo--KS&p`TY%p59$H4J?= zpc2!cmyzSt8r9H8<~OF49B00}&7*wFU$d^XP4!?ahj`krfTkkZA*K5XMeZ+ zZ7w0|Zv6he7W?CMFAY5A9(iYW{axWZzTe^(S-oGaE46y6_I%rob^Pp4*S-td$sH-B z=qa=CR%ouxlZZoRPaZb!+*N*DwTJ)v0UNXb&v*77=6@?ZG4;)?O}m!Fo?zSCpZ??g z|6&!VtnibOKUh@u`M+{{Gsi>eA9&ih)DHZ4akbE<03jk7eqsn>q+iDzHG@N<>x z^P6U^OP;^uSZ%w;_U~U$I(n;R`OWe4`J+}awd!N%uDKt#7*A{d+H{bo`f%iF5gWs|+;gZE#)I(bHw>9+)9#lbC4OSsEacs_S> zt<7XFQt!-GNnGVOyW#0Po1-sxpSYwZtCs7*A~@M|+AWW7U;2`&ggL$VyO@h5``XXE zYCYrFmFMWG(wO(YIFGrhcz1aw{6c$9y*Cy(=xp#fctwwDqkqx;%NhsyCx5fLEqH1z_bgGlTa4W5Q@13v z=t{^>ujHB57O3~?V6h`ht;Hg@Pllm9QeNrF#jAckoOfa+=bJOf`b2c)6+06SOsE%X ztOXS%wZWk?FS;cBSG?e}HDigN>XL?Oj-7IAm>(@r$=ded_qyJPvE8{{im@NKT>OgP z8yN5`smfsv+Hv-8^xd)*jrvYL+a|{G-pEtlx%+f!=$`3{#?dN8lS^Ck9oK|N- z2ZixXlpuZyKD+S!}D=FSeA zwuN`q`dr=%xjZ+^)c9B}oTMUnr_Dr@^G<^CIp0fD{@iVSAd&A=745+|*M@2TL#_W7 z&nK%|v3a_>>Bigd-t{Z_-@l%=)b6r@#r3w5uT3&i?X?kE&Mdo+1Yf!-a76Bs z*LUkUbKh^OZ68DAELtXbeR5l@_$1%u=Cahs=iF|}xoIQ7`O=rq`2?aabn;P0LW@~ay za#|y-*pws}WVcbF*Hg9S&o_60z>`Y9O*Phvn4CBHYI*;DXF&NUb3qT5Z_G@dEZ?1V zQ{{vkYr7nzCkgg2HeFovC{Wd}*XhRoNprl6|CCzp@RGPY(|5*GZsR*nOKVzRoA3B1 z$94C#$NqN(f3%mB&YoN-aPYPVqiTJ$%943W-mUf~^q z<83ldEQ(#fHU$2)c6emo$dQ-t{70en@x>i?c9t&B$+@HJ{6=E^-CdzpiUvNfQf6yuMg}uw8|9)b59)GB*Xl~8U zq>~H7)|YsiUpcl!)@AM&w<*4x%v<;9IXd0;t9dACy+r>TtKN?UhL@%%Q?97~JOwJO zf3r8LH2q$_&S-h(fql*k*3Jt(cVJm^@=E6&;bBL_-HV-$*_miZoD&h+be4Ble&OvI zB^z%COWn{D-%-{pa?f#D`9x18uYdQl*9*EUS?Ea%xTJr0WtYY(k_07p1nV1w8^NBf9=|-Q?FhP;MZTjo^@kz=$<`WWS01E((t^} zw_$aOK+ugw885Z)X<;4BQ{~UUE7-fL|D?bZUiYg)j!P!5YHsFGV%<~xI&Ww3bF=4c zPha(}PR%Z!oVz;5kt0-+pY3+4#~;p|GM-AASz@=BtU5gD`ya^&P*BS zTPm5W%BsCyl&rnvd}upMWb+c;_3NgjhV1b6_D-GZ`)HX;erlzp(+&OC*{@SeQzci* zyG$&W<(Ty3yoJ!AKItccldexV^z6p-FP`VqO|%jV8f-KbML1Q{4<{-M$~gTBVeMCJ z{T{%3e{c16o(UZH8aVQD9GJFmJGHmEywg}qdbaeO-QvHS*E-&Owojpz`CU7Y*|*kR z-7_5?s6DlCDVY1*_Vi5knK7RwB<#B9eb<=b!7^XX-2G(t?Zih~o+Vu8eV9(K&#ByZ z-QZkQI=4$e=aQ@%^_v=^Q(k|c#L*Sk=8|w9RD|6R2~9H*yphkbz;Dhg)$^q`H|F$8 zE!kki`jX9P#SE82c3RhRALTlHS|{{f>&W4^%qNbrX~wiB#47G9YnrZTz5T{EMg8)C z!afB%WtHfMYuq-91+BN6WXpM5OK6Ysgk7p9?ml#GKXohlxEFs@xkTxEt4aHuW32bo zX)I}2EwJzEPM3n*R8x<{8~?saKT5CamD-_LDP(hUS=OTtcgZcPPjsF>+<*PGnSHu$ zpW<5MB?bSy9?a1(lJh&I7Ub}jE&u+$U^B%=x%)e-xoap@Ry|mw47Gmr5ychD_b<>l6NU2jjzvavP23iduQ^i@NtQuHWd% zw3YEo#BY1ervi%(@97B8-aheO>#pgYa_xOGT$%SbD!ZThxcGR}mAMw5A}T-4e11yn z$oq}Q<(ehr^xXO6_4;Kkqki4lylIcf_m&WTp(P^zi=Ho;sC9QThm=YM{~sa!KF#Sz z{7&9yZalqARAr*Kp<}bfF;fdkx2fwVd$3K|`>?>8Ce%OEI3d~pg87nS$dUFyUG2Zs zTwms~{SSWf()E<4qRqj|bOrDKU*cErA6IC-qrbHOm2|OzezXVE&Um2}RySYYU1lMs z37TSg!weeLZT32)qsH`Guu-AP)+%FdyeQB~ zQF>!n!&a`j(T^p)6aI)SdC%!_Cpbsnfn_S6-MO8UWp*2#w7P9HDN=K{%7v#NRHo{t z-|=Aid4EOAPC=y?DGGrHzb1prJ9kid=RS36q%X@iVJ5GRHrbr_3dOk|vErf`2CNwm z)KpF{eUPUxaTg2Yt(FiC&OJSgpL`Zr|6S22TtV^rj_+L8zsP3DJloKwRkZ9?Iqz=U z6ZcP5tzWZ#-Qq{KA$|@&_%`lu+x7j(M`4d2VW%!8_p?5{ocI32MdhcRi_iXa7B~>9 z*1TpFQ=D_}8r_F6i&jYZL_NMD_Me@3R`Y(3A9kzk#2)KRa(t{G7riIGH_PMBkKAGd z$6TAMcX`d4ojV?`?X`aT>1+0cLvM?OH6MzqPqEni)?l+zUCCR>aE49Gq&C=PdJ1(awrrvQqq!fcGKCx_jx14pj?uX?q+BVZQ&c?X91@ zs+tRPncF1AzpvLD9(>GER==a%vi8r%A{nNNM=z3}epz{0@uhXqiww(uKRA~(Yd;lu zb>GgoLACdE_UfksS#jz7`VZyY<~KYPpOD@*-@Y!C-TlMzA}QC{&mRmne*SX!NuGIU zLhtv2JG1UdFfFTG+&_uqn3i(F;?3!I-(>h#ly5kAsp9b_PR2d$z6*j5e>|3UGiBSy zT#rZA&+qGs|J+;gwyN^`-_JjkU3zOivb{>ad&%Hu%Bfr0OVl66G+kNyK}WS-$RS(8AvXC{1_^jM*pH*c%WkrUun2?MBA zvS5-?cjp0hr40@tc7}Pq0iJ%g|CYo@&TwRUz#qMsr{{31eT?BMmkE)(bVDZUax_nJ z^z7A3Tz6RV&{yt@_tGvM(ap0w|Gs)fg=*9FnVhSwZhUR@WzK4uCDti&y~^iKgyohf zKKnA3&U;0czpt$P^kd`Wr$>^HpXNS4PuHDa-t}trmN^!MMrrTYDapQBB$ns>YXf6U zV@p|Jec2Yq76Gfz+cgDKAMFX+%pu?SGSB6CV$t_ZfrAGk*J!_ck}F;MKH~XJ4-WR* zXQbScERN1A5Y~L~Hro7D^m|8^jjDSJ-ey^rzpGu+`2EzyE zKT8`f3p(h<;M^A68@ zm#8z1*DR#xGRC}@UmMg|Fa~$Kn zCbO@hfBJ2g+IE{g2Wz+QcyG&b?)Q>kjhPPTlnU~9WH|<{Xnt<0QoTCoc)z^@% zH9OmMABvuMu>1X<=)8qScIEHp7Bzk@k6ioY+}_@z>d$eKMl(|yUhOqaooA}`oA1d7 zflntEPk5W`p*(%%a%GE!|I(^kWEF#)!on)0E^TjX`J}Q#_wc={E0gPZTMg5E-EEHx zX1f@>c03jouzb9OxAIN#{-W6JipScj#H7B@ylKPWJ=+&lKK^hL@KE~EdSD*EFN>XA zqwU09l|fS_YHCh>U%xBmW}K6%rm|YSiL;flry`G)_saLDd9~C1Z|#hZP@6sb zgfT^y+vgwM1%1?~zL@jtSg*8UaRgJv%S);emNEBF>})XQjdS(D_;sv z*d{(b?6l;a+cJvr=Nn&IspPfpn$yFkD8N(SWqLTJR>Wn(>m%6{^PE{yt9J>`x@h;z zWkT7d#kxm~%D(;s544{bZB%KRuYKp|2A2mH1tz$>)jT0BcH;2jJG(ucQzfEWw|wvS$93YJvp>Ev)_NKJXYG=W^NjmV_Z_)fyZ-0vZ5}MP`)Ab2d^m10 z)$3Jxfclkx_fj@>{GP5KuNS^PPSeVzA<_3FO=`R&2>ev0>X{pq)Fh}}y}I>}&t z*l&&Ap)BPk;_s4AT#vkDd+MY1gqPDJPCYSv^(*y*E!#!w9c4mSsP=~x^WS+*+fsRMDc{+e;r;yCf_KHqd!sz&{*-fKa)0q_%733_?WauD%wv*% zYwlxQU;K`D+xL^}pS%~E_|8GhEhY8TnN~4t**S97v%@>@{rXi^`S0g*=exf@oz|be zIsJUn?{X!Mg)AF|4y>|Ur?N^&P3~g@*Y(HuRXjHN1Rr|3xu$QS*NauNZdh1#tb5|C zIrsauvp@2@K4h&Z^j$p3ss65wy4cqp(@rN}HklE(_uaI~LJD zsZ$R57t{ppKKQLgd2YaEwqsLHeml@Bta4Os(c#P$a+#LVGnp^lxp~9%+!gjz(BPy# zPoqjxyu_EE4_qEB7W@&b(zLEcQBdZ)YGcoH0ms@?8@sb+7|IqsnXs>S%kic6++^<0 zUNimlji<3Gn@;Rc>Mxt?_`lTcKetPX(Fxyo@(wIhWxigEc-K2~is=^FACqc8u?1as7c;^7Gbbb4mL*eJiM%dM2t*>te{Rl~XP!FI_zCdTo8S<(b*P z?>*1=-Tvso=Tei}=~F%Q_SQGvJo3I(<-^?X_cX)T$7)_zXnI~4QY&rx$@bG~6GOEr z373xtf6zQ}N_j=+{+3zyJyrFCA1|N4W@g91y^nKd&Y^8m5gKP(-%R57jMFjAO-?(k zt-Nv8-ycZ{_rDok?lAcF<0Pn(o^Q?M$zorA;&Wr?0d?gK;Yurdug0l1l}>xE{(M=d zVJpia%ZRcyicMS*Dr=okf3&d2A}90yn9iNv2+8-y0cpbW<(jIE1k+_CslaS-dn5hNF-n`gZ^=IYsd0dxX zuV;xA(okE~GnH@F`dyKHo%3g3&zdlWPjNx{M|+D&6N+Shs@8A6aj*7yjOF)p)=%%2 z-`BPOeO15w%1KtvwO?2NePEa-xxV4Buz+JNpWVT4QvDTkUavP4{u6m**Xb+o6^|TV zrzWiE5x4pDk;EnS=hV`|Og|m``KWY_h4CKw{hhNwtGOQ(yC`%%c+OE~rzKbs!cu46 zsSqUNaoi-NvWso`(sVcHRhN(JZ8&^NUiS}U->J|yXY-2xwrhy5S7P0BYQul+ZPqUP znI7KE@(!9HSoq#h#(BNNhk2EsJ{EmiseXFp0aILs{LDImc8EAF)`?bpw=(mH$T!m zzQt^Oa_(*P({s9i`0wp$E%|Ww)3w|A(~I->2iN^NJ-=<%k58#8%^kI#t9&L3taE1h zedS@`tI+yp^&9)F)SKd4Ip)pXSR?zjn&wLUg;8GbmQ@wf6^11 zCM}nJwBvf$$seGt8_~)WTs~}XGZ6M*v8x4DB@d&j`KoK#e!1_MJy~Q152Iv({yTQ?&-u8Jy+TX&9$9}r@KreH(pL#5=LGFt z^(%Cj+Rw|i-7NtpXR%y(E#$C$mEN~|u2VPtG<>TiIOTw6m1=X|RbM~Vrd1tNr)1e@ z+T4BhL%Y)?WKvY;!k1Bb%XT;XopDmuLoiccIp$c7;?fY`nu(zv=jJ+Vo%lAn{=etW z#wj2Ee!s6Do}as6iEL`>-sBq#R!+CO`ut2%y72xp|2$XRyPp2{Q_}3Ob5}0Ayq0m2 z^W0G7w@c4i*H~=1X`*_e?1JgCzokAy!I(#yED=`3hg{6i~fofvnct^6#G8XKl+ zwM>=eyS{DanKU(Q0@w5&=g?D+RT@s!m`OZ6|M8D>&i^*s2fOE#zI`y?i*K&Yp|a+a zY{BW$`it4@zE!N@uX%N3^3yXn(~M4d>+g%0SM!QfCEkN|Vx6U=%ggYoIiV}(rN&IT zVCyyW?C*SOm0+)H>tc2awY=Yz{X1@lK#G6ph9jPjmWu?4ZVcL=CH-RG?3PPsOR`o} zPTmmOxm?B1Gkz=k8ndQV?Nj-*1Z|iL#TJVn^j*2~$c9_Iv&ww8+qs`<6ZoR{B*wyR z@v*qVjxFz{SiaqQy85YBYV~K`G*M;MDI)uRezQDPvO8vH$<7=HslOZ&{q7Has%Czf z_t5$Q$JhTtU;o6Ux0ZINKQ(=F$csm{*?-g81sri@d^;z5bZ9@F?ZEQ4A!B2dXZx3^ z8WZrkLwz<-h0OEr=M|R+$$~dPyH4IoJgd(+^OfIe75hLWtxnO^3ypYb$)j>`t=LI>X`|kg8$=i`3bg{PWRF$f= z%K|U2kN9cbSYrBhMYjBsmXOZ<XK>UgF;%NJ3A0sZ98+Hwt?cn+*RQJE z&KIs}uTU1U=UjMOfN2Bg%pVN$#rDT+&#->_xZR`kUdo*7{twu?S$FShnQgSe?#Q#w z<9$=t@A(o{`R7OHr(4tGboKXsn_Bed$m6F!_4h~h$=dda1Y{M)AJr`U6d7tHAuj%} z;%>m_Ed`oost%?S&&_#5MgMfi|5>!><1y){x+>}We_dUlU*3`Nc+0J!u zW}Uj_t)zIz>92KAQ0I~JUprN|=l^+i{b_vNAO5GGmU2Jsjo%Zfx38S@>$k9-dkg!& z_C-FID7wBpZ0cLtWb1>*^OyAgvCMj~d|{V+M*R8@KC$O4ZtviA%xU_1(Z}gxSHRM( zKfz6#cpfHCmi-cUKCk>O!8rYNR#Wr!IW>m!tma65Sak4Al%K(mZGnwjr8aucG)k&^ z-O_le_|}cmkBi-T{uS~onJukK-sYRL&Zl3sGIG&c#lYL|jCXjgm~tp|x%B3Q-rhB- zjh_WxA5NTDk+E8|rD1l22Gh%)Cj#|#Huj&`4!$bhblCX!l;zxk1-?=5FI7Ka$vhW( zs=WVkx#oHQlNVD@9PFPU6sutSm*rL4lI!Wy^uJ|${k;};{gkF!%bs6L!<}Y*y|sG% zRO9qQ{^q;4gFUvY819WTSIKmYV>jaa;YQp!cg^{yir7t3!JAmhgF5g@K$ za>*@;p;9+lW<6(KSo!FW_HWI_7d(_syjVVW?vqocv2X9G%c>Za+^blYeC%zJfNlG~oH+^Xpr0l=as-b&pq-&<)NfCp>v}Ij>yjKZp0v zQvF)Zjt8sP@7q-z7qs|_|0MO5pSBBaI*W02-#&7hPc?7-DGFCQ(UWR+yXJ!WAK^_!vYA(6OxG-Jy>fG#WJ|ZrM3)>>v6H4x z+PUj4{77^Welq=f@BNkRTm0W=cPz-C>Uc=Z`t#xwN6+oEe&!=?{`lLhmB-vC{(LdX zbN$6%&(Gy6MA;npzD%*{>?y5B583DTXTB9U*k(0Lcl{2T#g(sXR0MNsiiA@AvhIG4 zT;{CwK!#)D2_?atS2w5dKAXwETcwFt=I3{1P`iENg(s~p3FRzm57`gr&07}{bUd#8 z;?kE--quO#Nib|_%rZ3I*1N^^`00q3$5$*=e*U0e%`r-E+<8#mefHpi+}URx3k+xcIlOS*=kU%XS)-8mmM31a`zhC} z+C)9ynbmSVtl-BUx07KvWm429oHuN~5&Le}@tyo9?n~#~V%>MNZ2NJCQwx^LzMIqwCo;U!_<3fgv9++%Dyzx2ow=T`UpQ%>*3C(4t`x^julT!dp^)O`Rp&oS z3dwigTVMb8^#isXuKStmG6}F=1HOnNg zKUqJu3{BR@eZCRUnPh9WFSR&WHLtS%+vfSK54Zj~*E8*pSD)^Fvx)asANtPn_ETux zSK}YKQRgM+eU{1nr?O^=yY>4GUo*Z78Fg}l`2DSc>Q0J z>2-2>s<7Y!`9NpCAFr(!p1K{jcJXI1y+~sh>$Uwx1S$$y3+8#NXt5g>$a! z5{HAocf44cSeUslD*yZG>u*e#eE#?O_1>SeIdqgJxD*KX-tlLVV`QA}XKbPuGOJTq zt4LNxm_P4*w#VU}X!!c%*A z9wsL|{=wHQ^RB&FL#uZ32Tu-m8-JtcW(gXBrF$e^J@|KEXDf5(t(q22&jp8Vx8yiWAx&i!gc{>kHsnhoLA-l zUX(wo(!Rd#>uN>8klK|~0+=E^J!LP19KROOc`vE5C%j+#=E{%qU$6gu{aGvUQ>1Au z=fW2E&Kv%9pC(V}vTSsccI2G!T-EWI@qSZzx$7o!ruzFmZB(Z{3tyyrQ0%n*@6Gnw zkF+mNQ@9p+!nF2t#OJWjueW;D-4z$^pV|_oXRg|?|IbtX#dnev4cFuqsT_>^E_Zu^ zJa@Y1;hBg3b9R1=ocGh__T~wWYwcsF@9>T}%m2h9BUgEYcQ$`z_#S(qWfk!`%dVN{ zo=vvj!6q>`taFFFpY)#O^jlWxgo;eMnmgB7@1Uy(OQOfA#Hn|Ec=c&25@2Hy7*lvKU?ZGQ;AM&E=x`OO$N+&ve%>7f9kW8z}&F2{vy^G&N> z6fA$V_uIA4j;CvvwhOyWGJLg3k$G~KPUx}b$>{r!{VKnw5#6C^Y8S14y9e$kTUH>sqXWnP}?2m;;d{66~(>R zFWi!DV0zBPa&pqKZ=B+0%XOm{e0#c@(;>)d_s-(yyBGhwbZFv@$CYeT>^RcxrR?|x z=JAyOS2;8Hf5x@>411T|JbiCvabWF*qB$KJ8|M4pyS#G7v1YM}D-={_rCk(P@aUS_ z^KET{*w@ESKRi}nWC^-tZr-|H^+wY2*#R3}Ooam0YUO&|&Sdjfd%MzQ>o&my-+mpv zE2Y51!Bn$U@XOB~)$evbXR25zs3Q<`meJ{yPQP$m!qPuezj@tZvN{#T$70J|wI$&j zW8MGX_w#>0WpMUh#5a+_t~Pl2tj1N@i4D85tPi*!=E_;D-}~V2_xty!-OWsXZFg*H z#?5@~3mbx@9==HAl;CBsPx!EM`MfNLoBtf!y`DKu7EXWm>80cHPVvqD7dRhneD^No zQ$d=L?!#?n^RHyt=lE%+|FbY)V!6eY*jBl7!+ZW#MmxO*_wCmnO^-Rh1NKcoBa z{J{HfB1@W0Cx7_(=Ay3i@3Mm`djFIEzLm89u;&LuBSQ*v;ZNJ9$n4Lbt{sT`6a1$z zlhu4_>YvGsd#Cj;Ev#R3-XMx;``bfuF*VB8x|7VO7cEbIJ;__5_xG_K)8@u*zkFa3 z+Z4}xn|FzX%e&=f_jAU)%J$Y~e5Iyif93p_?Wd&fG&0$8@i=U7?>T54@SsS;!P_yy z%5cX2#BC2xG4gQ>GECd>Y_m++G>2~6(!7P%BAp-N-c01^@;~(8e&@GG0V<-2-#Hnk zDsk)*K50FjNjFJQ!`FF|$+Xr^!_0H8y9HZ4ggZLDcyv#CG*4a>ZV(iEWXV4Nvl_;! z>H->V9~P}uNNVYQr5rsetSREY?6k}G)+F59mUG?L#Xsq$k<*VnhCdf(ET<={Po zfh#w(R;%|ISH~*bCT+%vAs;1`eKW1})c>X%>D#VhVaYtlV5xBaQhw(Cf3Md6Tg9j_ z-R*K8W7n(oW*VEebe?+KzCPspRgTrauDD8Po?q~Hy2CcxrY-AUoPB@K@i*u1Ew8q3 zJk&aM|9!WIFAnXBdiLO8GcU)#N80G;X zC#Tn^2`TKb6;3z$eC+g*m}i$JHfUDIFgivn?uq!3yXEJ(`4)Bi88dIyoX%lk5|(Y4 zv27;5=J|gPiDx}_q@0spUA5!ENfEz!fByGK+AiPor!V`O_=```8{#)KD6EZ%R`6JM z*3wkxcnFizOSX5{mQR(w%;%6Fdx>ND*J7#r*Se#N6taU~F$$PJ-@ezBcTwe?Dc6`T zO+I-)&O(??f@#mMm9}vgR>g8k{gr#%aou%KhR&Hsm!tVqq|P`r*84Xya{Q~F#iPi~ zs^{65(4eNH?%80FoHKoa&Gs!{s;$=l-XfE(%;3isut)mrS!+&fiH9@hhTL8K{Cruy z`ahpXj0ZPs_D|Rxv*$uii;GMABB>XvZ96M_SUOY=Jm_Q$T60zYqcE?Jox<%&G3VqX zXD?I86P8+QcE~wTQF(dnOhc~;45dQ8E8WwkIZQXXHEG#IAI8bTJDH9t&fHRZ_t(iX zjh3(r_e|Mc($drQ=ZLTg)M_$wJef9a^_J{efo_%Im%lVB)JwK2M|dCdxB2MuJLyFH zpQG_6*BK|CQm?g-m!I+V@aj9O--_9uVJ>B^@=Lj`eZp#vvouEo^SyTpDO?QSZbzhk zy}ja2-7PO>o<+>P56;*B`@AiD!?%FCqDLX+FFtI%p!%UVOuM+Km}{@;w|h5aXRhDp zVkF1AQ+(D=o|n}(-K(_{-5%sT6Wseby&*wu#>}(Z?z_ZHPY{0)crN2!-y`3LX@C8u z|Jm~9ndaqZe@|2^*1g-dClZ`pVMO7dPQnsm;R4Gj}TP&vy`55j|Vr zpRea`P2Me2d~U1P_+DCnGA3?zRN2#aXU|3&Ew8*UCGN4z^3EyWd!-8(mhi3Iu&v?6 zYH`>5KiRw*9i>jDNM2NbaLap1$>WP%epAv+D%p$!5>&Z(912ud@gy>{>Nz$FcFQvw zoepEUzS7`L^1~y`57+d!XzuoZAJTH-;~Xx_IjQ#!C*EaeerLxyxi0-rOu5CJInxfG zynQrgtKe7Xn0C(~2NUMx$Lht8EDmTh6lG=k3V#XCzV^)N*~?{_(ee+rlx5{QTu(6( zu-tFKIHz{kdGF8mt8aF`@Vcmc*!WU}fJ94nAFIj3s7QO;660_8Go@IUx0;QQ zd(EoNw-n>;_n5TBFNqDGwVXlY)|G>T3>W@3?X&pw<8lA?!oXuC;Kkv`2 zq{++wYzyD9{BzUJ2eF?DE*;}mi&MYn9$dAu@7Lcg-zVBs?E7FeW7i+HPxV`-*f3@P z;$^tR^lY}i?``+T>G_Ji_m91>zQ}BGXU_d^VgHugomg~jv!?KbY4h6>DIA@kV&bRHlD#(uMiv zFzEj|u&`p*K`wTgpP4+3hnaL(4_pa!==kq-=4gY$2KFC6a$@FA_n}yi7K_U-;XkzF6?jhZF9MP5X)`S5CAvn)>N_N>a}0J2|&DgfJ(~{2#ZZ z@9FkL>z1d{iEqmVx9c)r-x6z9AA9>sL-e!Rm!e938OW`*5%35$7v2Bn-@H=~xu5E( z%0Hc2Dq^(C4f!!=DcYkJ9Rv0j|>bW*Da>R96Ip1+;6xArOo9?n(>S<2PqvMQ@%MX{wF8Skj z;Iez-AAQ%!-=aQQ-mEsUxlt}6R{a0E`p2F8A0}sU zZ>Ol$vWO&1#UpBdKST|*5YLdyiLXEQzKDBAA z?olnee&UAy$*N~e^$f;RSGP}-UBxKWx_#;GGcR4^7je!#%a(BB&Jq{zfY~44rWCA; zT^WBs!(`%1ckeqf|1K84-hAKJY-wDEDuV>?mVawbhG(AHc=AtMOv}7@*WHhvmSknT z4Bi+Ym3?3m+xZ*jA4I}0yeKKWWjifidu_s@=bvx0bu4ZDn40-iW3|tVdp=6XFXeL{ z3reW_yY@ftf@QYTO8-iIz2(NehQU`ylljbxEp}g-8n<*t3r|{oaIxi?+8$4Prus-P zKehYC_a;ss-aW1qY0{68@L%5+n-!{v*A#~vB}H*-GZmoFm^5Xv-I43VPEv^mZe^cELl_- z)`aaBTbjuFYzHeBqwOungbPNS{x+8e8g1B-etzDzEj%wyH1qlXn9gwRuC{?Tqoc#} zb)Fw>AIAUxb=~*(*UR(&eK~Zuv7v1bLvXxxM3h6~)BR1)Y921BRahZlB4}o8eA(ek z`TpN`xB2wcIhgh;{#uyK=yA)=d*7|xHEs>*3mdH-^tnwC6Zr7_(hR1Ccfls+8SJ+6 ztz;D{-ZWn{?=@9(uQldQGM0Cq-d6GH_6!f{y>l*v_&+NM{LRI`V%ks3Qxlh*Okd~o zB*jf8(95$TPT|<1bZ^O1vroKF&5GUT|3s)*-)Ayo>zbvBKi@3OUjF0pwrw*$e7t#m z)%>^Y7nCZ8% zRg@}vdOmfx+daW(A%`uDCzj+V7{A-G_`<*T`X1NW=JO7l3i&=e(sNj4TJ83JUvq&S zdix(*i!XBY$(%hYJze8r!O3?m?>RIXj_77KdhcF-D0|9IyW4&@4)TcX5CQc$HDB=* z{#VpU&{Y3l{cN*;uebhDy_ej#gck-&wm$wo#nV>M%?aLe^Jjw7awB^z&FPrD!U zjb&Y=d~d?Ez)W^?H{%_4_g{T|d(U^aS@~>pRuMLaZ5!U`&+5s|^_$A_VtH9eev@m@ zoFyfyZo)p9?`LNG<=DE6mFLG|L7Uqq4UA3c&u2H-i}F5LS^Sgltz`Uci@OINbOtLc zy!gFE-QTrZr17UG!;_eIx!Fu5??TGe9yso7aARDd))4K@!S28PCO zyRLF3i>pKjZ95ZF&GGc<_3PTEw*r3th;+EH^rA`JyAzwAaK5n+alGsre1kpi&sFgS zj+Lw|+JC%mmo9zz`|Zj-&u-2wzjreuqhFy{Vb-~G=i)3Jc{rFFbT+Je?~ri$(=z>I z+y|JyyqUQ~kd^D=VPkvVl{Fd6GV@MyAG#>)zIlyR*2x<}0wuPeBMziri2Sy7r&CJ5hrFJs??5Bo{yS}Gi{Z$()kN&p0$5`&d$=k%$4b_LvgNYdav;H9bb>%{-dXx zx>Pj&-^-;HnJvEQ)kmIOGTN|KC~n!S?E$4(%=WwY#J*73^CC2F>+YSM`3?q;bKWsm zoSK_? z=O!JV6&0<1dEVT}U$NrLwy8eI^NwjaU-V(uo1Wk=D*#aAMLa*EN^4X>rE?6 zcKGm2Mx$8#PgO_mnW|$M=X6wT-e(iVDg61>^zJ$P8PPv!$Qw>k8`}Z|7EKxV`UxnI=Y|9-D z3cNEmNb_=p?at=e`74Ue_l))|N3ps4exA)QW9O5}DE6(<{dnts_e{P1P^T%V+GT}Q6rrrO+z5ae%QO{Dt zu)bek_WO5ddADBu{HbvLho^Zp{hB(ZFYGq8e;$4K{Egk47>oUXTv~TyZDnGt z^sgN5(3#8M=L3exj75A?O=dg9Y*zZ?pLp$mnJ+FJLfa_>%K& zI#2kOD=+TsdB?z#e{Z97)IKIwJ&r@i4s6(QewLuXk=t&C|Cs6$v(NtW31xIV^C3hm z^w}YY`}_i5UT*LI9QH>)ae=)0;fXSpCGrbYA1HfP^JMhgSAVJ#EEx29QDDsOGH1S$ zoGgYmnHL|GVP^qM>o&`Ne{Zkv*xuqQGAmHIBTxRKU@&2s#nDe&| z5q@G{<^``^k^wF$KSYDbKmuo zrVR=A-rst9In42pMD5uOMem>8-ukC6N3JVdpK&|*rb+irW=Vq^dRMpoO*Jsr1vNu1 z^WDAhVX8)fo&)ch&HqpICh=?#=Y08|HSz9`2#Mrt&Pj`(a+s?eJFnX9e^&cx$-S-i zJ@)3mO7qoj9#3qNSNpp^XGZ?~ZtH1JuQW3@@B7Kkqi3ZwyVrBt+OnLRH`bmny1G`d z==S#eQn}a8u_bZDN9q2)%VB+B8A~Fkc@ytt^*z6sbV6e?_E&84;e1lHPiFdu#48ui zpO1fdcJr6z@#*_>4{_=q>YK16RY`=?^bqfj2SQaW>f0YJO>N|PdCDtXAvl)B)`7ui zgGtQh&6{~;ZaI70=28%gy(soTqhUeqt_Wgx_SNqlgsT|iUNEyTUCdyPc*(zkoq=gr?O9!WhmJB-I5b2 z#aHSlGxqIMDbagy?zwuSLzLr{)a9G*PfjZ+IpMQ*rCrYzZ_@&+8MCJ|F$?UeJf4^F zlS?Gy{$q~on|9u@t?Z5Vye^S;NA;NgiPqzt9ud>5A0Pcv(|919uVMG%o7$h_?v?bb zUe!MNJ#kI&!Sid+PBpx=^i2OErZ1j4QHMKa-W3#;d-D~Zd2{n>Zs&v9JC(in@BUt5 zUDi9zgwu3EYl51Nx3|*)!7|npULU5+&YJy_d(FQ1C!e+~mJ$EYoe?^(==akvhg;T% z#J3iDTL>kn?%B~I#a+_zcoVA#qu|E|vBVcM-8ODfKXq-|C60v)Q|)#lC!<8O-7mSElWEkS zn!kr(A5--qE&2Mhm5Hamo|!iPwAS)JG073@%0l=5{O$JtRE*y&uiusHHf7meJ>7qQ z(ytct3u3=GAL}dhE}N$vXHm6y^Lm8jLbK};!$wyaw&^XlNZPC(c`Zyx-@?Tfw86FNFT$=jSPOiLBzWM6=uQ@GtvqJP$ z?oQm{$0~oScfH=Bt);&zY^DVs3%YiTcU@WJ?YB2~F0L+kpHqJNTJBxvpX=V~Zoe;B z{kygLLq@XKk3vrSLu(xpy7HR(Zkvk>r(F_osy%r9e7Rx0yhyCh*`B)4qxC1=E^2Zc8gSnRvdqIs4h{eGHrpi{{kHIxrjvyrmX(VAH;>*^(k0 zbLP&?eYxcA<#i3cMXl4X%I9t|StYB#|4&i0)HS*JvmR$n{onZrwlcXExu;V%7Sk7wwZHa<#)NW-juytrra68S1z5)XHBiq6$ye zS2mWd*-)fi-{_>5y>H>qPxoE->Rc526)U0s?Qj3)o;lw4{A+6#{eJS;zo^Nc!KghT z=G{Jt3)^QH%{3|ONGT38S$247%=NvxZ}k*7cy7g4M29)P>$xj4uRPpO?f06y$3C3> zSzKoId?}~E5$(_QhT4j~{mb5TE?LUTqgXVd$64EAR`W@V8M7yVGBqcAZpNphnhEjT za;f)Ev-U2y9@ev}BJ^I7tXk%^tAd^O^ZLu?@i|*h+Ww^ZV9!3$KT(HbIhiH)iER1q z_{cuYj@9$thU3K?DNPRD6Jn$tx7Qy3R<`qV?)JCu`0mulmwU6kbB=7=Ey}@Tu=1(F zgY_+(+y7{OZPMHj#Pr0;<^1LI}{gpuB#;RYXQ!Xff`1SCUe!U)}M@9I} zm}w6db3PQRUpV-YHX7 z7QKqR&5@!Y;!ykbYPhxcp=rLaXYXQ2`nvL0=+ADp(}%VHW$ixJxUz6(#LrvNv$ip{ z9(rQTR=alUHg0`}$P(r!3?2!a_-q+#4;@)pn90=Jx`V0r)QX}D9cwK^OfG-hx8MKp zzWwu;-M|0z;pzFmQ@?y(`{e!ewKW-sD#YS5FKqN#`gGdcd(BodB^N}Z>P9I zox=sz=UY=B9l3b;?wyxQtjiYtevo0;D$)D!;*b8PUh3Y*m-{_8T79S3LhgS^z^$4C zcWTz%zxgEYkja;8A2vsS-ozuq)KuQipU3Gxo0H*=*t(sj@7~>E&APu(Ut(*%MDm=A zLd$NR)!8+dq5Z7+BJnr6B`=oj4d{Q=zTaFPR6l?2y?No0cfbL;{cJ3Uw@3*b+0V_v zRA@NOy1`+cKD*A5IuV5mC5QJ3GoDzVthV_!)!_W~Ll*X4^TL@}`csv8dLO!cJN0AA z)i1Z^q~$~%(3zNfSH`zv>8UxF_B`H}_rLag$?e6wJN4V0@;35+m^N`*3xkS6xDksJ z=Zt+1A~n};@QVKT@AJ`5Uki-76q1n zHq5mqd3Vh3RV?25$3arjQ)1eJDcf%aHn2D_{>$Qj_V?nks9jrfcyySQw}hpx>ixPV zzhOZ>m++B&vp$|NK5x>ylzVAr+LqA0uHC0j>q>R(7F(8an_X1<>gw2AXP8=^%{Tb@ zMO^kr>&B^Uv5^lZib>yK{^j+UJ%yW{FZ168sS9HIbBkJ5_OJbxwRoGstLT#=ywflL zOnN!JUB7RP!Pzde`vdt=QihK(}$s#-@diTS*SK@H=^OK|(^u~{ zrZ0-I5>5DCC-H2f!LIPlg3o%Nl$t+Sy)*v9+#PnJz=i=Rowb{~}!!Ou2&c2@i#_aiP`34We|4fQs=V;9` zc*gab+c$B3x)(=n+^)JmUX{PzzWn`k^_SC!f2V$W9lcaD{NBC`EDkN6*_x9+Xs=~| z5WYabV97$^=ePI!$z3;^X>(PrfmNeWNm?NBb;`FlZ*q<^HSeSHNMo$>ANzu zGF5A{B^X#(7+s>g{;sGx9UAsE-!kLH_06~b)!qM<`+HB-R@n&c4L$Rw-MA>YgPDo( z&8OmDxEX&#Sz%^pmdt>z$`|U8>QZT55VIEUUlL zSvo^+*6lUv2^%sGZ)U0ab>m^pcWVcO>3i!dOv8f!D_%%wJD*R*OHFxf2Jh-v!#FOpC&mTNnQ;~CS zM{em=pHB=;--4p$*;qbj_wfpR3F6_{X4|EiV_>cd%B#VAw=cZt4opytvh!m59_xF7 zs>!?-smfk1)XLifpNj1kG)vNdX3@O?z^lVE} z?RoS04YzlwsVgq#y(8;;`CrBYozA=U_xIk7HC~+UQ^qdx?na@vUfa2)=P&ORQ%=3e zDAdQ(7N5ZRKzpIWoCR99g`S`9Rob)4HYWGo_r)xG3&QrVk{1p8``}f*JCUKyzrKfX*bW{`uSFS$yV)yk*SQ$TLMh#-<@5&vgrAP#r<}-9D3isXVSjqeR=8J zKd(Z}6;{L~T%I(?S?R!Y{`wz>**vaB*M=^yN!8jTA6B^ft=QVru`BKVCad(*H zV8PJG`s2cdt8QOI#ZT|mIiTJrCXf-*X7zRNuk~_?KCQ8!LpJ{yj_S0+o9wdAI z_|eI5@UZ(WnXj`eAD_Lx>+pN|H+@f9pI-RAbC>3Cj@p;c|IFND!YVND{HFD*lMn28 z`Qd=<${A%JzU_ID=X>Vc#*^=6Gj`a;Zr5HdSFV;9`|7TV{q)soAC{k4*r_9v-m0>A z&ib_yzyI9Zyfn?gTptv-pZo4!_#~>qz+u$zKtMSYuLrVE$ogJ?m%e z=Q7^OSZMYxGGY{2z^1^G!QkY5q(MP}nWKxDZRt~{7pggoj!dC{O&Uy^?$rNiug`F} zU=+Lcy2Xj`Wruzzif+G^cX8K??LoDVviP#HzsmDwcr)5u3$l{B>U!l+2Al3)=K2Fl z3=vy`!}s5-`>#DG`d{7cU!NDr*IE8s`brw{=s=B0kt2RD@~o-{A^6@Kyk)3@2{%iqh}iJbkqux0OU z*}pFyzx%QAjr^JC^0l@v&b*v>Y@_VIj%oS9KPK&M-mc4dFqg5ZpY=-a>598@3Kjkb z?zNrynCtoa_tBYVmM)uESe(E8%sC~;c+mg&f?HNQ%=y9b*>m;6rPB)zuqsGAo4Q`F z*JsD{-+qh-Ctv)-*s%PD#?m;?SUh_NBJIcK%ksR9;@gKdchgy;T&krDdy3PN#%Mal+%?3^rX+;ks{cMJt$}Y~c@B$jg$EmX>yF zdl{qTEywUPA}Fuu& zi*0zqR5-2rVms@k%xxFf)W2|+s$_69VgC2!@{F&?edqUPUcD?e(Oz6S{h@3A+gINg zeyW=nUAwkw>HF;~AMFgS+c`gc+mE_^TB|?BdRk6RSKS_;xBm>+`|S&liu-fVKc(LP znREBgiO>Et#~4nYKK(oYUg?A%b#=n+yPMyqug|X2KEBzd#%6hsf9m}OwXO1VPQDm>B#Ys!=@g|ycgJO4c&y@@3PA@ueV^O!TQp2a2+kX~HEn_(J;)`05`h%Ya z>-slaekcf%;rd*yU8wK3?tR>>nCr5qR_>mBk!#=l{(bdx3a%fXbAH}|%=zuJXT8fi zpV)u9Nc@59#cy}_*2ixz{k`qoyqkM{vp3x>4jINx#@I z$1T)Po?+`D{m1+b%WU4hXr8^Oe7{fPRldp}ttX?mtrBsc+%D!IccI;E+PO@hMtk+O zJ2Q@470b-xUyvRadCV>L>bj@3V)Z-SqJKY)$=i3;Z+YyCsM^r@-qMS)5xtWQDo=g+ zdv$-2_SvbsPM?lBVY_VY+=~M9&UJV1tp4+3cI$n<7+d$NniwD&fcK6 zH^*wCZ8KwIx8+GGg%=Jde}ueS9X;7UHg)~|yVm)qpI#{6!oBFbT*ZRhVvSY#)0%Y` zUyajrn*88HjMMHJ^*h72?-$o!t8cPo*QH;x8#)!%>6<|B8NZS@q>k-Mp!Xj%qJHwbJC(y2{tvAE_Rj#u=?1AyusJz4dI9+T8ozyY{&NJu0I|&*v?;VEnqDjvfVOwhicu+W69#oZj1*FwdE?$&Hv&Y@3x@e zAanks^WMyc&;Cz|{_(lqz?=<~?~;2CU+7xx(pYRMcBdl1Zs(I~kBSN67cX;u-#Wqk z(2O{4gBo3j53M%)cUnwzRuul35~Ek@8x_7%Z_UY|t500ECwhPLzB}n}5Tn5NJ2Ul- zQv4spZohla_E+!mP5uShmls`FAd;+iaE-RANmpUGRN?AGua1~ZTh%FA@jGut)IQLk zaCrZ$w54?!?ybTF({eKzIE|Rj#@0{k<+NUK*2u88eG5+j^PPxCTXglkPx5I`lEv)}m&0$)0YPHpm>9e2aM$6S3 z+r6G_XZ(kC#+k`RtSn0>x2?39y6hQS)Th(I#k1z8YORS6zpvlB>Eitxvsd3rI+Ini zMDwwE0^j8v>!0toKU#Y7q4vW%?QM}W>=_n*+bF&0!r8e$Z;Ib2=2aCkY@^Y$?&Cw|*60n824I$|d#MNXO48Fn8ZRHhj_W$VKpYinqm)HT9 z=}djMZY=lT8aeB4QCzUhq<+hdUz$7)Y+Q{l zncOj1n~he>{|R;9`L`}Jdh6zALH7UBzJ%Z3y7$+yy%GX3EBh}^-*%3>XJgXqE!Opn z4#j<;>uaNp+5ztc1z- z&|y)H@)k#$?yL^O-ANr(bH>>Dunbi8Ks&1 zVt#9Rp5k16_VT2&o12e6etExv#kooP2#>=DHpz~KlHu)4%hfi?%z4`WGN)*p{)d{?^V@dHoz;GE`JvPPNTw$JR!7(Alk!>JX9zu!c(beKzxnU~*K#A~zfSm8#-AcD zdEonjeShzslimKz!DEa2?!33x*2vDCccj2D_l$J2o?@gE%j13b+&rEB+9#_29TXY^EmdxocjP@aRrL)RG>`7TxcFf(xA*b~X5T)=5w8TsJ&-==9U zwXG}+It3XoZ$ua$^S^oC{(p`3YyJP9^rZzDOY|p7bj3-^l*utZ(HM#y3|PHTL&LseP+v6srF``~H?n-Pqm!Y!Rp3 zUfzA_u{+(s>%rcKD{p_^V_#T($h^Eg|K8NUmxYsWcIVn}6Rz}5J5yD-dx@F}Gt1QJ z630484gZPw8>AEKm9q;im%gV zYWQ9A;DxnK?~^<{XWO5R6@IoW`S!PW>#X0s+Sans?#F@VT>qK+ZEyH9Zp_MOul~L5 z{e^!L3IdalF1aam=IfgH+Jz5)W=VaWqPRdW%}zgd|6bKMtJa)99sM%w@Z0U)KUor5 zr#3thTDPUyq>)8>!?ArI4srW3bSZa8Hcd|J*|6n!u^Ge3qL176eO=4e^Jc1Y%2j8L z%Vtq+|8DR9dwW@Kh~9$8Ta%e=S@I-J-dtXL$o{S^9=Ecl&vNzRY(?f|2vp>W}ZH$EL>h?GCbEy?6TL|8BmE;~6A2&vBb~bn~&q z$~`u$PxiD#)Uh5qBdss!Fyk%vmc~D<|IS>zB=G6F%=%4NQhR#0Zam!0uCtxHqmfj zw+50E;toB!(_w}ue><45IuJ@l-*U0Q3pz&argp|dF^5UR- zQ=dKiWc4d|)wb;EC0EaJ>2H7Z>StOh<3^)jSKf#B_Wr1w^ONJu#V<3be|r>J_H`3e z#mxR^ybfw{R-c3H-gz+yGz8B#VZFDL^~;_c4FBdaI-bvAbZWSG!}!+{zuYfVW%Rw{ z7UVQ82)%yodw<=8*Qw8TT~^O9Di+ZElc#0#W!j3*W@$J0Q@Wq{Fx<^yxa)j5d$;ZL z=ey@_yc}u7#&nzSlnf6ei+It*`fFZB3z?ZdC)rKhd+Wf1O7D}s!P!?6)|rEv8GGFm zR{UQTlu)CXe@XMB3t!`&S=%r2KdLvgcyW`BL45c0Lq7ejhI4ytjpv=cmc4m-R;`I< zI>+|*q`~I6Zo?Nwsu~7w zghaGCZ+rbuy`!~1-Ys6?>*3%3rrxSn{rGpw>X+}ouV>iyYt>)Z?8Fzo&h9s&)Y5WW z$~#yRR$tz?Md8wgNeuohOP4;pdGjWpKuLI9?dk}d4IU9f_x^v<|9|O}PD7?-)EzIk z>U|v-m%oa)w>Jn&j!qSR@obt!(>&EbUymkEVA|OrudAN0;yy$2)U9*Yxn5qh*NUs+ z%k9vAUhCJ^*6)A&U+^!hz{Q0QyXvH*6ZkGLuRCKJWu~umV0xuy-%`yf*Y@c4&QGs< zI%T!q*D2A(2XD-tzopis@z}l1h0A`X<}w>BKRWaIvn?Oj>^hsR?|VSYVa41xvpKCF zN*~*~;#Y-T;`L`S-vaW_#2qMQtoYu>crK;uzO37Ck9`|T{BK#$4xP@su_Ae!M4FR| z(U0@n?=!1PKjYqh_U<}{M8EC+4=&CBxD4Wtwg)N*1pE50MdFmxK_4LcKr~79#h{k80 z3e8*kp8Mz1uc1}zzD#wuN)+91lUHfE`lHW_75h2ohb-W&l?vOjOFO2jY0?LkJ6SV- z92JkxsXKl2kAotw{H+Zw8jhSMky6jfCmfmX!Js|Mv}xAV_&BNK^Zz_i_qBd8^TWH# z-n+RpKE!ukysqWFZ&t8q+?JI_+&38OZk;M+X#3XxfSrp=gQ4NY(J zBD`Y%y?yb2O_%*?Q1t%%oRwW*%lE4>4|W-yoMU#JJ0wfHVb$GRZpt3nKXd#}?XLeY zb$a~!dzOFd%%@w{shvKO9Qpg}(sOqoF4(>3!fj!l?-^l%F}j}~{%o9> z!-ty&r^26oUM8ndVd79=C_OXsLEh=UwRgWomzPwhr|*g`yK_mFL%`z0gT|%XU+kWx zFn7)tb@g)QwuL*zv$gbhxM-xsE^FELJn7jV*03MzkA&P57v3N)Eb?lFO{m-cdru2% z8`Wa>$7E{P?(ez!Mf~lS#jma%Gg9rb70+FLmPN*qn@8x-JEn0VRS1?FjFY7yNsg>A^#kvax|6J^^yK?HGy35tmVbwqPcU(MQ_dhFV)n3u% za)m6`x)Yw}csCuGzfJg$!@{Rd`i3Ts8LIb>HZ0h5G+chw-_Ueh{c`Qvou?n?e|!FF z|G$sd_qhD$`pm?1V`jCE!PDJ0zTLi=%*7GKwan2h{>H4$FM|JR?f2i@wR*#>^jBuv zZXJ{eulvj>VN&1dP@J5Wwk&q0%9%YY?)R2OD_tww&wKjNvmfj0{%x*V{lnw?Z1K%! zAH6N#9sJEG>vM{p9zXw`S^E8VgcNodU;gv(!-e*s|II)5zT*kMBjB*ZI;YS|>fpyY zLO*o`&UBx+BviON#%g2pPD4;mlTMat3yWdpikMKHUAW3xYT1{X8CUy@r$2aTaAx{p zh5Po?^SRkM&Z$mRz4x-lxZ?A-JFGj5XHA(~y^Eb+CZnnNKJ)M0dv7Z5sQf(b+cz7b z1qVVU%04aYs404PsaN-*VkqZ{BK^6aFGnyn?2NGc80sG%!I7Mux$=_c@>5!h%kmEh zY;S3{T79QZ?xFdli|b$Ye+!G|G;Nx8t<^!T=dEaop^5KVK5ji?ESXiA}%kBR0~^IvPGR`r|R?if6wdlQiVR9QuoQM*|$dV2IsF=(Y?Wp-hZbY zi@3w8h*l z$_?9p#xNx6wcguamRufxE&Sd2>`y)kkG9>Y-oe;(`R!H9(|1oMYx$<__AB{#ktdDM z%FTx1;M2o(cjvJyRNVEj52@Lzneh9gaAci@$hyy8{>*&me)IgN#3z@dBhOpR70wQ1 zbL)6ky?XYwQt9n!@n>Uq?`F@tf7`a?_};t!nE9V>F1+b&JUQF!ljY8>JLS^u9=o{w z_?FA&W{i$JxrXryng_3!|K{0u?~3+6uiv-Q-)KJ-jsIHMD9F&^Z6FZvRD8Yct&ju# z0tymY_XW25Ow~Rwo?AcltLt5%fWLplv-|&vWoYfQMr z%^q`gx@k?*yYl+)<+nfQ|Gk!Px=@QZ>e8zV23pMv*jYGhA3CU?O}x0PA#MNP`OnSG zRIjXF|0+!EF#ndQcU%9sKThU}o#6Z8HM95*R+br3`|UCW`utvLFOGAo`f6}UE1rAD z5&5T6S6aRPnO63CdxP53_vZ~~ZP~Qt9G}kC+Oo>T2kdKhJY(B%^hCVLy5~jVi|%@D z5e>`y{WNp&rrz1&Otgr|D^fd$@t@cUlf#oo8x_JGfPd`!f5;L7w(#F+_&5K`tdtcU;lV7Kl@GI zNw3p~9|zx^_u<}G#wOw9hwhoeXUusyb~&k8bH3z?UT})N_^u|X#gDkRlmuCzw7M3lpNo3gO0c1#mgVX=cqUHvvZtdS8$tB_Imks z7vUW%Z&$s3mUn({c{%&LUHh#KHm}cYGIKp~Z`bo}d9@4=o`ih6v&H;bN;e}*=*oYe zuM2Rj+AU#M c($QxyFpl!jyGq%j?4T@~{uYbG1!oYBVMbR<)$oW<6x(A&Xe0d%A zf2+~0fVV5GR@Z)wS!Wj(t=+#R!y!1Cb34O=%M+))YH*N}sg!KGc#!Ki^Zy6@{}wc^ zIWAwnCzF%WwMoYI>E^g?Nc>JwwR`*aTgk3k zyTy9i)Uv{XLI9+Qf|g!IL_%Ra92*O}!W zC-tFOYxCKUo6~nWALlDqH=2IG{`1{;C+FMV+&lYkv%Tm2dsbik%C&6L?5-d6nK$$O zvS-hVCspKr<2hGeT_k&^d1rb-dBvOL$CvNkeK=kEaQ*csMo#x#{M2`wK0KJP;5Xa( z-7y;q%h$@E`3hPrz5Y7~&)4`VOgp(ud6d0*y3Z}V_#*Y?8eQW#=TB}ixT4@bczl`KL zHE#~S`**YU?!JiX)f^GGrU)%)Nie)-_jqs2!-|c4Ur!%unQnht-RJI|q)&%96&{*| zG{|3IfAc}uVp{nQmPrP+2Om5QoSv$DZPKFP)-6mdtPU&U4=_fThQ({wbMn5`S{*yJ z@4pvA%a_{4XS!#u`knOg&_(ClTiqiw90Q`|*#69``}LCT$%U2QeuT=E%$zy%<-gzc z|KFeetN;J${w=%N&T^ZC?B8eEnp151@c*6S^QLS07u>Yx3HUNO&TiYUW2{$p9NXOU z{8jQ&(eR(W-Kq&pcT;cZtUYhO?_=*XuJC!gwEK&`@Y}Y8?p}57;9eW9D-{KQ*Zuj& zVEa2Db53M5+n;x5boEn?$?g4HHsfE!dXsb0uTRqUPW5}7`Hf9Xz-0YimRoEOpDzD@ z`>K8JblMl!~~*`Dt{{>k?H?nBG>SJ!Q-w)mWz zt@rKzl(&}8KmGkCa@+S@|CYv^D{sx6Z!^0u=Fj%J)V(r6^^sgW4j)bj6`a_gC350o zkH*7AQ#sx+vn)Q$A#mp2x|Ve(qhIVa&{1!QKR^4qb>-n2YeWB@+*fuyk88iaS@~|N z!NSeDz320uzUqt#5a&m8-8``w!~CI*h@`_x#QkDQq) zwC?Rg?thw%4L7Gb94qlbFZ{o9 znf{3{p|+vZ)1xG-f4{l7X-V{N*2e9N=30H38uoVg{l9sarwPp1d~wN?G*{bOX_^6% zG41{tEOWKC@px1)F&#T#p&2h7k$A_h_QKX%>vK#JTE%6#=3I|+dvIPeKs-rWf0iSY zY(nV1ecI0dHoX!sn{j%%!^QYMDdERSHNAVqxgYyU^Qc@Dke@(9Mb(s0T zqUY0F)-61Lu5LJW`%u69dG6nbcSa?;H#|5uM{eE;n=hU_U*55{n0HuZT6_EJUVx(Q~2@ph53^>SFSIO2@xkbIJQZ@WIWjV&S%D{nJ2bAXJ)z2pjs&36aa+gy2jiuKa=XTJ}& zWal0^zCrTP=0B=2`+dp{!`VKE%WaO)n3BNo#UN_hfsZ^FD%4UK4ly|P$7s-1sv<)P>&s{ceLOj^JGNu*VU32=rG-vbJROKq0q>UCB2vVV5ZG4shC`y#p_uwb>+R9uq=aR zhqQSvGehshv;Q5kw(@dJS?B+Lk@5CdE2`MPf7T56GJVsrBl)Y=MQQdL2)yWXShq8! z?n?gpXA6yb))(E-+8y(8b?TOdbklCcgz|u9{@3us)Y5w21hB&FxDF3=@ z#j~Zw(eqB`9F3Iz_dDUnZ2$AM%H9Y1eR|Vx?s)yKCsz90+uKJkZ+z^XP+(Ziao9F0 z_VE1IpdI>g{|zOg3Iw?lCjFF86ZZ9y@F|GD;k(1PL0+QN#h5x4%E8yqszf5yzr#tZnk*cqW(|Xb9USG ze-S+&|MSQGHJS=bcvH8mHK{jgw*U9Be|Fo2P2rp-Kc8$&$vfH8P{Og;>}GTu>lDW1 z-05;}8yy}yXh_XwYIkTdT%;Oe&aG0^8{a##=#)r=bAO%vmXi{UOZE1#d2tp$h^;;% z+WY%)fXTCKKSE=ht24Q-NL;ruk~=nYDeJPxWsGa~Eh5etW2`OD>=9E6XQD=_?+vCly?1#N$ML+W=7vJ6dP)q-b?&pkc^X7O4 zO|P7Ddxm$3`eNRg?K^iDAAgtU?r?wm{%;ZA4>bSY^;^Cx?Zbh6Wz!#Ax$*+`1 zSK9Tq+{}CpHnUU?ET7iL;OO0F=gY=(N#aVPkki^*_w|FVwPK{2Hb2^#^L6u`YdikD zT)z5SXvET$1*IXjqT%OjxBr>i->~c4ow-$v2Fs2G zN9EnWQZYr_@8X+jC|9t*dS3|JZEl z{D|e_$r~@vN=r4|tUUeh-MriHUX|tCzF7NMJO1sv+x7X|zwg_7_sqZQBJ~8l)U#XJ zYaay7lDzwl`(l-z+smItJw`XCewz9~!G?kL(6ML>wP>k>Ruj2Iyqq)*73_kH4CzbQM%W_oD+&(osIV)PcM%&*FP@kWqkOReIOt@6l3#?10lb699Uq;cwuVp9}fS=tX~+pj)m?id33=;;>@)p)ia%ie;Ph`&|b zvbFi!H6cUZ{(pv7r=2>zcGHoCtj&DQJ8ifYNK4HUubW=iAM@b+rxn(kZv{=J9SG`m zy%?oy%69tivqxJEUZrn6`ToG3Z$-&^v+r-Y7gzG<+FA3@i=S<;F)jb%AJ5J4={DcP z?{!<#eB`Jc$TC0;)c$W=|;bnt^MWJ zkf9x2z5GXO_U0{ro@UMdu*tsnJU{z9%YOTx zTiNR_)%|+6?SA*Z#RoS&j%)BMEl&3@$!7YLcUF9^9LMQn*n)-rlY^ zk9U7*g^K>?WM+YwvxWOFZDLobSSliYDc+bXW#O9H{LGQX^8^mth!yESsCdUM^ZMT0 z`ETN)X1ut^|M=%~hJ)ck?>C%~ST_C2y`b`Y+m_!JJ^1%+zU{qQ<>}1PVl(H?J)3&z zX7Sd_WOK=77E@Juwn-Q-i>%Azyv%j^C)eZsF_+Kx?_{!XF-~xoW>vXpkg!gtfWbh- zLh}J*h)Bb#U8`+hX&gKImU$J|^kug$@vlx*Y+`t^z;Z$3s>!V_Z3PEf1QLIxR$eoE zt0Lj;eMq;#<@3_}2PT+YI;AY9+og8;wr|5rWpRclS^5)}^Uvc}=~{1cDDqJMwqPlT z-Zar%PO}Bl0$Z-A`&2(&E~{t|tHmqv|KT<^lyvL`K9D@f5)#th4A>F zU$4$!{_fEF)J)wdb9PT1#%U0kC-ucS9T+4<=!FX&*-#3hJhuh@uSxES5BLy`0E~~E=k=| zYcSoP@$=0XHm2UGg^$0_X6@-ood3+r?eU`TN3&MlU;ML3xA*=;UDjvQr%T0OoOzP_ z-26W$=Wh|W-9I^N_me(jHs?1_80-?DtXTN!zO z-kJM+^?$#W#I0gtdCx6yN8sEZGyN}-E8dCQ{#b7enns$-p0MKIBast-7vHVf$F(W1 zPLIi~-C@z+YC|WXAHOT_nasB|zgRot!*yms`*Z&e_$Mt_yXM-F-g!B0M(uaEhF#+C ztncRk|CZk`akuZS?}b&Ril>hYC*GR;cz$ZdQ4YhGLUUT`8Ygvc|8dEX#Z9t-`NM+9 z0;Y)$3kBEMW`BE>;T|9Gg_XxK=#a~oc~yV);ZC2k8&|DA^gDO; zhJ$}=xFqz8SvX4GPAFV;fA#$h8%_S@NN#y&fBnamiq6#=q}HFR-g(=YLzw_; zqTKUsW!ZlD%s8=d$=~ODGXG`e=`3$MzU%v^x=JmD4?dUH%{*7z`1)FTb>8{2Kl$JF zvlWz2YukU*B-)xO!z}mQrnFNW%XkDNIb#zxNSL>U`vglYJR@SE!FG>n{RjSK@m~{` zIS9RFV#vsxFrRzIl(bcsR(nOS%4OAS(JohQ(_iDWe~wplV$7k&)jD-f2aF6JB;Q}q z`;>3e85WL9YlJvjQX1`NG1W5tVsI?H#L(3sUZ44o!Qe}XIK$EP@iDn8$})Fvd!@ZP z_C@@^F5$SsL#N^o^m9j?)L!@Mnp&=Fc9i4WD`vSt>KkY+0f{Z|%+t^CxGV z`ttgU*h}`}ry>S%$6ij~|0h*?IaAZK+RVM#YgU(Rd4E3fvGST@ZgX}XUb_Jjho<3E z*4wVRZ{E9IJN4g-{(mdZ8tPZZnPugLS5FDv&$~a<=G5s|_y7OBU#`FB$Ln`X_jv66 zdhYh!KX-QK<_J*`JVU9_5FH}9P zv0=hqHSWnfzdeZg7R|b2ZpYuuAIGC7ZoS|C|77vwyY7s|$D3X)Qh0N$C@S~zvy0!u zYwSRpEt>04SdQdH*H!2!z{MC2Mn88mn~6N`Ngy6)?%lgTgJ>61isAs-Q+sUD0F@L z%T;T**4KsCp4wdVWC2I+tkg$LO(rQ0vW^}GOtsT`zc~K(E?%H}E9~!s@H$4r(&}|q zt98G|{9XM`ul%d4+_IMF`|*Fn=j{uTIv+ZH+lF6Cdmdd;{r~1o&SjNor^SLPoPJS` z4}=6#o&@i!`4h7&rtYi2f-Rcgn3*KLsr~!1+&;H1Awcrg(wT+Fr4^#29HSzOC%o+6 zY;#q<@YR|!j`!Qw-j~Z{FV5tu2sDVB=1@OFwZ?mqNz;J|mHpdNeCtLd2xpL`EE^po)_?^6eVy;EQgX`z!z0N!T`P~iPpLcoI zt0^AgO=451Xy!Rmzb%a=uJ+bb)rBv={S@=r!TwYC+3f?*k1yYqyi@%{$%WesAIwS@ zKX&VH?ym{Hp@+0)p1cJM*LMe%=ch3`JT?_Wgq>%H&yRqwLh{oUl4 zndHKo@AhULs>(d6r`~Ir`YfqwQ_Jt8kD{NQ|HZx7&qFGqv=$=WueRiZ%p^Z*bNS5Zcl_ZDPi1t`Ce`926BIq=Xy<_C`Eidu5-H z)+-IiNGJD*trPe66s__}{A;AuyWv#y)37^5;wvuYU%PQay+6I~En~~q>w9Y%6s*p$ z$y}PnaDqXxYT?9BPoAGz-E&D|m9&7_IfnU5-I_#Jtl0g+MtI++6{k0C*gLcSM|=H^ zZ){9$u8Uti{$#iIOHW?-q`IX>|BTxfN-KDLekxS7fL&n8PTk(}vu}&S7X@G3H$QFZ zhN++8)^3<(erol7j<=hpb4%4-7y4N{yZqVq`+KK0WG%M|W&8K!`=jzcHGjL0tKY3u zpZ{)N<=fVGB?msv3_iYVngIW+Fg(BI(}~MyKm3R3(Mc+-7a!FvoE?J z*ZJP;Nh*H-Ql_f!KVlM+{qfnF8(aR~pWl>c*u1j}RK#9g{50T_XaIwNjN|$gF7^fX zI~iD3{y$W)YvY^!UA9yBr_AR#QEh!{dVIR&kH0Q|f8^MyPygFIU*-Nzh9e&t4!*1@ zeA37+zq8=h<$VsPD-Lw03NVQ!AHHIc`fpSCg)jPZwzRObz4~Iy!U;PIz`%p?;3W>m zAcu}`vE0oYU)zf_=rW&J&|k)2@gnVHhuQ?zh74UshbBRdHN8(x3GSP8fqBvlA&t=O z1&L4BnW$Zzx2S*H*Oy21dw&?6O5Abi==a-8^Z$NY!u*P>BU^aEajO*<`J`Qwof4Ru z4rPW;ab9sNytC}UoT4x85mz}mF3plEFPCI${l-nN0q#SQaeOW&7 z?e~?xEO)GSW_--X!Sv3)$Lz!J`~T}^zyJ1i*5_wcy}3JAU!J5NpY`|Il#u<>pTz`B zw#Q61F*d&ZY_7P#{=%r2MxR0?>*VXqD;kzQjQ{)T<-3>a^WV;^_&KFdeW(5^%yxyc4;4mS9yDoc~uIPt$#$>jg84IkZ`wQ;1 zo_Kj{rE-lf&*STX)Ar8aG5`E=`DKMd?3@mB`Zn7+{gCdjSI^(NI9t%b{E(Eyn$$if z9xa`OOIq|OwHT5_|l&wS+7N`%8IR=*XcE0UG`prxa`OiLJJ?iqiskiS#&O1(<+PXc}rGI?B zJ6?Fi-PoqD_LzO+dDTB}Gg!_uOv+xiTX&~W+VNw&cen5Ryf-f`ZCf#;!813B>p^q5 ze)nvck(_-(>wloWfWznHdI?ap1&&s*-8-_8 zHS0+B=53oUZETR8<;{LYgo9<$kJgPW6F(*{4RwFI)@`PA!<^=+8Oyie!66K>B(~6&zW8IUzr?@!-iJbjooxfuq`q=H7)Tvt1UgGyU_iA3+vJFN*vtx+lc{?CHmx8K+$QIN#scuqjW}@$BYVBjkLmL6oVTArItN&Wwe&! zSim>;S3+NWRPH3Vs!RrVy@kHFUr9drrqi3guI7%`;$PRKCfff}kNdx6^O`a-fh{>X z^;6Rm&TX!{wBf?K3qIMir!zWy08JV&H^nji(q}Sz6ZMn ze-@`#ZQ*86G`O68>DHcGZ3-G{@ui&6Co}vR?cTarH!Ymz$7pq6`2j)u1b1gOo*T>s zTr!tdos2K6opAL2vx7m-SJwJ9vCq(&z5Gzw+_ichB{0ZpvB}t*HLBbNR0C_bRqq*D5Vv zb$-sFL;zB_c%c@Dm8gGI`7Q8(F|2)&d6IUii@XBXQ{CV+s>C)53FS6AM z{Qmqda~=iM+5kWm>0Ukluxh;%c{c+;aPW_2&B3{=$W< zCoXLGr=;KP{_ZU<*j%mhp1t5S{TPTwmMAHdI_HIw zN7O!8RNOjUeg^Xvo9|njx7ac$aLahH&k@a-GA-V&Fy^b2wp(q(+OpS^_Z5Ae{B5#) z1v8Va_wsX04X4<+Uf+^^DtN46f&MOrrUsS$o6bHz7-P*P!C%Z!@%_`YCk7YtEbr%E zE817_@`m)yAHA82@B2%BzLinniD4E*13mpya+ zz=D!D7x$R%n=hRFzv^GfcfT1&{SSHE^P44nvMfnyK6mtN+f+vB-|zP>-)+zC@^1g@ zckd2n_~)IyG-s(Pljw#6TXwA7HKkdR>#)rF)P`H-& zSlkwk2d#dGB=TCrXQVUqi!tt4Xq^H%4ZmMU3$Wh@+apfrx{b6)#KoH3yzvZhs9q))!F6H*TX>@Dt~WXU%R%^!Qnz@>KB*$2Vb|L7@n-UwkHL4BW&AW-vd{ff@!tBR zJ-6i*e(b*Z{i(G7-CYd(dNZ&8nB-Pqm(Z`Ia7JNy*J1HPUB{jYi+#I$$h5{Fd@ks8 zj#nzOTze!~7d^~Rv$6lPRGQh%!GNc8Re|FEUpjkApFeV2e|hixT9x-4w1K4|;&)$zVj=4{8}S#fuSfoydMmi_^xf`@%kP&}E>YgV;ZPWJ zNY;Yo05^xwt3#YWE?tn4XSn#|!oAR_pJ$ZAiE zo2qDAwJ3Y;qdA=g>y{=uZ1}Z&-mJ@O4?H}-D&T;`Oy&dg-^#>^WPHo~l*xW}y42** z%mdSPwme%@8NR=@ZsJyxoO@@_^?h41&22*2hG(m7zWxs3TYWz+t55#_lHUgV=cmv6 z8~Wl?+4sjXYbt-eym+mB^3Pfy{d3QYULJk-uwmEV%Afb-*FJd6SZB@5c35^-E~mQi zvCSqn;s-C7)c@4=aWytzIQTDP?Yw%1rq%AZ7d}Z9`BCmru%zNsmXtM9)6VMsv$-dq zc(?xDgBvN|{SG|fFaCe!cI7|M3y&tUv23oiU*8_REw?i)EBN~l^ZM1+1^=7xI)8uv z{@t$s^J-#KiZ9O-IFQQW+ryKr|EyxIY10-iKCVAs!WsP~F7ExOecx{vFa4*r zdcJ>sgGnBzz6tvq2FpWh7~};aq8t>?{t!u+yzkJHIEbXTpKzRZ>;lS}u1-}^qxZNmQ`hYK<$-|aK?jgRk6 zpa1)6#?i;@|8Lm-yt4Ui>noQ!<)15(x0_{VvV2d?H#hiE5%;satv#R1{=VQf^NBy0 znx1dwxx=dC=c;_;-7Guv43^)?+ob+6a;#$uZ8r*Ea-hjs!7y3ygz(OQE4Sm8JX-Ex zkWio}?mVAYV2<~!?Z?%MEK(NzK3-h>vA@*5`+r2T_Q~l_n{2DgSbB0^|9kMgetq>9 zhb>L~Hdo&6Ql9VL^Bv=1WVbDE%689GY>F`Ds-%@nznua ztF<5Ocw1`YYMw^F(>ou2K4uH+3XaOhhgjKuHX7Zs`o~nwD%EKAVDB`RMh6E6IfjMP zrZcwBihi~7XV`*U#ao*dLZ_$S3TwJKsrtVa|8k3q)2}W275I4bp8JPCUtQYp(RiOp z!@GKuZw!hFC#p7T_ty2Ey_$P)x_0i*_kQ)i_HVp&Z@0gIz?a+qzHQ%sH}2J$?X!-5 zI&u2TXY*fkEbrD%x_^vY-)8#jiTB>reW?Gx?)OpsI?>#h?swfe<>Tj^jyv%A=d}+` z)7q9xN&HDWRF)c9k=^j%9D|*M!S0=l1xpfCni93Pb3D-w;^jE!dRgw~LB6z7(DLG| z3ttDk;u6tNknp_Y`|N0mj{U!aS?3uJZsz6Cdva^W(RaNr`=x$2f0$o>xMLp235$uh z7c)OCihNnK{rfu|_jh+L{yjPWPvN(~TGOa0?Yrkzmz7WUY;XK38E&|xZZk*4!_{je z6%{yY;spvrPyGKC|9>^(!AmTme=kjayS>=-@2~Sr%Bc)OxlA8)eln?jM z1*WD0^1fnc<2hw(1JZ26cbdx0I~uRg%#oEm|J~L4hdtY*j58x0CbHgR+_!0qQ^R~` zhi}zP?cb(&rq?lYhPD-XcZAuxY8Srn_}sqC_~HeDQ(KJs?f+FUKbZC^%lh!wCG)ra zOE-ANU^SbaVZle!Yu|oN+v@YCJZDWlTk^lFcOK3^Y4h2->}uFs;Vt%|GwxU2|59&m z+JE%C?vtf2-^_e>UEl8h-oMA9@7n)4d%x|v?N!;I4-UUecwsut|Fm!WH2yjB-@oI3 zfA4y4>3yyTw{7h%=AK`5{@v%DlTN-jly1`DWp3)eT-kX>=n@0VZ{-bDpnM{i+dgS} z;DWha=Y-xXvCU3pR6n$9&(p2qdn?2b&G37E_G8MMi%Tk%CF8pPK7S)ysb9FiYk|#F z+vbLZb6I8I-|gLdd++OM@BIIN@!#dX|5L{I3(fqc)@ARqnB*28+A+iK^K0|Y564Bi z4Zl5Jw`~3fb)Pw6%Ul^)8l4U}N&jwexy8g8zl^umt#;+7E;Co{EekF#-pl00!5rnN z&hay{p{32sCSlRvOW|`>9j0&p@5a=0E3D-C`|W3qXD#e3sC&$Q(NRf~v1?t7b3qyy#f{Wo_MQzh%F3FEd?xsB-I&(XW7H z<@l-U|6+c8epy_6H^0dC+U=dfU*G@#m4E1d-A&nZ?;p&4e06ZLX`n>f` z!@-U3q<{XqlNESVkwVcW9?r-+9u;|KOz9A(a zbt9^4y-~xtS=`4a35I`s)KlCVE^Wh|zBKVj=&gPGAGH`>l77C*z2You;xndOnX@g< zPrJJ_BQWyAveENR3F7nrz6ZtX{ zQuX`uZ`#EjpIwnlAEES_<7D`V5&ccPcywtq~XGDAc0`7H^lgZBSF+vm?u+a)2ersnkN zT~{{$x+&x|W9#!(`#*6_cdOVsQ+|hn4hO@6^KuT;rFOTq%WG(UaCg?wjZQ6G?e}!r zgBRSrS%=TQcoiR+(8`+EqbTmMK#`?@!IdFk#_0}57O?;pi6zVuQv)9ymoUiaN^3FM z;4X3g%o&sE-;Ml*x~E?)ER$Fz8PE+3D}{`b!xzVEMn_kZ&HbN9dK zth0VNeb-f?B=(Kc1>1SqSkkulesn8HQuj+r-?{FLy@j#8Z<<==+#8;6DrDcM#q+Y| zI5=@AI#idh{#s}M)n<9==N+ml7n`PCRt>#gd%fz_m7;y$S3X^7qtz4t)Rag1m@dPL zc}rDU|E>Brk1^%Jk>Zb=4@};3!|3YqDbcA_>%PC59%FMv{DJ@eZ#)^BpT^e+AOCEi z|K7P-E%({C<;OaoFWmnO=wI?qAlf2Du_alM5>DSc12P#6;{~dK-ZnEankBvQ3=d>~$yubIy z?QMUb-rxSd?sa^T_M!8)ve&b7?Ay8fto)tZ%MMS@{%m|-{`8&m_qP7b_?>YnmYXAp zO=W#=VZV#@jmCs2Osp*ZIUC;0+w?jA?i@+JHOvQ%4`2Tp6aL`9m9~r1SFGRXsc=JI zgje9sRL?YbwGQ`b&u(|m6senkU%GCQY+kjI?H&n*9fjU%UwmiZ4vk*_X8-Z3RFkIq zZ%^58ZOdTK|8pbe_Liqk#;>@RuAdj~+i+N>UHI*V_?RX}2MvWE{r`XT%W?=wO|A^J zoBZ#vO?cHh&s$5*Pf7SKWz~{5WZiMm&1zTnXEzx`?ief{vTcAGE!QNKWPV-uKC^-{C;xY z(e-9C&g{+z_;;a0o%i3J>i2tNxnI0Z>DcaFkAt7~o=dEpy1i!lBzc7&pS<4dp0Xa+G2y!|7~yB?#-}OU}f2^ z-X?r#e~iVQdER%X7fpV#IZ~=Z{l>X`?)mkd@#`)0r@Noun!7XUahLY`jQC%7(r@t= z7w5kF^*SnV#=F!tA^);|`}%D#&Ez{R*j})h@h52C+*S@h-rLD89)7cC<=pq?STn`% zmZI|=* z>W3!zm@083Z%N<0Ws8YL zi`7BiHO!_u&32WHc8AMWZ;;D;{Ip z(PF7@_#cPf?bbi^W9t6ziub3S zycY9#=PQrJHSu+mCX0PI9sjS0z42?|!gD`@e`fu!lACt$yv;s|eS3brdVj0$?fPx< zwa=~JirfEp-STkvEo1AV1IIoUJlnOJ-(6e6!CbmJ{ToM}&dYV@W$KfSO3o+LDJ?k7 zCUtO2)2x!+CZ?A-mMOTdpKW}gu~eagZN{#7Pfy8QxXEx(nX%kEa-ZqC<(n)kZe3Sv z6zzSW-T86%k)M?f5Aq-Fo8b9y`%RZU_J!r?c{`pMIlVtr_PTd|#`e^gpSra5^1t6L z4xfEizdI(qxOhve{1nZH5l?v=16l=HTI3&od@TQeM>aorrR#frBTIk3bzkk~ywLtH zyi=89YWT8GtIFS9@RwApVd7&@(b=ARd)pe;HQK5iE=>VZ+g^n+wZ~7j*Ll7F(B}pXpg8x((f7BwIVK3-+S0r=UHHbrqk?Q_tV5LM zsD62J(kAM3%S-xid-%ro?zw$op z|Nr0BFF#{;$`hl?R=-=vd@wZqWmVhp#|Ne;Cm6aH2~}tcpEXpNvHt8HnRAm4p8m;EV^~-x zr0}Cejnm=7(HQFjjmby%o!F|qPU>&XP1)_KH$Q#z|90~AJ!`w0c9WiNUahxZY4(~v z-REBpoqHfJoannl?TDRb-)ZGD62b-#85k~bT#~E#Jo|pm`6n&1iWWYbZ8oaKKD}*h z*=etqSsA)>QpmkKr`G>z5q{F5xZt4z(^;W|4#FNE1Vy&6sTwRzoT6yIt>th)Mo-e; z>p!AvLT^9f+|JNz##Z3~g{y$s^asy`3ulC`Y>naP z$XZ@Cf9~A3ZzHBxW#|7~bH&d2R{L7hH_FccA8xKYD|Ta}c#v&F+?MM_`HjvWTS9C8 zIEqVsSoZ0#_P>~A86ov$ORGZuKil+(!RDyBUc&MD(SK*!+v^pi$V@pFAd|enWbKxX z75cW_Vp~=&&rW^we~I9dze|6bp6jiC7}~D*_Hd!qlh@U@tEd0zDxdtZTip5oC+E#o zE4dSF%+0TxHrc7n@nL7WDsC_FvTfPDsqx!BD^8sD==-a_@I|b5F4lc}EWfS2?q|St z4!fU^PQU#cYkk}4*6&SQK3`>Qy8e{;|GAZO6wZBiH{PFrTFl+y!q@-avTu4#n?%@m z=4^W}$m4KFV0Yd*9`X0u`B`_*xnT|agHOat%U13`@{HdDpyr>>9n zN_O@3*kS!O^83L|?*|hC(is_Ew&jL@ow??;SK*ZSZ7-N!UEqCiv1g&AKoCE}glqo$ z!`ZjJ;`_q;`^1JnTC=0iA78xr66g9IPme#1FO%rwPvz#|b6jBf@NT={fg?=b_cB>) zWj=mh<5$6OWA*m*hI{RD_OqN0#MNG0bf@T|%HNd|FC{Zq`-Qsy6SeDEob$KM^qQ>2 zCG(8`z16kHXN0H!UE=dK_PuL)EAQP2llJYsQubyOds+JLtLN))$^CnpoSV+qZSyaN z@6w)adu9FNcm8C<(O9~w|=_8Glylb`B?f7HLK-27-(ts!*3hU{s}wItG!{r$YD2`^Wjn- z8SBq`1PaPig8gQkt=$t_ck}66?(g;M?uwngdhPVKZT;uZZPhNyJ#&p)@6__Ax0suz z9p`ZS&LJf9|JVBeyVeLEkrK8{PLj7PKR@|Tuy83S`{e&08xlC}53QLd9IM3bQS;I} z{?&DN1}UGXhMEaoYd*4bN%YdQQkULWdYDVK z*Bv?~w)e$?y*jJo#RXW{xQ{TkFeoRmyjc*v_v-wq`BxYJ(i4xc6zp})-|1TXv2wK~iQ)@XMt@NvxDt;%wu|GV}r zTKGcmmQ|wqkKmVWAKU8=rx)&7t-k9ktHQOf1`P}L9yqYz*Nx&;`Y*#D8LM-%)ZS-q zx?TQ!`}Fd?_vC(EJ%2lSf8CzF`#$%6dtq$pG5P5u=bsuo6qdK^pRcL=+V=9#ojWzZ zT^t_7yqSAhS)sylmg-$4HHQMt)0h65z08q3rFfY4X868!f=6Z>C&P1a(E$&C2FC;= zHkQvfW8&DiGqJeZZr-$({o5-vs#%u*I)CPE)R|+Sbp&i@^;W z?me}vQM;g3|4-HD$nRvs!@qp5WonpwTy-Yk0{_pY^$+wnJa8%06=oLx#m%tr{D!Z_ zWvsg{1a5g?yx_Rdr*$(f&U^FbP0n>GrXPHaQ;wzIFgv{Gg834`x2z8?u-utC?Y!}= zMmYz8y9~Ly+1>mmRr25VKJxy0_EJdU>i9?U)=Pq|w($Lqd>UF8le+OmSl!iyKTLC$ zdz}xByBNSA&7pJFLV)AX)jG%XCYv5HOt{4S?N-R$kFDOy917wNE|&}L@V~am=~m1= zUM;sR^lH9Q-baxS&a3Mje=oOdNcbxF+2LXn|CtHlqR0O8pW4bHsPN;}Z0lR^%*(dA z%l%8O{EExP7!L04>uGqvTe&~^af!8k@i*6G z*G5}s>EdJ;6BbRK;+Iz*3JS3BT|X=N@PL(ojdD)x`4U$?mkS29uifRJ#OW+dyQ!00 z7vAt7U+DSC8r3>|;iLJ+l6$1KKAi1s={Tb@G3~O??zhus-@Y0idsFVur}^8W-<^xw zws!iq>~%YK#n!xIeS7F^WWtR<5B?zn}B}?~M0~ZhBQQxg!0V z=f6nLj_Xf!*Qk{;buUR+^PQVeO2LZd&TdX6da3Xbox>$7FYPuPtNC~P_3)7)s(YK zRdo)8Z~0^#7NHPh%T@7^nOos^r03Jye20!YKh<*o*YkbT*L%!;pWSa6g|=56HxIja zK>mQ$?0%-V>*aR{dF?Nd=#igwbTYr4i0{?1PoZ-A3`O6~od5Uk!R)tJZExRxC&N?u z=A!$p;C`E%WpD4?m8<=;^V{thqrLV2?`H}rAjVTV9*ctYDiFXOuqGIqW3axj(2C)x7p0L@PBsU zM7`d*^qCdTx8+!Vgf%RQ{uSZS6j1xj%M; zwjIYoyn0<5W&*0LU_d`zRwcZ(j)wS`cJd}Vt>Iq$SUo{Ujm@R13O$d5_KxEd=$qoUwH@w1Yz3V>7 z-&(cb=(S{gn}fiFrIAnj!(%E>Opku4Rj(KPwxev;fkm>ptb0CQmb0!gD?4(yKJ#LW zz1_bp*Dw3q-+g)DuvYSmD!F~()oY%d+V8XUW1LCR#YlP9TldWb95$FV&HET1Qz9O} zl{?txQ_R=Eu-4DV&#ydl^T2~|wtgJ%^ZM<-WmLbqxct_-3>NvyFFU`*{L)phnERVW z|J0N%rd#eCvo)Esaom$ts7U;yH!+dDY2|S%fg`>AXVx$u^H-uP+ik^EPE?zJc_U?Ps>^-hTI*UD4UA zZ%@~Myju2oZ#gSR+%3J`Pd=6Xvy8s=b2bx;`;F(!$z{HWo`xMX4J_tVZMyW;uw}*T z%14qLKK1GJ6Ek(bC5}rL? zw59CQ3-43vD;Pza}Dc5Cwv=LuT!KQ|tIti@iR{bow^9@BeW`oD4+b8Le2 zA6^nUe`A03w!Fgf2TR_~YgZozn zUk#k`d}>e8=@6N9n?88%ex&+3a&|P|vXAU67bB)mVqSMCtm@C_7>DzlZBC2GYt5;j zFV4hrIq2dF+g+Pi_hlx-!Mlu2=eONovj5H9?b~JV?p_`%v7|h6T7&)6 zE!&sqO>46^ovfW3bWU|5_usA=A$PwWm?X#@yx6wswUncby)mf4CAn|i^Ic5rYuLWq zHr>hi(Xegl8sTWMZ`D(+KUq)lKl=HjkJkOOatEIq3%-4k7`g653*&)1bD5Q{$99XT@%UxH*UQ*xTyVER9tts82aIM3k_D88qsv&hByW>mNo&p_|_w982zfIhX zhvqmKyqxtU+sN)}l}Ef=)a0#2Gr1o7I|#(_3DvyKj(;6~^oOLSQ{x1+fCx5S)ru!i zf2O>Yns(FJ`lP+~Qf>RZi^gZx9cr(eToN{?=&0!OM^o$fhR0O|6dp~~zH5;8ao3}D zF6mDrE3Z`V{4@19lMZV_1}h`iI@|PLJPl#(J`BbWHhg=m8U6e6mdtGR4n_y>8PonX zGAc|^<1R2?(7D}*7 zJs@3*8{yBHA{MMCwwQnCa96OzqKQAt4d)m7Fs`7v5chA1x+~sDFD`RjXWx~>j z%Z)zCd*6CrqA)|7(@6gcOU9=~cMFt0t^fCG{Vuc9;p;ei1y-(qB--^aVDE+eMfE=( zw*OXac)z34e!&C*g&58@rl?0k5zDiFwb=NjEIQUNBzEY>Mi!%ajO_J)uh-xG&TZ++ zAtLfWYmvJT?brDK^k24m+XMY` z2KOeoee4qtGubm;yLKwO1%n)`7?+KO1=AXa3_dwV!EKTkOy~GPLiB_y06>p2vItYps|)w?xFQwXScNwM+B^^Q9vT zzkcbt|0@3F6y^BJh2jz><|`-fTCu&Vifsqu-Br`KTza^*XzEJcr*9)A7Qaii3E#W= zeCP4|yZ?L?`ki=9sBCz*T%fA^QFUu>9J}X6b0t+3)GlO9bC@*CxhjG?Z<@u zUTNuSy|W5@*EJ|GvT@w{9TI>4aOby_jGqdRXWZdXR&V8us%EYKx;nn};9D0(M!yx) z3=i_(Km9-D&a4X`7q@hkv`jiV->ku4#@xBNpj&T$%N@KW@1Y^GeyOBg^?wB(#?y;Z zHF(-nS0{5O{bMPVOicAY!TVV-?ESoOBT+laWj>i7mcBUr{Hn>-G-s(*F|~){wlirm zNDDly^ZMJt#-DNVx>j#ZMpuJy?)!!S#)G$cmy)?>|-lLTmS}HMhbnsTR(|?w&(O4u?IMSj;f}m> z9H7w;$;8)H%d`s@=uNScQm825Vd+oHtS~G}Wno!f9H8Q0@cBUflXnNio5kbhn}rpQ zxqM&gU%SeGjYH4h+y({3l%nX&rs&Q-{=?^w_??*bM!xdN#BZAvw&DBIZ-u7a zJh`cDOGogb?F|jzKTQscJt7?UV1)yNePXIs?$YP4idjoCVo&k>jQZFrdiT?`Jc+PO z|Kqw=JAZXrT}XK8-|%pO z!T;`YM`%r+IK8k#{+R58=aF^}?FP5`8u$}`P1_Xl{s70lkmyHOKQ_2ujox`U{r%K^ zhtv-LTz{m#?o^etxoY;U_n5 z+v%s@FY$RH#dz?~va$o8CjWd;`)Z@0z@Mv+`E{8O_A)k!KY#sy(~a57#H=~?sGg7S zm?j{wN8|Ug>A&`Ud~!X=ztx>BrO;lX;IG`l$ywc(d$#bg_)ji;ebR3(vo@n+H4Edx zRv$H!riKTLC!W9m)}i3=?gj-%CXT3UItm$!Oi#|*<5$UK{Z(sD8JDn?qwis-0{br) zoMSHt?9%@lT>5)=g3-ylSEmEH!^P{hNc_(%!<1h6QC49yGGcy+}B)Pm#%0 zuEn48nNXIx_u;G~tE*Pj+lKFcboRm&`&qWr*IK;N=V#i_qV4#4?*9qLL!X~2*2v+E zXIOq}eaWX4KTdr)w}}0LWSgk(`|GSHu5edua2L2y%y81UcOJ9sVd1^3YF8Kw7FaUf z=#l)pz(FdiQTDfhtlz}{1(qRmKXUMA&AfiR^-lwj_rzaWq@QKZ@mgMg^7!sOTU)`nQs9Buyoc9v{S*75nQEZ@`m6%;BwAKblm!$0Nz z{cTgqxqB0y{Viuccp)vbBBqSJsWSdL$2_0pIdOAJ6)LJ~qWw#yWM;gIulB4^aY*0u zpIKnedA3A{g6i3s{%P;FyMNfd)8$v|4r}Ac85?}+)J((YF*Mcx-d?}^&+Hv)JB^$f z1M9L6hO#$Jd$4W$>GzYOsy4a2iQ@d%;^2F1x!2}DGiTl4%oW~OZlkz_v*7g0AM6}f zDoz%H&se%`mPm5FTGSjc={)<<`>Xt?#_KISx!|$Oo=Nir*njO{F*We$INdCI?1cN@ zr;!a4qHl@mJv^nl;p{-?a#ee|&8Bx3Ks>6V>A$_HGHaFY#38U8{6fctX0S(2OU``#JS5gxfsv zS}$V~BHJw=+V=fnacl8X?eICTZvQ#`jpO*w;M~1I8~%K7pU1lIRixGVn3^NP5BNQn z8I~MZwv#^n=VL&<_TqOHv3hZg8Fd$#B}~M69Tg(wo!M9OPEoZt5$(PDpX-44@mI4? zG5oU8o~(N>Wd7H6cB!j$f6U)@QGN3Bb=&WI+1F@Gr8*dV=SZu6xn8c@?L%w&?R|VK zpN)$n@9j0o+Lt@?JLAFG%q;fiTQ@#k&alhv0zZ3?&z9*Yr*nS)Z0=AXDOL9VtNrQ| zjim}Zy3WL$e|1FWMnJQT!-tGqmUH^uI!|sCT<4IJ&1RW=w!FCiL3d&N`IJN<9fcRu z^|?5rq|6j&{gC+R)0Ta4#+^)onwP>iwlqz2XMg_0%1wlD!S4YWFY7 zH`*`ssKvB9Ow2y>!Ux$4dI}x-mpYW|%QQ@`2F89}eQDQ}4QeHvx0(E}-d`el$;$Kb z$vumgf0`Knk!kJJ?-%0l9+~JTo5@rgae-@-zU$>4b_T8n^?5&Dt(vo{IX%px+y7LG zHlF~;jtA{e<8HZJt8>1kao$dYYem7+PJ7qg<>$ZlslSk%b@F@Sohq^Azs&4^`pr67 z)As)GbFbt1msZt(6;1rHsGhOG?$w9e*Z3SRL@fJgzAux1tMAfKHmk@QlY22YSp=?W z<~@+)?~eZz822=|{h5|LItO`4{Cr>(g@<`gF-S7APwi5XB zd;kC6b&s|-EU?J&tppOj!O>&G+1+%guk26K2^WrKz&ew$L3jXKToYGT4i_YLHxs` z@^u-DZ53_2vmeh5W8L4lgsHVce_zQ_`P3D+FND@*MrZ8IvJ919vh$%k!*qdTj}_N0 zKP;@U_{9Wqsne(W<3AqVZP2!V-_pEq^Y@7`oZx%^ceS(psTCztr)kIkI~rcOYVtlt zi&gvoE#A-2WYW;k-OpKfh|%fiiDZxEe^&ea+?4twJmP1e`eWY1HsQA`=jn9cH}F4y z*y6B3VSAc~^#4chSG{*uL`pgC7khM=@5VZ7IYw7`xr*2*+n*k*{a-q7zgLybe(v3O z>3bj5_nf-qzf|(lg8iBN4KXo)Ti04R@0&WmDrE1D!@s8Qx9Hj6xj*m(=f7tY*cE<6 z{hDvv)NlLG<(**7qP>C({&?t3ulu+3xwXKYN_7W=59j0#=0-~GGgbJojA76DW487; z=ks$o)&KG^X_w`AHQD``!-nRA!WTBmmE4kvU~gJ}cGuUI<)<1I1!89P8Jzg99H|s> z;?jp2wm;vN-cg?6`QT#8pSf=YYc$X2_b~DHsb^R#s3Q~n4snI2?T zXED`n5 zpM#pFZ}X04X8L$;pZ>LZI)xn1jHagVo!@7@#Q*nHMxIj(1n)ljbbbAY1r1%QN$>Ua z%Q;vAzVI15ZZG+?uCDXlCuXxN<$CfwCXEd83=s?Z=dWe^vFP6c-tQ^Bn`UUePr1BS z#6NCo{LaZA+x|_?wUyj{@8U6|OAjX3G`#!u;z0J_v&Y-&P8@x`%VpNKfcsa>e#L#& zu4OMUo4#{jXW510vsAx7Jl&2{{C`$HGx{|1 z%wqOAFV0JF?Aw*jGC{ub$Hs40ocq5neRzD{DY+NnacA;*-)GPM7AbY^tKr2rcSSFh zd$Sx+XJUHqD>|()A*}ZgUv1XS`b0gJr+Eiu4ly!aZ+y@h^{}>eE%U+eNB4a_viu06 z_u*&%Pi$KJGg5JW&3mS%iyXV$KkRLI@Nrt3f9EuQgCgG}Y6Ze;%cWSHZXUg~?ll9~ zT&AtpxjPhd{Ekm?n6OQ);?NNzD@VV{UMqwhTB;ZuwX$dI`}ANQG^##be7AFrj#mVu zt!l^4A8s6*ziP|07{@U+v23XMP`e^=<)$4|%Q+qO?)_j`*)MQ_;ag62+bjRqa<&PRs1pg;n6q;J%j61{2_gY(J|7lkthIT< z+i}5+QPobNAvVEv?p0BVXP3k-^*oxq>v8bRMSJhp9$h9`#W;~zb^i{_Tly0lg~eK`Tgzwc4zkQ+t0G|ZTB`l9?!>-XLGCZL9ZawcNdL0 z$9Dyn@vtm@Zo|g1SkT65D<8}BpS5gq*BT#4CcLVecKl(({Hd=U3?~2ZaxiFjo#z#_ zyv=`!APdX?XZin@HA_!cP24i=te0>Oqv&)-;VTUbo+dTTKERfgRb)SP7w_d67dSJW zj{ogGaKHX{{{OZ5yuznsn zY`GWD-1vUd1+o1vrZ2CVu}XdWq1ATxB5hK>Ze(hj_US{BnZkqv%Wg7G&pL9w7bpCGeP?Ou^m5__DhIHbv9GEAmhTx3DtmXoeJZ`IU(d1ePdo9M9 zovd(UYt!<`>t9pUpMj=b4C}8shfid7XJ+|5CEvZEA>rBl8pd6AX?sj;*qZ)Mca4#s zys7*f%i3(|46RpJK7h^`O;xa9F^s{XFwM6saf&Udug+^z8*Sd4B zmR;>PRbA>s&#@`fmYS?!;NN%g$et;x<=(Fk#OrQ6z5IpzHO~2AMo;Z~y5;`zyinfp zw)3#_o+rN^*80{aii^9PNBszfOPrM{`#<+r?A)Mkhah zTK(frqRjg>R*xj5K8o$P3BTL^)MI`Bisp^M?_a%&jhJdKqy0%-ZD0CRiPKx{gX>wi zYNs$fu2|1sEgo;RXIUca4o1h?*TwUH$H=d@yYWT;W81P<5p|;H)}|+(3V5%z`jt{o zz2sN1cG2fodiL$S5qHMD{omKk^ZzZf{nZ`Q|J2}Y{=Cff`!_B=D{ps2Z%%wx^yk-s z(~sZVZRlXI+TMK00&8X!#)G;$qYGRWc1&>&j1;q*mHMO<-i`@3zg~WxQGM!n3Hz@* z!cy*^*75Z*2~F9l%wj&VyNA8?zM4f>|8=GZ>?{D@-{J~4>a%w+ zAN+G9rs)PsZt;_ECBbdh!wYu%xpMn?lhetDKoh%|BjLC{|$au)3y9|KDCz= z=TO>^nVHqU;AvUYtPk7RCkL=|aF!}8YKVOrnY!l5qHybwJ6iiQj?XswRr!_s;}Xr& z@o}sZ{{OxIfA9Z2iV7LlO-mnpY3Em7{B(7m`z*}`=PfqppEX{vdftn}?M74kzc1SS zV!eg-&WyAjQ`h}bdn~WNzw5m0v5)7NVvcf`noaxAy0$JX)w7>}joD)<>sz;Xrx)IM z7_oAbHqVJAk}L5p7drr-pQiY07dwzXLl6tbZurA1ChMbY;w;hueF6>^Tw%K}$zRB#8nJc@5 zx7+vMZ`FN1y?yDrhu#VQ`hE7znr?i~`A_?P;e9VX_L-bCQjWEm`BeKuhT41?nRB*H zvx_5Av>XiV4a-v&+SZqB%&YeHXrdB-hF8;jE6gFO?)1WYp~#9TeJi>zUTFoa;Cr(V?vzENs31 z)AR6IY*O=n^**!zz1jYCLu*0g>1D5izG~Kq-uV6VeEq%mXPEQu%yhpX{NaZs=e&=* zeV&HDSARWCKy?D=sY^YAw@lVe`~2+LGb;s_d2hZl&3W@zD`BDUsyJ8S?JS>Gaz7CK z`bzixEA|S;mKXje=S-UHj2axgr&OF2+2J6s;QhKi?^bec`}}>u2_AE&25vdM_|qfv zFXClty+x~S@-7D2eB;ZxcwuF6rsKzB>=9olX7O)%#D3s8vsdiaxx1#TMObGmKMl3l zl6p0l`+?^4*UqdAM}AvvS$zIig=6>96t=sk=FXLsby+0H!nKwCtd3PnxHSLk_&VFg z2j?$ZnIXfn_EqwN=&;hFS-*aY-^#Y$wq5?uljCpO?SF^f2Cb_&gfKg(j#j%Yot=Hj1~ z0^wpaxo#iRVK13zq_)BRCFik~6+HJC&-O8HHqCTq+qqz6jPiyOmDA>(yC=IDIDGhc z)_Em9lYFB@B1-`1bB zY-81fM)q9|+wW`_^SzqN(RF3^TGhnU2j0cAurWF}iQ0ddbozlS=i624`%mrv<9GCG z-qo^}^?w>|nWQopW-&NBT)1~|q1svo*QM+CDe#v%OFNWVxkde4B`wD&KTTb}?#IJ@ zF?sz9__=3kDR8`9vsUaEyZ2|7f(>7#?`>(=Y7)h;<3+gI;xk5v&9wI$KMk9!UBAHV zc5$P@*DK~bjtV#2w2uBG|Bbygg`0!v@Ga5#8LzjLG9G=@Zl)b4qAZdEOvluaMFmn;e zIa74N(9ob|#^Lmkej)w7y^C4Sq?oZZ{aoa;X6{Upd3+o-N+0)6_I$ka$6l#Q=O;ep z3Kf34ZI{Q}7riZg`}(G`hjN9d+S%@N`xkIuoayr@U0T2-b9%w1=V$MkPg}6SRY509 za^)7Dmg(t-ju|T$ie%jCbz>ITqT{o}+SF%5bP-b+$BwNTtK^&m7Orcth`X@l0l&hF zaFY)lFEryk;@#vb4n8uD{uw?exG>v>hgEk1gA4=bw9b!nKCDx{x^w5nui7m;ELg?1 z%=~kK&1)tf`qlfd$t`TwBH7-f z%&A=IZMoNM&pnWT8oqO0qwQmk2cH6;K0d|HWS{tp!>;=J^e@e?xUZ&P5!`T@Pe<-S zZ<%o#gNcG*!8(h3-F=VzpPmg}_Obi>FTH>j|1a_Vx^P)<=|}PVJErXCUcR+`WA*d7 z<=@t_We9{l4UrD{dGy_<_1{l^_!O^uy(5}K;Lg`Gn_uRy-}e6B3--6w_P?R ztIKr1ZNK0AJCEL$)5jb>Oq(OK&)i`{HjDA|`Yp@{#SC`vv4pSo^)sDcs!*{?#@hQ4 zbC$C)OSAL;MnkDq>T+b`a6vR2XT;_oNs#pjlly?$H1C414$U#HjC z>dxw}zO6dbLVxdvMHzaV<~UFI<}*2gcb3pUkJ%!#S{yQqIMz-}J2h;mx&yYS|r{`mjD zuE%C~sk8iDqWH%vfon3qv8KxI=bnEi#y{o!WAMpoc@aZ1Q}s9YN45*!ZF&3VO%8i! zgXjZ>f)Ke&;&lkn}vLlua+@9j;?3BbFuXw(+oSUE$!QW zT$;Y`%I)LqZAR@+d0s!*`RZt>__90yirD^1M0P)X`z^yJzV_+UZ*Twq>HpTO!~32? zpyuh+>qhai8PZH5>rce(pWSzEOK#-Po#}@UruIJAdO5PMzu}gM!j1Ib7w(xhoj9)_ z&^xV7mw!IvqwAaBfQCHkm&hh+u^Zew&12diz3Kk@yJ;q!I=_44`=45|6)`^vwUgZ2 zoO1lr%=vv{Djo&N-#(;AsQVpi;_8>%>S|%HK7DD^b0f|jPS4sIXZoik)hU+E`=%m% z=*zO1W!=H0;qjOE{d!)1@7=D?@9YfYrl!s=-ahB{wmFk8_iQ~}F|%pw$Aly`8J|-v zJ~JP-_(}*|V_|o6D-aNKP;`7YbAv#;_8fsH`njBzO-%Bn4=5s(>mWp|HBYTNmz$8G2RH#p~Yo>j!_g#R{Gg9Ddt-7x0x zxcG+Q5nsZUy9M87F-o54Z29G7vgXNhyI(vP+<%AHFm*L3C~Vl`*TA;H{q)lKD@NPW z6`c2P__Lya+FGOVN4ICPNrrw~!fg{?|K0Gxk-dcpmNFYY#V~N^*QjKg|6SQo{xtGy zka*Z_5dodL2a*gO`Nu>jut_ley%lMbtN(X{?^M#D!Jz`a`Sst$r&eQ1kPn`tA3hH-6K<|F^6mVcn5S zY`4oy7KVGo+!PVfKvn3TQlKmAtC;ZyO&5>sJ z`ZjAn@7t^E4%PqsbFJ}#e6sk7hDf%i;{`Y5uY8GhC|G)a?RTjP+xHB+b}Z^!^x1}u zrTW2+C#^FXb}?L;*;**`@{_2_5Kn>iI@9Ixg_udsJ}$ughLvB`$?E_}zZQ&Z`x`*78vLLr?p? zowuggH}oGr{BiA>tmG{WYmaSB{ms<$jrnp?mVV)d z|HoCn(CrK3TX|pan020&rT+Vk$Ba$;^Y8!Z&)+VecKcZN`uADu-&Yv#v7ckj$jq|& zOL2C?gWQG(Uk-koxQ1b8@P}Cp2V=Bn9IjJ2VI>fAcAMqRJ=Yo^oGg0f++%J!ufxBS zC3|h^na7KF?)l9j+44>GzA{_l(UV7%nx5W&s`~U_%s);(-)?E<3?COycWDczX@XN` z@^Gj0`SEglFUeq;`I6P!;E_tdj=20RJ_fH3vp@dMO`H0hS*(6r!3x{*lwEu0Og_eL zH1Rv9Uii5?6{okArS3cO|4AeJruT2>**V77`|i7v0z zRowDNV*OoaO;3)zwXCj`LYc@$zH`;eBEja7lM=( z7S~iWrl+U>b`&&WT7H%NqDuasSxZj;UUL8Bh22qwJu@$@d->kv@HQ?9;kxb8`dQMg z{|<}oop*Z5{O?)J=Z`W!?O>K*I(cht#S2M~;uCJOFY#OwU@CZYDtX5K8p&kww;5(- zUvuq^JIfNT{m|Pdz4+6wKhN#=|1o6WB7J+>l8ZrG_)Z6jZ~JpfHgLnQ`m+h2E$@7M zPZogdH*}hpcV`Z($=U;1g+C7`hSpPlOMkHaz zec5l`%E<~AsihhY0&k^%Z?On6(h)L_m0N4~_O)f71!!`jX{SL(}jNxw7B2SXBEZJatTBxFyn z-z)s4WzSQCC|0KlA6D-z`J}GH;Be?qIlv2rw*Z=;?1_GWf-r5LN0B%s6S$ z>N~4mPdK;guvg;Yiq#+2oZY(j*Ds5pc<)2Un0%va4J6fHT#_?A*XREH!v154OFyog z+av98-h$~!#DQHojV26%dtM!$YX0w`=C7^O3;zaft9^0()gy)}g*|zNTO~K7$LH%l z%r>6oG|S`Z?+F6sH_SrgK2}MD)vbQ{%dx?^UHtavej5|Eru$j{--qw_`+xiHy_&yk z-!RV4H=Zaj{~9!2x0m_gVOfs2ON|NNlGAS8+rY!JxqVMV0>@higLj*Pl1w|}&#x{{ zkmZ=iD*JFtLjs#DPuQ}oRGXBh2_SgDbl=K91jGkT|BUd@87?IqC(cA%l;Uh z@c3D@{DCbReg_eWaUit9Gi{Mp)iw#DXXg4qdwc8;{ByY|8Y60gnG?)%+X&B(O> z{Pm~G?0j4Ar@g-ZzWB-wag(Ssyw}g4{g%4@{GIZ6zsq;;uIq5PU3U5G+fP3GqBqNY zUl;mv)gP(Cb{m^}Pi%UeGZ=JPn3a13KKlKzHa)HSXD5r|+X;I(b;AP$zQi;gDO&p1 z*FoW6nT?d4PnqC8oq$6R8f!yXp6>s9d%x~~C$>h<>YxShTuLQBeJOd(#sjYbKu-_x?WFy&$h}d7J9r-HptEEez)ql!Ja>1m*<|Zd&kUP zeE0g{{w>q%{wMu@R{n46-~C?>$L_wL^Zrd$wIoNK(&yi68SA#E=Rf#s+x5;yIXs*;tSb6 zIJE?@&+ptfK}kkv=B)nv$7afXKVT_nagjrhl|#5$KQ2jsV%qnmfyd;?zH%)tDMoR9SVwy)|EG< zW}Mp3(D%J7SlFt-#W~Hh^T6^z1qTk%TLK?B%J&Or-|Tw8?%>tzI6=^0>irFW_8sZGHQyX&Z)$t$J55n<14GV5 zCB}y)Rt^vTe!qYJx8cINU2S1A($=hN-$!0LgCq#Cl54U{<{DD!2v6Q8h*C5tq+3b7>-?FNcgei)dT&!#+`iU zj!hNbW+Cc0f$`-{)^|Ur#jzDX(sOaV%(!$zL}BC3cWUoy4#cxJN$&o9Iarp5sonjN z{{F?1FTIbIhBQl0x;gP>!-*fVcaoS+?3-|8=J}5MbMG&%`FkO$y6k=9w$E?xocVvw z>2|rnelfwfM;>Ny>7PAP{g3sz`+|FORM%PWPJ6ts`t#=E>-Ae=XYXx#yfZmw^VWwm zCfuB=_R@1<pI=-=q6aK2MBoFZ5e_?vqAzYFM21 z)ARf%n2t0QBs7+_m(E}OZ9`8)+6?!fb5AV&xtR4bKLf`s$GQWqjGS+ITA0*+F>PSt zn6~VaJ7Ylb0qOs?#`C(D6?M;BRlf7-`MGZ{AKq}a;@Y=Yp33X)-xgo-?o|%Y3-QU1 zpO<7xF*%+OjsGh=f6Kz9^`{S;ysyYz^Ko@qxY<8Z{+*vLZO`1AEmO=`*|2Te*Q?AQ zF2~(k|7~WLyHsrIm5774wGJ0wwEFUR|E;wDjWM;K&+Yqm=kVgC59=9O0bs5*Ey^BUH#4RnBZD^W& z%A#3ovom{mo8R^W5%a7COkVux7H6LDc2|OT!~GEU-0q3YCe`oqtz1nq_N#B&AINLxbXLaPb@N1CyG9pBh|*Y`0Y!Ff>pA1>JN_XDp_GY zOISHy_SD`&_Wmu;@1I-PF}MBpqjfT~I@}5rg`Y2M{aKdB*P6pQVdmVe&tFZRsjxna zzvdtJTeivh2OfO!nQvOP_u47>$vZpeAJ7eMI+YSDY`T5kQQ@#_yA9s6aGYg7$f)pB zHYEJ%9WE-~Io$bJsde zVpzL_HED_VKEBssm7?|B4t$UIT>l(!!*816eJ1~m3H4JsSss|5O~@>fc~mGQlCdCA zi+Ri3u9fk88&mQ;ue2VmNY1?Yjq#RJnOQQc#Ye$}{TjKGHf64F`|G>+#;VoNJq3cl ztbBff=doe@%zQ}XD)wQQ ztG;{HiEf+q&iW$TyPKc=8WQ-r_sE>BZFrzBSF5w%aL;nts^WaH%xO$4(YM7c3*1Hc z%JXkrvAfHcl4+qWevu>2fUU`$ndS3u2NlQLJ{e!uS9P(R&urJ*8aDaU*F9a#>7oL2 zI&*etNG&aP{>$s_e*5f8h3!kKZ6-8iU-H!JTzYa-%+49!TAz2DHLvfucqFtv`Rm$O z5r3~#J@)y4GV^@KNg-p0W4jhVH?r0L$UZrV-=B1U;mu+HS2V@R|HQ@Xk7YE?wnbnf*5XO~2}FX6;zIuD3f)e@pbb z(D_W&-#+zn^wi6hvnJ@WY`OSM_C#def&BND(zo`VHTD!f8(X1sexBV^8P7e3XPbSu zxtOp)kD=>iwj9Tq%}W#Cag;1#w&0!nqBB%4!18go<$tqh<G5~-PPV*e`Pdv^yW#Ghx6{6Tl+Mq1 z?mDAyhkY7b6tkL_!RNmV)J`Oe%=vYB!m+AnLT=wY1b^B8ILN4hGaDQiI&W%;=LEob!g6lr%}I{S^j^N|Nk-8A;2Q|Pi4L8y1ZA4 zx%0l-M_HMf7o8p^@MH6rc=^OFWp)Ry_{xR$Gqv5@D$8)XbZXDWH_wH4IxMVP*w0XV zV1CgT`TZ756a5@&7;n ze!H^RfBW`td+y$|D^dCU_2M>F=das-wq`JIHj(*#w731XD?@xmQCvdO5trA$8YU%8 ze4pYIE;?y%<^2sz|1WOHyJydSE=r*y+3J|@OP7WR;>&zENoNd6R@J)^4Pp#DKe-p2>myz?<{OlltfV>Q518kv8|pc%fjB zX)aRaZFyH^_hZI`e3OLin8K9BGqSuF_nzCtG;c;!o@kv)mTj7#d^ZYyn&s= zYx4p7b%&*2nRe}8_|{He>L7zD!-oTE4F(DYr$cT}-~GE`zw<*wU4`BSvvw$@+1b3S zT&Vp~msLC8?mb`61%)*01bydO%6?ql(S=L9=X&n+oYuW;vG2|K_j%5WKihY=+KR(w z%WseB-@WFyA00eeR^k6`mdj*|$*M2cPLH{kxAWz+vZJ9p3%;J;e<|>ea*LU zZ<{lH&!n3-t{jOLHq5U(+`0DAI#u!7GX+LwjF%Mz+NK@iaPmIfu;6cF!-9e)&KDXA z9vWAJrY=>H>e|f9AvEd#>-xXz_nG8aPWhnuFnmvx_giz%+2s%BC~V*J{i%NaPVPbn z*#L%n?NW~uV^`IEVkp~U$oOW9#fR^pbIRT>&1ieQOM)r7{`xb%jtdO8W_w8Itk0O6 z#mb_czwS@>yTqUAzkZf9DDb}czW@K!wqr|~vqSU(uC=!&eCrR}yrp@|-&>QH#s9Or*WkE7PT~gpN+OAtEiOKJdoKl^p;JB#gtj7+yw=W95 z%(>BNP{*e=Gb*Mprt^tGU0?KpbwzWyJf#0?9dGMfCv;)+O z8(&VmaQpA&mznPymJ6<6nrD`>vNV`I!a=y8y=7hC>Ei20QaPu$tzTEfc;}mY^!3Js zKkg0%Q^an(USL+))9_AXf9-6>;}g|BY*>1i@86=v8Jq$=|D9S+Yt%;teo1Rk(=RFC z_2|++#wDLKd}gg{l(~F6a#AY8vgYfBR)xzZ$1mF6oA`8MbNekPKOXrWv4VeV=gg>m zopF1wviRY5=g+U&JJI^nBAXdrf4a}@-%$JJvAN5I*qi%4ZC$_Z_PZY`yMJDbzP0pX zjvw>1h2!4>n$aP{%gw_6dXJ% z1XOY|4X*{ss%L8UPN=&4gQ4j^=x*C`#)BtKvS04~72n8S%j3atBI79+$GLOo%6$9H z6yLPh2Hu@n^fdLq#DQea8X1GA-ufy-%UK|3fGF%l}n}1#1aA#3u zoT;15e9hpeqUWaszwOuC_TtL-Mm6shb}d(;|1Yo=e#V?=>idy3*EM}>d(j7X3GsN{ zhnG0)emrQ7mF|DvP@c)VbmG2GUwM2Oe;hMV;J9+@-N&E)~T`2a%<38p#6Yf zV#&_c&XTNb&nK6i-)U0wsZY&7cxvkHd3Jjw8%=6nseF0$^J+iei$|<1i`uj59BaP% z%E|8Y3gJ9{RV1$Tz*)Yq$6D*N1tzmxo42yzi7C@cPXBeM9SjueUKZ2|*e$=n_xA36 zF(wxN{d=#J?fnyFz2|+w?d`^sYaX4*F0NbgXP3_ESh0iO5=@%P?^IUb{&q6@w(0cv zoi;D8v7FFVOfE|HUH7LYbdR9mnCIl@Io`V&eZN=uuVX{_lp0ZJ?1r45*?o=vII4q5{o`yL*>u*px?u9s8y7#n!&w9cyW5$=cJISsb#%CW*RvwH=msywD8=!3wI0?oBnKxVQ=DO-_xHafAXS^qRhEt z`BDd4w@_cz;yR&SY;`6q%bKEPtz4q;{IWlS- zzPnWKT-p38tLf$BGZmAh+e)3TKadyJo0a*y!J+9e%bQ)DmpE>Dr_@i`(Za-#AuqW7 zn>Hikp@svG-?~R@Uk#6Ut7UMU{am;4mbm-pRL%g2;KJXhrG5r8iR8M?jjVo~f?V+SUUjQ_vZMl~$7V_G%m zRkUf?lxT;5o1a$iaJ`(h`)c1&I{zTZl^@V^_L;C4& z@%oSAe_1RPUN}4bm)y4SN9g-i%=?24Us>i%_BuV^RDS2-k4H0J$5;H@{`R4IaZtr~ z>9;e}=jZ1?dH$5|d9$71?NC8karKY3mHR9eJ}k>%wU_RF@N?$>vwwG1?LOW5lBr4Z zm!xTIS!7D_eVv^f`B+x7hTXUQ-H=e{^X*Q_f}16))(M_r_!DGx>gz?eIJ-D0zv(Cc z%cPu$b={hC+mS~>_;UZk{wHS|7AqGNY5actiShEm2R?Q+B@PBFvQGzv>E5l{-eogc zUry@CpSK4D8lrkwcN}3owql3%2Cm2hqP?;P&9it{@;h+W$es`~4`AnbXRH2GT}og( zvjESI*WRl>27i0l;C3K?OOEt~88%+0w@vtS|JJ0ZPmVD2RNFl+VNjj?DEZOJFJ672 zxythM7BBBP!gue}@k{0c5${h`Pxlo1sdu|j?2*T2PU9I{#Ba?|&fIKg`Rt}kg8Ye# zJ_hd3HtYN;`*t`r{z2dUw;gQ;zw6^p-;Mfq$o*gRq5T&7)ruar?o@mF`TO?V$h_T^ zx6l5ZI
    Ece5#Pjlz6`1Vb%dl7NEZNiGq=?ke7N!GYp8i8PjOEyp3lXcohJWAX{$ck0KhKN=)}$7^^;B3Jx_JFmhime4@0ArW2W$v= zJ=4HmP9Q|TGNb-&+1uz(*ks4lu;da)l+-fGwf!oYN7vSzUb|~vpY;;oUyq-@WWG{6(QaQxa_r|t zyg!&9HC$EMv1-qSwY9qC|G)qLcmMbCdAfqPLSb^((pEcjEcGf*__qF7=@0;ZFHn+bmk>5Ax>6^d5KL^e#th{$AX?FLV z8?%1?yT`GsKXtxE_4l^Jv3=}J&lcD5eBtOT+#T#Sp*;5a0)CY>r{^lA-Hi?9n^WrW z;ZTW``UJaajfKHh7d@0`c$+h8=NSgOFddqkIbr)87J^IS-7iZ=pI{$~7(|37yk((NC7H^XK95?kv;n9y9 zHchOta`|@9hOKGtyu#mKKA0Ss!g(idg0iLR9`jiT?HiM93Z>1~|dQFcmS)LSpMM<0GXecij3#i~ZXm&MFX zlH6e8(DM8y3(NCo&!(BWH7qE*WOnO}+~!x^ztU_U_f=&jf8Cyc=AVOiJA+}s6J|z_ zP3#kxch4ys7Q{p>ta_t=gWhTL1l%aQjvH9!9B)o(dT; z9Fw;_5`P=&ws(JgxyN+_eVb$1zl}c53%h2$AgzDJM)Nh(w>aPWlec5(!~Y-c|G8h^ z#`yb{N?(cHiyQ3nH5;;}8=b=LZQ1)KYt|xO|Lk)H_deV@-v0Nbzx~IQYPHW7jnD6& zV7F`i-hap5m8t9(eb3hCot)nlvrEaPR%_F{T@43bFEiifFK2tlOjvPcaLKv3Pu2x^ z+Dg`+Y}YIL(p*t;^P=Tto2+xxH|4|7wzPs7s0c2_f&oG-Rb zKYwn1`RCZfwjXUUr;lrSK>`mBF!Y zT6boK#DnH(9odnWj18D{E?8xiKTgb0`~CmPZ-aL;E8;R`{I13C{PV$a_w}!ab^;kJ zJ6Zj*_V8z}HEOGS|9oeK$;|a-bLP%{JAJ1=lOw}kyF*&GQmbsY@IF|c|Ns2|pZ32c z*gr9@>q^cuUe7qou3@Woud=;-mFcnj{&(9lyQkloWt^drnVRcvs5Zam(Z_FZjQ!K) z*K61CJryZ@$9E=I>gUOZKl45Wz2nPydn%%`AAll=Iy_1n;IUdZ&Il)wz{y5VTP4yP3D0G#fPTZKQF#i z=KXE9?{`oAy1n{O{U0s&F8|=V`PzO9hRIK6#&T|K{~Z40hpY5;(=1N=Ikwe&c@dLJ zXB?hqbL*h2c>ILFH9NEQ-^U8yczo$qCI5%hLB_b_$%seON%DL84l>b(i8F8%$> zapCm+Y@PatALeT?EZwu?72~eFl@qm^It)4A^}mCejc@6mSnkWl@5>h@cQ<{f_f;^Ch!5e$z)IyQHnAuwM0g+O3o#%4rU#vD+xMhEXym&lEN|dA9@2IS0yyz(#DT8YDM_R43k1WMhvImSu}R1{Ve9Cgx* z?Z1C(PHWiY=5+VCbWwpb?5=f7tfUV1yqtaM<}Npb2~WBiGsD^E?Fgu{V_FwqHmAFN z`Q|-0rb{t5J!{TlkW`o$c6M$>&h;6bpXc;dt7Mw{(PM{#rV><-cz4@ zTh8^(5lUO3lY4@(>z&~z`JcaD*RtHRxi)#$85zz5uPJ;79$m|4iY^UZ*6=j=qUTN1 z-iJ$L+?OwN&s(lK@vm3`d!wy>;?B_h)2f8^Zuc>y&Y%A8Tz<};!@ZwgFV*PiT%LWv zJ&lEBvDBN=!p<*;4(9OH=lb*YKiP2N+xFWJ?^<>~^Ee>5XgI&vp zs#WEU_3W(;iSn!_i4JpZ=I|}!4Riau>*$*|Ir7T4Sc-Uo;^E-cVO?b3*UxxnT z`#bBN{ak*lSpT2e_kC%8e9Kg&^|}NYJl~(UocMOz+dp4s%w818@Uzb0P#Yjexp+-k3O*`vP8m2PL3y*bOU>qcBz(5b{Jr(ZA%Oqn&8 zKX#szBYVd^muagG?^)n{f30`2_>9{!Tb~xyJvx5n$i()GyU!e7_Tb)%B`i<&|Cs7# z@xfR0<+=k$4@Z9E7O>fop8rm4PX6!W+A{~Qf0o{SQAn;rxw>(YLmvDFV6*?+Nciu{z)Kbw%r$l1x{s%p@6ZtF9ltTmoH8WeIJ8<`vg0wkCm z4?SG}|JQo!4+RE|0-%)jao?*&`BMr?G!ALHzW?SSjS>VCaVhd6|b*+ z`0z`j;lif1by3NVvReGLVjK({cO*Gj7@JlL2j0_W&MeN^D+mJTJ%{MkH$9u6{`l%4<(0@z6epQU} zKD>GJX4wTdk1yx_u=f)0?Phs}*IF90%u1P9YQNlIa(KLwKhrzc`!YAjr9V>d|Fnkx z4wH1feR9`vZ~mT5CL4a7$!ZpltKIiE?|1jx7q=}h2qkW|-2HD`8sGMJrT32={kHUj zyucpIvl~whUZyBY4Cdggz!agcXUT-BMvKV0$U;r*cLtCk?WZZ`peJ7Nkf z9QUMdeE!L>OS|~c<3l(8)=FN}Ps+*5f4=>N+xIs=Q+pV?8}|I|%-(rzH?wHNy!rm0 zy=Cf3lk?S{tlR5d&vHxW;;rq^gPy(1kF>De-n?dtY{&Iz<{MH!Rc*BXU3$Yf>kxyO z0@n`amRE-|_8(#_c=h7a?^#T*8cb&GtXp!g^{OrZ&yo(cvYbmtUy7$37d?8(VpUA7 zGMjaj*!RzQ_l`3dF@BovR>>V48Ft2)VbV|u3Yrf{F88y^&-(b zv%OQxpB#Fb!P)<;`M}B7y?QZcT^I)XsMviuIsz1 zl@vH+1f&iGG^!su5nGyWEU?B*aSBJZlN<*NL#EOk6}65G_r`-;)3{QmE>NG+Xv7qA zd&ebKhBehJy0u~{Z-(K0UD>IuRP=4a|J9lEPGg-N= z*{dsjdcU38ljyg#T3=<4t=)H!zc<5xPxcm*pYD0))%kK2o8MY)Se|>%;EqJ@@t^M7 zx13gX(d%sZnZ$Bx`lWt5p(?w1vlY^m=I4IQaxc;{GMcl|^?va5$(rpo8kRQ?AAQNc z_=nu}v#*LCtYK`jI$pvsdFjJ{(T5om%-yp~yd4hwoyoHP+@-f19M8HMeKM*)U(U#n zGr0WyOR9Rrf%q*Y4G9hp4l+2rXWz8sHN%O8OJdKcUHi#!X#1;wd#AAf>7CZlxb>oO z?|qJdmve3|o_3DsLC*m>g~v1f^!Q(1abK{u@H$)3k-HL8E9_59WMo+KHJ4xOb!;wCHutZLKcm0of#I2z zIdy*i-&dD?y7zhx$KJY2%k=`^eP?ppe`V6HFPDUlOqC37{W3k!wLP)qkJKe(&b|`1{_g3@)$lJj3$m{+CW^=0EG+ z?O$Jg-M0Me$&ZV#*PD1BUp)V#(N0kTn_~x4y{x8YzvX8fnDahY1_hWjN&> zE*xZNcjNG6=$w|ccBaswU(((agswCwcIgfP3HrOX9YN>v8{a}wlAzv;R83vE&JoFQ@*gDuQ1se zn{XodYn6U*jnpyeUnke!Tittv^;n}xF4u(1*D~4HsU}P9o>i^&{+0B-r`fxkRr78u zFz6l#`^(_sFx@Rs^1#x4Ar2qb?SA*_ZM~L5LBzM+FC_QRkna@xI4vnt`#uNneLwj> zXC;>G`*3@Xh~1X$Z)e}Xf6j6WbIru_JJ)WCo&ECnr4#$~T^7`sg*U}c{c=6+{{x?t zA0Y=GTnhS@ce*Bli=%JPvErgRXa2?ZlmuFJ?Ekl;O2#6)VS(~9!Kb;&7d#81Z_o1n z_w3W|&E`)6PW=73b7QvA#aNjQ+vSkGBMVY`{`wpj68-Uqj@m{#!>S=jEjXZTQH zl)(S&%X-zA@81}!{C>Z)vX@?U{LfqUg3mTg<%PoAv)8cwDUYb%;*x!UW5tzb4+sCR zuU%&KiLG{CxN*Ko?S@pP7kBLrO0(_V$Gon|m($q6d=Ga*>WUtAQS%KN`|r>0=D43a z#ZoK%$=g~V-Go`S9gnx~NPe>N(APQYCgsBQ!ijl{y(c}nnK@CuHswx*|55+B%Z*>C zGXECK{q)ArEw$gM+rOdsyngP1y8;{D8l1WK;c>=3HFMdslfoDl1|O-8V`Sjpc0I0Q z@7tUI{Gv}ZPFno?>GQH*Gt2(E7ah!+=9tO+{^u3j+Wb4cjP2pEwW+r!#Yf+q^ILQ| z^RMNfHx{Uzem-r%)UZFVpY}_4&;PzPfrFE2!UuM)j3YX{%uVYGRxC~2GR^HmqM*~u zoG7VvWdZ!>U-=p^Ih!<^2s8w|6&GofKU_9>+RAOKYuxt9pSgc&$-@1=Chl!;Sg&l z!MYbOC!YUge~d9;iM<5>H2=Aaw#8rAu|Vv~pq^X6jNuM39zboZ~C&97v_`0W?3 z0*AmQj(g?zYxmk~)-Sc18b9@@t95-??UP>fi&tkZGhD9gW~Os2KfX@&$;$M3ZyUbc z-~U;jvFZGCrI#`{s*=N_H?*poTh6)9_jLJ_X}3xzGH+MkIr-4{)U17m>rx+iZ*D!+ zf6`YyzWQ4y?~nYTemiBXzkRO$ zo{5)_wBM>@_uyOF#(lHBG_LNH=6Aig^0%dLuif6hb@jSEtL_%Rx2?783;VFBTmQ@_ zmxctLS>a4gu6H+}qeXDui&rQb&T ze&E?_@8W9|Bsj~ZIGyALN_x2xIaN6I>(+({J8eI7I#%=E%um5~zI+Y=4gvui@`WRm z_p~xMvj#1>c<Q5p@8J^ZdOUaPx<^bI zCPjW9>%Ojz&n+%4{(C81o`GTK2cxOW?(O`ftB_H1nPU?xOD6ZxiT!oOn;ZfnStD%4 zl)RZinCMBxO!G6Pq;g`aDC5}pCS8#*Y%ecJdvqt{qgncniH*OoNT5&eeUt5 z=Z{VQy`77kY+A1g;GOdiU?{kqwR`!X!WeecRVd4zU!NCokCjWjmX)*n?X7(+@}81=gYKMPU$CG2?Uv7K zL4}Hvx|MrBo_fb{u=eeD|NVEi+3(&gTk$%e`t#KCqE!~RCNp=}Dt}rg`Fp8erunl; znb*^5zWqCI=B;jGFg@Pz7vqnaF+VpO&N{fRmq%C4jx9I!RQ{)0i^{MYsSSVb!p;K7 z+8tVUF}X>O$?>$SvqD5W+XY6BTOM)C+x|cC?~@gq=>Poxf_bZbe`h^+mtI!KvT&)r zl%YdM!<{MEQop+@LQXLxddcmL7+Ozrol!skT&GyV1|yf%X+ms6v6ea+JKd-hI$$j`A# zSiwU%!r_8@0Hfnm5rH*J9|~u(Oig{4uuAXFs^c4Kz8Wqqetvm>T;Hq!d_jb9HOW#??y|!0={=Mb%%z5)WZ(mr)Bd>qbrLI_nu{@1yztPv7>Ixrb%@Mda z>1FA%)9PJaXB=nVc7JxGMtjMhT`d}gsdauPW#IXJQwM{;X3d4Ga!;in4Y9iTjC)gf z((7qAif>=L$?@I$lIZ#SQ@H09Z%~l^5O8ke{OR5QmoXPC*_v?bMb2VJiH8^dwi?b9 z_+${Z?X8@$!i?jIHWivTyYC%deoX3M;5_C3d_P*Idp13_(^U+(YF4bw*={K=lvPRCla8l^~ z^M=>{^cufVuUUR9YIiSVopD3LJ@fg(0rS!)-}gB%|8MmH*#+x#t8ON5Z%>`X%E4$X zoO9mz?N&pndo#Cuw~YSO{L1si^XFyzx9xs={@#K6_8*I?e|BEKbuae!?QhGK1j^Fo zug-fDCih-2oK4Z2yZHa#@84g`G&l)AXBD4!e|l#oU-i?VyXBv^UjN|yH+fQ8m!5F( zTfr?pTpU&g4%TiQ*NSGCG$`aA6yRVwxb;g!W!LU&XHxcFbbqnh`a=3j9)T?)FJ5u| zK6Jxtdr<9{l}0~)IL>0KI56*DM(}>^xHnIk?|t!qyU6!Kfe#@ZZ>K|LONm zV+_k^WYrfCa;qGTJzvW$B_(S!qCef3=5u%A@wn`i{^#;9|5rq2S6bdqzMIY3%{4{C zFn!bPxynh(=RUvrWmfP(@CBR3wksKBjL)r0SG@|c3(bGKH+%Y&px5e}E1n&!+R8gA z>Rs`*jsLFsU)%le?O*5pX)*xn@)X;wdwFV~AK%?``&r$6 zPr(qLBy$Cg2R;fK557p>?={W&H(SK<^Qzl<$81hKoOmho?!Q;z`p2A(*z94;zL9_7 z*EH39JKg3bWuBgSXm{*goVcE2pdd$+Ky+jV zrwAwi_Dxq<#n0@tW_q~hM_{qoU9KM|K5e{mU?F3ZBPX*+2_sXgIbYwmsf-N|4w$@h zoM#hNb&TEnxxub8v85L*tzR@SZThoVyme)4_dHh30IiT6?(K_D|75jyFV+SS-F?aK9kn0-+NC|AZ7nIp=He;EKRW-A#Quzavv>oS3Yv!$l?VCk2WP% z9KV}7Cy?)Gi)s3k(#3c7olBeOTE@Gtba9LjLtLaz{{J^MJFEV=?W}v47CDohbK9zq z9xI{}ma8#86SrGmba(MVrD;J%wI#cJ{6eN`F@>!(%Pcb5a8Hiq@q?UsF;~6c3UHWx z<#@-&a#efU?zZ{0-);uzta%eG`(m@GT+5}mXPTdy^ndF#nRdJLPUp#!_q?ZCPK(Zp zJmvQ@Zu8kWXH34mF7e;q^Skb@vF-1vU-hidds;Ux5OH*D&T;;{JoB65{M5o*_nP7v zn;ZhfR-~4(mohmlKbDM?B6c)a(dpc*LlC< z%o!`nBWmvMDco!G{qgfttYUKZ5C7fU{odu?y14ye)7JjB*4DWedBnl_#jE6py%Fau z=1g1O#-6}mzB!Y{%uu0#%kmv#%AWQB)@x_?c4wEAYCd6}n`6x+BQ&EkyE~iBy`$%t zs^IeG%1f^&?zA^8SkaImDUcI#!O-AT-j0>G}_P*QUXM&jy?h3kpO(V|?K@kowL0`oxb<@KZ3zwekT=(tut9f~n&+6_LA1a-gxR;x4&X%cnCo5&l z_SiVNYq4R!?}yd19RgNOU*pf%^x(d)5>vcmB9r66CAE>IhNqU@Jf8c%U6doreB0u` zcfGqdTuJ=hCgQj<{o2IR=S)f~8~3H#KELt0SnBTOCH2NRm+!qv-lu$`d`{uxwzrvo zcW2)ybXzs|-@g3+XG%W3`#p2s_hu%?%RUMk9Cx`nW^G$G^LyIf8{d8E=N5>s+|7Dy z^6GHC>GI0_KNuZ;r!yS9i2Sy>%hhJ$fs2BnN_zjx?= zzqIl0G?6y`yM52TpNmbn_UJ_3&&OWZ?_RTC>b^&|G5TBBi?!0i=f4STdMcIwE6Oxt zo4gZW;c55KH;FAZ6L)^;D%W8Au{>z?nfvX&OPg43C`I&J7yo?!raWn)lX~|yu0_@y z8uri4!%{y+SuPLy_51a^LwpU<<_w01l=^QnSBDi`V_&^Jc$NIO1zM8?MN`@prP#Nv zh&~n2X<7O-(`Hw={ppKd#__!Uzw*)pSXSSCb!$PR8AE;Smc`0P)%N`E4fW$qV7Tc} z`SR;_%T(svZ~FEBw-){D?S9(4UB6J~?%Pe<9_g9AntEO5zkyCdHZI6q=}}{@Fr#!z=B(*w_SXe1{CfFpenuf@*@xBZ zTQv^tEWf8`|Mz15>C}|s_+MAKFN*UPAGg{pCCTRQw!p#9(A=kN`o+Ryfm@7xdifkB zU6!;PR&%X-7|6#Uv5Wb~>}YM~oFCFpj;vU|{%kRej`ft8dB4La6uTbDYN+l|khIjU zFJ-VkzQ)nvMdF$7RVnZMd1d4jJnm2UdxP6xqSaOVLyWiG*>|>`x*&YwW)JU_yfT6B zmv*LH=i&&zxGKke)%;3Xh8Kyw&!Yy#$`975JAORr5otFr7_ z@a&%@+e;mmuKn?KA&>OQN8ffzH6=YtPoMih%;AF7N-o~cMeAf#HUo_kL^UVc7DrRdUCef6nfg71FovKOmQVrkmM#_H@>7Uam%bm~$ji(F9q zl;BB98ZQdiS2|qychOGr?suj?ZJZJROqvwbT~{ucX0855r+)L?qC=nW<`~~z|8m~P zx;y2UKW;i_`_^%Tf`u@Lm*FR!sK!}u9_q}0csWD-00+xmQEdkS8IPZv_^#-uTju!R z4tq5@SI;}BVZmJ!-R-qIB+Hi--grOl^yzKe?be8Y<=hppA%4f{Tkl=F7T))(bAMYp z@qWeb-REzHuX)Zh{cY;sn{7;Xw;jwjh&bN-v~8n8e8arj^E-NsZy))7`|=i^XO>rw zYp81o_((b)=4M%{r!Fu>X@|Ig$@ypImp{&XYVh|=cf-x9J+AYAfBbyjy}tVUTJzJ~ z_O<(B_Lptl^Yz$k##Kut*6m)_RoS5YSj}>4CRb#^x``VFpB%0}WsnrbEF?ICrEkre zX)Bk0H9E1UW=e0Z^Nsc!SH3^ly42{5%-w#u8xySqI796ZFJ!b0V7C z)vMQ{I(A0im$UKl3Y2ubX-vApF7SqF%9lQ;zs`0W#8*8qFlySH+|1y3fKNo(^Teh$ z?gJN(x~_?f`l^0~`-YN3&c+tjEGflBr{-OL^CRKbZ-w)WAAW3zvN*=^`Rd!<|5!el z_xT?_RHda+^zaq?R?#Sh6O;e%QMaB_Xu}XS^=t68b!y@Xr^RpZgS(%s+rm!Ght$)$*U2~IJc;SdmM>Db)7(@nv`+FCm2 z(9D@LKlSF zEqwo+JD1$bO-$#O`Y`_5W->b2+0$#36pe*1vw%(kgs(+kxUK3hIMYcpe>T4REikH5kSj+Vdo z%4HV|aa2uLT5)Q@U5%z=GoN0*XL4+6>X!K@r|omH|9#NEUa0oX+Uxf;);qTDSM%=K>VIym_K_(M zH$P!zwLv3WeXEyQ?w^Y6Fj$wY_vun-R6!9!%TlUgjmKMM2Sex#isGM=0q5eqfu4Bvpw7sm7x##z|_;Bv( zd#j?uUzy$cc`0^YOw}y^m0PZ@K6T{eWQPrlx9gl&R&Kd-@@To`uNSx07X9UFKllGl z(9SwZty8DhPvO6}Kj2zqXWq7w)Y;#aHRR{dnW5#ryidvft54;dC!Ix1s#lDSjU9Iu z22Gu$q*1axp6}5`ah)&k4_IW**yj+i;PFx|LCvHf7S<-s=#+0PO@2Ok9v|j?^72!d z=KUdIx13n=P19|y3O77Ye|nxN6y&~i#tEy>r#_thbn~0k-?Gp7ZGU&Xxwi3uL)P2` z#nkUCnN3c&Jqzaj^ejmD^~^l-aFaA+Q^=w_nsY@QZyTk?^?tvZKL4+P>xai$=bJ_R zo3uWs{N?=dM{f$Rh(@))?c_S;lWOPY9`l@gdY8G}@9=NJ^NoAHm6-RueWp5Ldu)1o z`s1K)mp2~%w&Ctlw&fOWg(>rTmBp3c-d|X`{qFpBE%h7UgM26by=C+>FNh^J;76^u zppU|e`IV-3@{WC4Hve&FW@LVzhY|1o#q$5(h&u|_{61@bD)k9dc-Xrm&jdo(Syq18 z7`R!OFG&3JTZ`@&3p?)_S=@_dYj3~s;$RJ9x}M(zWp0iw4Br;~D3oR7__nd|$ZLt^ zuAKjVG1NZ(ygGpG`e~Ng4C)*C6U0UM4!6BaeDk_B>xJa8RRY!Ex?f3Q#TiELiH=p` z4jX3onIA}-=(z6W%$G(Tb_eCGo?C6+H@B8Kbw*)^?$>Rt?hQh9az7QfFdtmtz}dAX zJ8n|Z@#NaPoq|8V74wE&=Kg=J<>>Jwskl({c?zc--L~njUSbz!!(?O^k^0T)<)(+6 zlOLv>l-kE`aLxG4aaMs~!A&8nHhiwr<>pKlJh1cQAz{xAj+U!my4(3!e{!~XbTCWx z$nQvNA@}UPR}Nm-!LgTBLdSiY=KZ&mQe`Jb{+LylqLy{%`(m}PJkcv|W!mQMy~eXy zc2C|_ul1r_nm)1N!1RUvNszU8rA*gay+bxwA{RTvtqGoM$kQX zu30ZFJMQN;^zz(aF8_P;^vUhb+jJ6Ex-cCqzgMY#V+j+hx@GU=e&LoJCr!5cU(4&I ztR-|O*G=TC;OZB`(2q^yf04NmArE{gXYy!72DU=s6WoQ)vNyaa^3!(Om&aV z{+^1Hbaf&&`=+I(F-`exn_hROTtD_-8m=IIDDvwds_D)H+U&~ZAVyhpmXx-w{3&$GW_0|l`Qvo#;if}s0zO>{ z#n(UVZAf@_uqf+HcemEco+d}};Hi_UxQb zPf?z=Rn6}9o2oT6t9beh#rsRA9+WdX8nDgp*B7tnRB1scJBEctMS{_^n-Ho{HzB7 zj0f-OMRW(Sur|dCm)MkWtaATg;ZVRa^WZ(lbA0zwwi~>;TYBJd+G`iSl_gghiVhuO zKOcMTgV?tNLZ3KTJhpq?HBNY)`<{P z49l(wE!)0cK5MSS`SPp^^OP?ebnjcR)YmRPrnvgr-L;!C7~69$_doGC%yaGFDaX~f zW`CJ?X5Dv=KGk7+?LS@Ya+tm)ZPm8<2?l0Y0`#7p%wr1N{J^<>^{4ltVH2`>v{v&dy#Fum zZa8RR>9FFd z>tm*uH%`u-F}dm6vy_XcULCJ9w(ZT#{9a_>ub^Qez@g?Ekku$W=a>z*84K&Z|4;n? zsl4-32r^=k=hqV0(i8XX@0^CsdOEX(S4`d~JR>!{%4G!vWn^yhl>p5P2 z`*(MtRQ+c8sPb(ybDuvmHh*am$H5dTnr!{McWF*qN{9UA6J=*DjQ2;j@o2jSD6EKC z@K!H7;?(xaGR6g-3O{C^uSx4x(x|@C`X)}q(J^1@^W)U}RnPC1C*7&|_xybR#w+(L zp4Z+uxZTq7Np0J`T@SlnarDh@XX24_cHG8pVeq_fUdty-rip1BeX>n2i)KB!p|kO% z;Ec0@>w0dV%iVLId&ZljHSbyuZEu_rX#O{7=7EV%mo8xP+mK*inY^-R!@?(pC5Pti zQCuCdUotEqQCPuDt|9*b~sChfZ>FU*Hwz_Fz0?WPLPn>6D!kXQB zR_U?-JdN7q+6k*7YZapx#LTd6zr133Mz7!UmHU0x)xBseW)Y3j5@4+R_>o(*;@P_f zg{1|;B2HqDiX1pz$tI-Co!W1ExiPvyEMeW(d3(c7&3Qa^`tAyAk1fKDQS2hAzl)3v z=I-Iqez7{lq3@h@QEHZr>7MU-4T-W#UbRT3b{laWPMFJP+S_rWW&g9I{T>U%b6#B& zUKzG3J?BXWL-n64+qc^=b6l&sU35D!liT0w0Dtgp!B=_wYr}4EJ(_(jaLUTi_$sa& zxz|hCrWWfj+ZZl zZkDaJH1m(g#>PCa`j4KfW83}a;k|oW)-M>|I7o-w42!<<=gPr*2k$c4v;WTV|6E}{ zd9sVK&#~3fm+yD_&D2=Qs;R7@;G>|i^za|cNLAMhy_`)^pY<&&CNw5oYfR0X7G3`O z22-J_>$ zOqwNew^;f8Zg7gpn3owpvtAh;WY79@XLdxuf;|bRcHdmKGdseziHXIr^JPl>9o^o; z@1~W$x7~00zD~X=<@HHBg&jf`xAp({#kg>=ytV$Os{eY^-t{-kuFWssFL^uoB3J6i z7?UbarlmZ$*q92Bf8KkmWc#mkCSQ$pKdU=@ej?$xKqT+Bm8*Qu{r44RWo8HVB~P(p zN#&o-{@3W-+PYH@D$-Lsj~eZ=xGB0u&f)5TIqkfE*41*qy3f7;PwAD*TUTE{wfp^E z_u2scH}85YCs>s-C%(4`Il%bjn7`s|d&cy{Mg84>95`j(z3M(%8T-OG&G01yBQsCl zd{=)()e8nKx zu)Y64)Vt_Hdxlo-zKPt77H$HKP2JC16xcVW-l<61HFbqY#GmH-D$6y}`0HjqFkgD5 zhUx4=#wMi=>+)6@uQ8CZwv9}g(5uw!E_kf&70YaQErFQ(5et2FbCs-_Zuc}IKMFc5e#b#JvifG=t?Ed7)hJVd+REawsJUp zxvO_bO5TyNNu{;*_>UQf4jsS4?RuVnYrC(+$#tf4-hVJ+_DbdT)@?Z;ti8%ggH!FR z`Fl|ot~VNSQ_cx-E!bsVUD+qKLf*|KX5rLQ$&&(pkJ~Tre3%{>d-$WAeGrT0OIxSh z>e<5AF0Ylz-F^S8*v_x7b7y4e&&!T|`(^Uq>X&!DQ{_ICzq`wS>b3s9$Y*(HrgFcJ z(Gb74m+AG4ga1F-bh9coti8(|5f-;OeMNdVSH&O0m8Qp?|2=>6M#s8qc~h6!$#ajC z-Q7-26fBeH=esy;^D3!eU# zj(_LqEQzrB{bsXcqnE-8pUDptp0eD&Tr*)_u~GK3lU9Y7#Lrkx~()cF9xBH$yjZnC-dEZoNZ-p5l>Ehx|T#s*Z zo6MN^RQSUxhuhnH6r2nQVn4WDuE=Iu1+B8vbhxnVl-cLJ{~Pkw7&9(Z zxW%h{ZFwG(^WC-4hgA!<=%6&|MjSr^p`?B=bhkmyCD%8q6xM0j8{bPy4 zgjCz2Uw2QjGcmEV#$K8E+5gNIAKkvJ19tyr6wgeVGgD~*3> z<6{}oSALIH-oAC!nj;{lEz9GcJ3}+mfx0pY{|yJ9a9B^+eIkYZeu;Z`HcMt(h{3r` znMo7UbWQvx%>S^a@`9&=WRm+e;nc6cRAwD!X334yu-MDwc;eLF#dB0_SXLpdJ@%#(+COE62mKSQ=YdT{P&{gJn}j}|m%_V+heuQ4kO4x11o zVDUNp{X}*d*3OHOXN?3|JWTcOJQh8js3_&eaCNVugQB7jPmW5C#?8IU#MjT5S)gj4 z^W=tPcU|@Dj>irT6HFFx%Bk?)*3()uwKvVOd~^5mYZHtk8+mIcpH+UpzjWW7eTBRC z{C-vabnW!}$KIAP98G1J7#`^LHi6woVP-Ew1>YvV7aKRFU6^lMy=_iff&C!|du!{{ zr{Y76C*QGj*|)yjJ7dqx>3g%^JpNp`NSLFJ-)q4YrT0NRMNOOEuejuN(?PQ_{`alx zr_T7?^aowLVp&HHuTeR6Tq^obv`)OO5zbs#lFDvE( zC(B(C6@e+A^aZZOUfYm4i@#j$_Iwdj0hV14HtanceXY0L|7K9%uUoyV1LMkr|4U8# zd3AMo(&4K+Kg&<~x$|eyPo)PHFZsSQ8N@wwnRe}fbg|Uu2MoIy+n2RFhrj=je0Zt! zTG_kq6Y}K~L!SRw9{2Tnl8V~zU5oxc3YEO<9d}n_ z(Y^zYDV$erS6s@xddx?G*^cw|j~8>+Jo#Gm>R6OzA@>4~jyLT_EA~aEwr3o?V4hvY zEMqu3xMS4`pWUpSXR-tw&YUZ&tKkxlwGVt&!032R7e`(2XD{U~4zUQ3QRPd{MP1Lu&e;VF4 z@;zwj@z@n6&A_D|pTTD#=ohZMW?xN2lf(Sg(bHePS{aiP@uSngDrg@=ujv}S??%Vm zdhcrA;QN1S(!GZz-`Q{V6(*fd`B`$~@;VuX=Hs#l9(?6CU%+>6dU<>`|EmYmZ*=xW z+Buv(^T+p`>b~B9pT4EMMP^$!b)RwwG7L(P&G`NM*Qt}oZ@jI1R>)Rea=`GUpQG#) zDFds}a#3z6*^0SWmTvl4w?+El4kmuPy9&11Jq^=ZMr8P0?$r4poW%cdVPoI}RoS%B`*XgPcd9fz1FK!6>v1E$M z>GPhKPoAp^?4L8aHi)hF@CUzdk?Y@<=KYC#`)=Rt%FB7t)j!{6^XNyP^A>pLk}G{; zndpME=gu8ll6yDW?EcyBvocLjr$=*zuxt(5dPnoEU>4Ke=ku!d9M)BSlD#Zc^Y3f? z|I!u0o}p^XQfC_PP5U#k(fL>M+|-#mOpvd>Lb6Sc9wiB%2_eHJ!u7x>FYA8IxzShxOGzah)hy`x)u3TxC?$1LGroc~zLMIS`+ zdp4KLiOk6S74ohzmg#KUuEeN!I?+rbVGJ6M?#rU@M%r{by-MC5XwBUE;mlW4J+sLU zhBDud2&G8Q{k;2zvOpC_6VY9}p zLE-s5J_kk_r-fe()Vq7^SzQAZB)lf7^4?Z_F-h0bvN4YR{f!@a%LG1icxfpJM{JsO z{C@u~|E`1pCdLvb>pPD=C9@0sI{5vOeyQK8nEL+$4;gy`zWv(4#G$o6{m+g|mAKs}H8*;VMW(?D~nbKXlgB4}o@#VdhqC9H50~CJ9|Nkf-XlLI0VtT3a3Gpxg&))yz%TRB=>_)xs zX@h6_pJS5k@9e)e`>E&TuMdi+nf~3Ae*5Y7$L6XGJ{#6{H2zim-S#yt`sp(*@%B3N zy6c?JX1~4R^LoLzGrNCI+ms(4_U7y){F{F2U}CLO-snQ>3>w09dmp4fS!&WME} zx%M)9V(JXpLwg(cC+^5U%y1yjA<_K7hRHk6$sRG9XSU!}<<*;~?{hJIe(m`n_0B`L z&AE(@cIh{_`GsFnP1>xyaL%&S-&(0lYk8(^e3Rg>ZpkEIQ(3%q&aQniYzt)i^cKyZ zU{o#~cl2tkkJP~;w`Bnv4epoQ^}Ls?_UT>Xu3=O0%{__V;l}I98GNDwZyp?O;pSe- z=em|-9iObcp7QaF=l-85k(}XB*R1?3WWLfI z6*tRzY2&V+R`UH1jowWA9IJE8eII{9lTCfYhqtLY`(7>Bv^rDwrHyx$=*-EYe75@= z>kfK9Uw42hQX~9a{8OH@ubdG7no50 zJ#U1 z%vqwdIh;xCyt=Ys&RsZ)B{ zB{`zxulZjK-Bx^U^7)tPv8F4ng4kK>u617#S=s2f&MvyY>FApCbAAYCr0?1N)%vpc z;{6Q=tVI6Y+_r7|f@ra|3IVU?WC z^Z&h^f698p0o&}GMKAI#E{kXUdm8^Q_2;Yb{Zg~pS(ZGz{Nt_gS)-IlxoOqc=6+rH z(em~7$h_BweqFj>mwfv+|0e#F+FyO8>3g3Z(%YYScXpxKtK^BwELMe8JiUwMo^4cCbhfpKCOYyNNY_zRfLane5fJ@%tLaJXvp# z_32X$r&ln&_$YI%h^4h9|Lh*Nj2ae}>S?*|uNt#AMt{^4TYBQk{B-$)rf>d7ik;@S zlzGI|`z?z7e!$wZMmyTHbmC$c`7vJ)I3JrGaO2?ZU8^@9KDv@SOx#fR{@-`y=KDX- zeSgFyP5li2as1UTJ}2?0RiUaV8cnFU7e5kDOEg1~o8rdfr^g5U?$aLF3(@%@q&Sc^35V zXP9v0xk9jJ;~x11tD0O-Ka!pr<@$Zup+j3vEsg*2dt&R!AG+4E^JVv%wng!_<-K2b zJO7GAR=oPYumc@8Yc4B&JzvnfJ!d7e~zF+bH?Y~B>Q$l&WE8`;?hkAAng z<^Q*n?}9VWCb^r>pUqpiQA=B8_X)>HuExpxCU2bFD!lJJr+~}?R^E&DZGu#xz-+Q^KX7&a{S#~d$1sGoA%l`en z|Gze%V+oJdP41+c`#)Ictm+q3@erIdb0%l`?OT6lT|1mIt8{AVjS}zObuaJh?Eibz zAnsRs#qXwL-?H{i|F*_`{^hlj@9W+!OON`t(&U{`*~LRLlIn{+Sj8@+%5U9&^W3)e zYZ4FcSGbUWtHzSg!i+=h?d$35m|60fSk7+@u9{dpef`~pp5#Q$s{)k=zWQAd6|M`n z&w1czq9G%xrEXs?bMt$nQI$yL%gY`69xV6yXH`_uwBxCDfZxQ+tHsYZ9I(E!^p>T` zzf*>n4KDo@DYI?L_1WROBR6r5TSsv63WhwEkfzgEOS8 z)Bf2ugk3%F&d$7*Ek;;in}g!sX@50tPvOw44f@J-XKTc&Zxby7m49t347niQ%=Gcb z${DYsYkjQsN)qlq*0YIwz4`m&Wt%sgvHrM?_e$Fb<(JGCTxM|0GmF1<`%3@m4W>1J z+$Ndsoptzar=tC_y~#P>6_14p-m3jpbuZxRx#KC{q#8uUx8?nPooGIL>DvY8-Y?i1 zXWM)|p*3b_iRezFh6lIvr>=f~m&2gq=OfjIgL94A|E;lJ;d>*YA<{h}GSubTTqWjL zawX1z@?9ZIxhxKvH7;o0*x=8gaN6Rn-=SNwAI@%nyT2}qT{C;h5;uF?R{-h`{WpCPC%ZpL*O%8`mR<1dgE5pR%yG)e-4+lf8yME*JQjM#+ zD+`8^!&0ns)wq+N_s(b!S$KoU8xQUf;pX^8Z`@e=(iH z+jk1S8UCJQr94$~^W3FOx7}l>s0f($wjX^H7Jhcq-P88JC%iW~9=G4V_kN(%;k25Y zdiO5Rd&pO1zBbKj+r|U_3M+0&Xg1Y7w=`2}jg$7( zMZdma=N-qL|CEd_uRh^=Tuq3*;KIb^USD~f8Ch8RihS zIT&oI<6x=Hi`A}C*WSnMlp^w=DEOq*&3Jc4Q}wBLlH4~se0Zgmm9apGiKYL%?y+^r zp;vZ%JmRa)eCIbqyQX_Y;rz}C{BnFg{2M#?8!c@d0wx?4`^MN8EzHq3KS9XOR&sgQ zoWESpt(dslrzB2TE>%Ac1%Dty0Tr92b zA17Y!WNmCK`s}(@a+6fvxP6oC;4$*y=l#iz$dbjtDoL~ zc%{NaVa0>u7fDOj+8*{E$MUAoRchk zl511*s^AF6?Nb*_IK(zJz-wXdgCi3~>>U$>Zk7l$RH#OXuv9!QH$wB{=OD|0CPi2dn)q zRi6LzYI)(LFVz>~%@0mwIPZCJSKu?RZyUZojdfVDU&QI}ULhCt*#?)-o2-pKIBj~a z_JL1&uVZ&l-Z*{1>D{HdH=e1?|GDqB?dd1B#}-^;PpC_k{`c7aUvk5(`v2eS`MWmM z9@>|@e=|Rqz!H(291}`4Qg6(C{7n1ci@TTXed;)G=fm{o?r-Lpr;Jvm%+BJqFE$(kwZt(3JWn0g_ZI^m| zctg;hy-xQ&m}w=7>enzh&mu->dMcXh{#_zdrk7 zC5@)!%ZqpLU$@*SAGT{3$H~V+?$ul@*BPQudrx)J2rUTZQqDY48JT?X?J`^b@(#~S zJXZSGJavz(F1d81^260vXIyNz$we72`&!lR`IGOR&V0_qSZn=jy^6LyuayH>e?R;q zvwN%9f_w?fL+a~vABB~Q^ljK7&QR6W*%pJ_Q!k8{-+zcUBcsrXiVaq%eG}q9{1ikbu9SxB0K!b{C@u{D>(mWoxPW0 zF;#qaN8;OEp=J5iOEYJcIs7-x?5{56Sg>lV<%K6KORIMquDaW>;NcnfXZub2ukEQ7 zQOIavHz-yA{4c&EZDr`+h0|v-7hJx~sPyLrn_tbgNcF!5<{tEu;0x+r(~~;+4vT`$ z-4@xN3m-*SW`E|ES=aaJrT6vIkC>iM+q5{Z@vItOR`~+4swH=4EifoM5qeN5gDra(h9roe*)g>J2PtTsb>8&ua(rEtMpV!ykO_^De-?n}4+#A8= zOLn&}E#fNEjemCD7qlju_uG~b$J%0-)@8-X^PVd{d;mo5#)|-!xKAjbAw_463d*Lr0%ikM=l~W&h#9RJi@!H7P zn0(yr^pBaEDJ(ZNZOua5ChQGAlP~;f&LZP$JEbJAF-B!GtV(@ncUmv5?e!wBb*{(4 zE(?pSQ&_#7Q{hYS-4KEP-63}BTdmZS*gLN3?>y&MRq>!%ymi}?)Tz@gB2>x*te>9J zE1PGYWZu4_BC6}Y;EKkk{fx(61^2vdaxNF^U#REvZNqaZe}(uP$7>2&b}r~IJaqTi zs)e0rl}c|Ie)69JDulz{HSFFoCu8@iFDpM5J@R~_Jg;(1&98p@Xtfu6lqV~%DVg$n z!DmL6WTQfZ^rCkQ&38Xsyt|oK^-k(bHUnV|m+4;?mlrL+y>%MvR_<5pKRrCfv@Q78 z9JLf~o)gxV8abz3A0#rYER6Q%-QV)|UKl&Sy6o=~?jtEr+`4B=hx>$2ZuY%*c;nZ_ z(MJvzYrVUoeXpk{P3J4C{h1!iF9uufj=!pYfB#R-d)ZBGFS>k(*Nmd>4eHzQndPF%xOfkRhh0-qn7#DBx5 z=<}iI=c_IHGsqwC52=tJ|ixb<`i%_|-r5uHKfq zY+?12*#^6o#+J|LeLuBKo#W<|O^r)sDn2#joLOK0_cbFIi^0sgYFRsu^Jk09U!VT8 z?BpM7&a}C&r3sbh8u3?_Q|k7Hfeo|={7uw151 z_xZYgb;q>M@yb07StmT-ij6UK!<=7V3U}l%99*2!H#<$RIp!~el0owv%{NVVex{f{ z3wgy}ur!SA{pkSK_bjOa3MUS6J6M!U|Lr-Uc&aI`O=!7W+k#&|-yXYi{DsflV>i~! zE>2(F@UZtdTle<^y)CO3T-Yi2P46LV5FsNoK4nQ)GR;ESCL zQ)b!lP3X@&r$4W0k>v>syH1-Q0+l7(3+3znp5Wg#`{(2gK7N4`R!4TZDRX+y9O^uN z@zp<*s(W_DyZ-ds|4y1I#NpR_VWCYD-zJmQ3nHp61hOQ`>Ka^Q6cAbQ)3KyQDE0kR zC-;CA&3|r~zvV5_SQ$~cEKkNe%rRllZ6^(Zlbp{Qf>-v}<;Dum7v7wc@OY8&>8LHi z+J~=gJP>N%BD2Eh9RIGVoB9*K#JdY_{uuUun)_q1!Yz+hpIfq()l4%$WZBoI`0&#? zw+lK_ql^>UZvB48ULkOKuiolZ_f_Tfch`i+9cn-HHcI@O>1wCm(nse^xc4XC4c`8% z&W8guG>gAbG(K0Nw8{YGJp@GHd!jEb)Vc5rbg<;ryl zH+Mf!WNeun*wj8}%31eWInVdJo|k%}x-EDA>-W`uZhU`keKuNCrmnx<=XSxV9?p;{ z+C}Ue9X>?g{}q-~Fk#k&$;s7K`%kC8Hn_Da^qJ1~%1d{RmepTttvmb6qyFxtls%FD z_vV_+b(m{%+cEiAqSUp?2mE(W7cOM7zx(xj*0Sx>@BT@-Gjlu7>gvtDHP>F`@8%Mz z`*nGK+ndGZq1`8#Ld4E&x*@*wix;a10~bqf^;b_V|7G+4K1?(``zupFcyr&{%YV$) zo=&U%9cMi6OLqTyNxjFXz8k%9blmp-Hb3j0KTa0oH4hh`w_az=vr0aE-Hj6lA`V-!zbs-dc%+iVykA|w<@;0PIl*Vn zJvhkuYg?hR-__GQ58YdOBUhn6e81u{u82La8Fcl?DYm`|#(?Ba0N{qdeNAl%gI8_*%oggW zwaTob6}v6fzZhzXc9C(T z#9W@N#3sJO>GE06K9nb}pM17#zft_znq~Dh}_iDxdSV~rV{=IDb`Gxh*b!EN(d?)|(-u~r!?e>Z<=Jlsc zRvDc*%PeR3+>NPJgNuW;b5jRv)ut6of2awB$T)o4@F1RH;+0crcC#yQoSj#hyZ^nI zd-aUpU*}||*Uf(UV*0;pncMa!8rS@KzW3$z9__c1dXK%n@40P$DdmQb_xHPZa;~4w ziJ3kBdBmB|&rj*s|2)m`>;L`l|2EeYyt6sJcVi&Sf<>J>Bu?kDvOyc)7 z3_8E_SC}XN>1f^X`d(Z}qNC>)et(}0g&c3C_I5=2&XdyaudR~0`K!^$&^nCmSipkb z`v+bWeEEE3xwq00-sQStS4!vHaFD1*X8$2+|;{NJ>{;8Gcn$IZV(u z?$EQ{bG>)5@_(VsFGBV5KV{Mx^|LEx*~qbStjhmz<4({Co^Oxr7+Nnseyb)nMf{1i zivQjx>z6%`m@u7JaOa;3{WtINg);y2?q9wBMdbm@&(589)Z3kzS^jb~u?o-KvE9es zF7ljB?W#F{P11Gke*b>@t3Cc`;4e#f5lClwlRFE6Sgd{{3iV|_R!YptM{Hg zI+L$JZj&BIfZ2u9y6Z~gVP^q2=JZ`%lP=2rFE3_)=ro2Vtp#!WERH|eE)_Ckw#M=} z#sIwy(*84N^0L|7RDPw;v$y5QYX!+ot-UqZcHOwS{Y><;a^G*ft3S#y#J@P`!ugY7 z7k72yON$HNi{>Q$XE5sI`LUWIu<`YwIh*>zo1%918I;F|PmTWKGR6MSVSA1A8&`k5 z-T$v_=FGX8{c~*ucNTv7aLRK{r2VsvH`7e(f4^7mePlP`8cY2>;XkRhCdN5C*UIaw z$Ezp3k4!(i;a0En|Nf*+`(~H!H+^V)^R(6!(KT99c--hZ7eo*|kQ9e_r{@U8F z(~tey!nawjbb7{zTiN;3R=@cD`>OYTE&V^grZ?O|WlTB~i*=Rr1VWwvO{v$%~Tpe=f_fDt$g9!Cvr5D4(b7=V=oqV{5U3B;Vtf+F!mFncw@-Q_kQPub^(rU(^p*6Z5DVdcl8Xrw05Z6h1N*T zhBXr66VRwP@`TFi^nMqy3(f#*DuK2UwdAJ8SqJ*Hhgfe{{Vl$D**ruY5mewD+Ffc`ARe zxWhNG^hRt5}*#+DGecS!!|J&Seg?8zY zd!MKNiM+SR`s8xkMn600eLvTI<5_&auJ`@Y%wu!&nsjfrZ)&`2vB+lT8fWtf90IJZ zOahH<3@K@8YB!GLNljGJ&?sTw`Kd`WJMD(gX`?F7mpSIk<{m3ITJQV4Kj>M{=foY{ zU)FfPwtKyl^VcSR$z?$wB$63q&i{R~^V7jr{!{*SpYA`sdi`}_(JPL*?N@iT=-G%* zpJingvP$`bcE|$Dy`>ut3f5_yZ*XXcvH!)uzN0OW-S~{*8s!rVe)DFesDDVXESog< z?Qsjq&a(=entr=QTq)>qdd?uIDDHZBm8AKK>}Z7xN4D>J=BKb?dYjV0*5ZFt?w&m) zeqiaL%+NyB(gMC-Uc)vfw*1(5p53L}4n6C&m~62_qiMyi4JXbk{!%XtT)B1qq#4Vb zTw4o_vkz$>cGthkSl$@E*2Ki)!AhBh3-TK_-uTU-P{6U^mh+y!HvWcn@~vJLX8AMD zS{ywR>>XnNIBiOtMQ;%I?vu;QPw%<-XwS?iQhfIg&yXwT^gf=D?C$nqi{E#l@>AjU z;@_RwSZ?YZ;#(eP)+@u?_28w^Z8nyr9P7LVa~K^9D=t4-uzmGx-mSLxOq;Lp?Ku2& z`}YaW@Ad`vZztyp(r;rEIsd>=mFaMCmt3et7k|82Wn zKKY@1TlF-{_tQ=qrSE*poLN-lZ-2K||Nhs1fewND@@vlSsJ+Iam%_N*W~Q|dYt#Q< z>;FgHbFADjn+b90j{51(*J-8U|nyy>(;LV$yH+E;|p7s2?xrfQ~ci8UCY4>*+ zuji~VI{WRro#**$bKj=@O{q2AuYdQ;_f2y{(zhOYDPjNP;df`f5Bux?EdKQD_E!@b z|NjB+&KI1zD%sEN>gtxXqDg4kpE#LnuGiZqs|gEK$=p$xvfojxS9!6n0*Az$2PR7z zA09NSP1@D7NbHzpNdnK`Y0Vo#j!v7fHp#*~PHu7Sb~bIe!(R7rEMx7~OT++MT?5&J58q>D@o#m>s0ros&Dt4_>-@Wc!2f zt?oD0I=@nU^F!Lp@^963M(N5|DfSE*I!;%Dof&o>dB`SIE}^Y{WB;0>tdKJYLT4(? z4`w>(+MvKt%N6;7(`?#`d1(!-`xq{5c;{4R%%#e9CGOnv|8KM%1!Y=I_grIY(q?dcp=ffv%s6Fh zI{T^TYpr>|b8zHcJr=85lOA%d{q?sz{jK~8<=nq-e^~vqu%Pf!*@D(dmpG5|erQo% z%>9O&;f|H^ES-lpG>E9mK3zAxnxFRt8Q z8sjtV{_f;Zo)`CgR+nCvJO5<4^tOWStNLy33p-dG5iDQ$tI^T?hW!s~mR%>G9$UJz z=;xocpStJ&vAJIJ_Ve5J{ju}vp1u5ZWOBN5n$Ii$$+c4} zdw8~fn)0pv={*+x-BVZIl-vE&{O+u;SGTA~)N1A8sih_J57`>qBOzp0Am|#(aLRy{q54n4Mg%-|ZPczMn4t_l5f#4tsHt`?t5} zU+mL!%C2s)(du^g6X$qvtvADizo_orzqhhUJq~4Y+Ybi%vnQJW7Hm{7Iu!7irAAq! z>)m4e9^W3pwr_5q-Si)+GdUbrRGGc-)W_4RqO0$koWAtV-JG*f^z_^K5ALm=J+`av zMNRVM>4?hcytAWI<>rx%3)1$)l&(>kvwUhu<)NzShcp(5I2~NA_{u8GO)jeJ^4$!$@Xomp9`C&o%hOjNoN z+;?tU!-M4sy!D^IGd4}wqb|guHM!NsZO)0p2CwCeFUxoHXKmHZ+|PXEd*Rk?vac1M zDW`0#bN*d#=p<(lzp&!B!qXo!4!tw$U=>jQ$G7iH73V4zU%pgFd7ceoRvTW3Wcyqa znAP06ao53=Gn!br@TGDpW7_M0Z()lj%HQL^EU{;fMv=i=7e3d& z?M;s1w_p8z#k}R@Kg0Rg_OIU+m{M1`FQ)Q;*v=2vrhYp7|JVDXx2Lv#diVPMbkP;O z^LD<``?h?3-7*>Lx;201zmXDSnP+Rgo0a7bZTE+xxk{mfv=Kzx!ym%-eT%+$K|mLzbTTzVG{9i(Hqv#hXNyO0AMQ zUbZFnuFaxdf>${?nTj8GxIf%^_=c~_DoLX~h29sl%+K1q2@Csc?DK8@Hw(FM&sk1S zyZ`NCM*g+w4$<2-7|q?Dxw!mZ_5MHC|Nn|(_%(l1$L^w^O49otXeji@WV*jN;@o;# zV77DHf)}OzhXon_@E*7&%W&bVBcseSm$m;c+WDPr%094=i&^>2KT)1d&O6$L9d}vy zZff6nm^Uq`nzcVjNY-c90wuS9tCIGe*u3U$S+M(@-0NvGwUWcKmiwgg?&mt4xP~qA zcHi82?lFH9nR%vezE{GN%ER~5$|2;7X|Q7F zEPb($Ix|WQuFjbD<7MDSg~!P!1e=6)uT}+cXeYd0bpF)MP_}^GA^Yqi4mB@%pZC~e z8DGMRa|aENUD7NO&`P$b?Jn+HDCH$7llr)`ii35P*3v#67q6{pn)ikk7KS+n9hMSO{ytNF2^RXzN^>%6XZA1<+>({PpiHQO8lVa!ld2+@q zhYgwMcWtOk=|1&o>e71Q1OI;A&Yvd#@BRDFH5+aIe~xdNR4rPDx1lhvo)H9-C3O?qA}U{6Wf_OZI5+rQ8TV_CDn`OGr!GQ!Zo36 zmurm0)_R%W-j5%0OqIWT(Ccx+=K9IPr~lo*Vf&=aW-a4NK_9N!%tO_dZ_vdOX_ z)YM@Y)2SC6j6yr}6=G!Hu-(tx>FwHMa8X;v@AZ7mTy+&6uw(y(a4J zhi^AJC#Tlr*ob&*%l|ks+5d=O3KOHF!>LwIxk*YQrB3rqe5);L4%HPUoljDCI90vt z|FZ9IRxjIrb$e9qg6Lnj-QH=GKJM7{{Em*2tAYQrg2x>R7s_*j8|yZ8+6qTr+pxRq zs;*{t#7{?2zvWpn2j^r~q}pxDIlFJdg7uO7zSa9ad+tydz3?e}`@C8ACn*GoI&7PL z;P0!i*-xilkJq$s7OI%)>#%;$7p*B9pJr^HXZK3J@_}5+k7GAqTH77{nBQUdRn|Rq zqJzMz2QPjUyp(4W=v$Z~^+DZ1=8=lP%9bFW-xHWigiogRSALXUCMwgv%|~|fpF^)J z`g-?NOL_3VN&fq{MBtcvsEWKW$nWcp1yZeKE8bvwkmbXaU;WTQuQ$h%Z~O{Z-06~ zO6E}k)26O}I>P^@dXrbQ|J4HWN-zzTi3+_9!viz=6XzX9XGx@C2 zDUL;UYK;#J%Xs^XHl4Uta`x>mM>r1~ex8!cD z`;v#xFLo?@cx;OH`&jMg_n$oJeE-*=?^yNM>FcLw%NIOiF|yJsnLEqjyjm5j{okAZ z(~ryB3p;$^|Nnu%SxZAAhw0#)JIdh`<#YM_Z*pI`ySC-+U(H|6i}PmvyEVJCVtd8y zzee-!HY})nng6HKX5O2GR94pJ^Y;I1Du2J-?i?3T+q_9}se|M_vuUC_vm?Sjym^yz zBe#C#VXZlSvMo&RjSJtaNSxV|CbuWu^7FhzyUy=x#81y#aJS0yruWUSK?S+ur4DgB ztCsHh^2+<^)amh@t>2#Cvp)Wvw|lCgrkShUN@**H;R`433F^*7Lvfxc|eo)&&>J!xvT@i#)=hVXEC?V`^089TUVU ze&PFeiL7*nrUtiCfm_qBOP*%A`OYpbHD~pjG@+g^J}X_Pn(#B|=M~PheEaeCsp=`} zcO;?tZ(^$zyYbrolKJ{?@45Z1uH66L zO3zI*DtAZhx+pX8V)?9la=$(H9k}b*cbf5z;jw+2l>c5!s8~Pe{flHTkJ(&>p(g>|ZI*-#TwN|WndiLMM@4KhIo&03_+Z6eYye!76{!LVUb5ikD z!=9R_MU{dIKMwwuKXUWAdB))boIU!BkGq|^pdxJ-@VDq$@$yp_gSVVb4o>}{p?+t9 zdVuA@dv>>2Zzj&Ku5j;j^yd~>Rk(mV;Bno)1veOX$h>?L@3`PoXQ8I}w6l-hqF+Cd zsGgO3ZO-diwedSd>!(}|ym&w2#I|E6UQJ6*W^KwYc*9c2mws*P?l$MMVpAMf)|M~W zQK_~^q3Yt@%NsJLCtR&++i291w=HtlTBRReAMf?-yjM8m$I@LBr-y1ROjA6S;~2$k zyHII*%O%r8Gt#f_Ke2V{Rc(Qke4E0nr;}g&Vq6%+emv0H_)OkoyH7TKF^ktEpEsY^ zvPkpj1?4x(ES^V9HO@17ncwKh^|Gw)#?k(U1+#dp_Wi#5KCkY%^?gp=pBFh-R7h*v z&&!aOQthoXD`0ZeY`Sb59J?Y1m1t(B1%b=hWeF?bQTMZkx%Y8x)=@9MSRAfB-G znDm#6yOh`L`t7&ldfo_qO8OvpY8FbDS}< zeIN9frA5wGee227n>+4WD9w%#+cbIA``ry6Y8~f&S{S#fW3ulX1>MvO>5hxKS@drn zd$x4u{52AvC;Ys5*8Xs9(7QV8Ywbk^Ob(6Rv#Y1Pu4%t}*Z%*{^UQnp|NIucu<*c! zea3It1UO~WkDq>VQaSa@m5j zvD_~5THm#2B9@w6=Q0Y^&VPMZv3qH&V#&5^y(-rhiyVnI&p&Lp%%6E%*n)GMDXiNz zEtQl_j){3T$8xhE*TSt2Q}+b=2_Mld>X}~7xHc*ELZI@TJRzy6{OhGB98}!%zVgW5 zAg+~H8n<%&U}>0_Y{O#uK|vkpZiyU03+x6gjltaK*!|zN@XS>cfYQHaI-?t=ff^K!$8{PJ4s@6ffe;@wmHiyM^uHiT+vn`r_^@H}0HV8?#`S+}v>>!<=_U(BL&wsW*$AN zwAr-CAWhR<=AvW6B&B6N>D`kBlDmRqdR!E*in|}bx=`)Wmj9(LHKu)k|8Pma+*!)g zTX@PY;AQTTbIxZca6g)5`RT31%*P8D^n{FJWTUVCeqLA_^vA}mnDf-FMQf689^KIK zJn;6@t!&z5u4P6dI~VXV@vIfr?71MgII3s2vVhvO2^UvC&f?j2?)$_Y$~6uLZ+Pas zb7k7p&Dx}WD*f}CmyN$}a2uKQGi!HmT)ktzD`$!E$&1nDr%uk6Np7!|di8)~ijVnx z4@(&~jjFDb&1rnL0yfejj(sz@yB>J#T->uj#PQvl*(=`PI=bo6Tb0aN-(I<;-$-5b zxmSvNzx86}R{q_ofA~M&&GIPN^1sNg!a+cHjmVM4NnvFPsRs%i3RpVtP5#SRDg0OV z@-DOL?YkOt#2?OIZ!Obi%Vs(Mt@K*H$GiC^J#<;`S?+XI@8s;OLgk^VKlU{*eaAP| zaDlPGEVt>uSgTo^=K5I36qXk^o>km_`sa50gy#>}emdrzKQ;dE_w^RqKgIH%J4-}| z^;8MX{g8fs9{Rvc`fHAt z?eFqc<+C?EJFI@!aeWVqEHQ(nw6^RA0&Gjw_lg+uO|TZr?e5 zR$0#W`O-ZLxY=$VIVG&6y<+!Yw+kAlBVHv0ar)k`ORSmIzgTZmPW#)u-yGYPp5xjx zm0e^?^!IzY;&*eT4=zd!F;;!LPTIEd@^bal9J3wf{rTfFbIwv<3+5j;(vP3M5P0SI z2EirLVg<6*D`#4zv_5OHIwioKXE^2KW=8Kx_nezgJUO$Ckz>=LubbJ74DW?LPQze2?2TX~X8nR{(DitZTeN9~fF?~o{X;~(QeUA8?pEE3h`ILhkt`l#p?M6EMS z+xelC`K*z8!yQMp3zNNGS-w9Zu;`DaMw5)Fxce=}En*M*R-DSVeN#L!u7K_3`-yBX zum8)OcXIZE8!SH!{jYVIXU{YaKPCIhD{Fy6!PGyyE=SpRFVvW2@jFaAJA(B}@(I>e z6;)MvOJ&@X4;zR$HZIuIYI{Op)wHy(xyL7OXZ^SK+X{2z57wsb92`a0vi$95yG{{o zQL?a(O`G?rW9RWi-s)=`X1hwI^FB|Tc-`s|KnBNW{r2BwmH02 zSaxlHs{MiP-hCT>NALQ#?CF^qw;wMI-!f;@`x$eOTCbTfUF?*uh`0Wx$M5cFKR@07 z@2h$M^ZF^*<0{tX7zK3Z@7^7#XKf@iWnO;GXX!Z>pIRRYrld2rS?=`ydeLH~s;O6X z0JqUcj*l;%mq#);S@!-tu<=y7<2(juuaH&KD?c6;cYe4 z+w@=Q@d7e_j4bSot;^-CC6`a`QHreFrf}(9tM51S4_|Jc!aC)bR%qA< z^#|2ow@yF&@89nCM`OJf>~3dujg@|Jk9(%Q%lu=zPIsmY6h69h|NOs;#!p||d}+k$ zUC}c4&}^+bwx^|qDJi<%*#ZYFpLJ@KlnVa{DbuJtc5>-szQxLJX3xbOa#$~_mtAw~ zc;>I%*Y?7@Wx}at21$pnh)D58Uvsm0xUJeF);M3$n?u{IgzJ)?-Rj8&ox+|rr}6|D zwi)b~sQq>9Y;=QL$d?E0RaaLX>n;mn?KKRlER}i8nayDL+W)In;hDM3Dsrab|G560 z@%(Gdb@v5B)Cz5vJce^xOTNvp>Yo?9Z-cy~$9dy<3`^$i+Q$|;LHTvw+NqPx#ZGaq zvsl`~T4P@1b~npHQSZv$q%7M-dNN&$8TKvKVGfJ7R1En0Y&Vllw9@~8)HJ!B*KSH& z>7F-hp4jzM65o^gR0Tp7e)*!aCb8jxaN!Xdqo(Ek?L7)~f|) zy>6b(U0!c@@x|Kjx&Jb@ObdS}b#}t<-TCzDzfZ#NB$IZ=FG~^_hS7Z=SpS z?|$V6r%$>vCp-dI>+br0{oU34Z}OMjIX(M-2G~FJd14xNVs&@wL#`Z=uv7ATsuuqF z5I;|Q`ngy={l9;nZfd)yomw)-gYBk?k)>(izaP@|F?RoddI^U31!VOrI9!{r*0@0U zyt2ZNz+12W?Yqp!@^*TYxZ}KrBWIO^ScEyeG(~1qOc$Cu0CR*iQjq20*)+BhYd}l%S;)9F6Z@{?4SST z@?Ueqvlivu>FZ0rRr#0y-t+b0Zo70_$^GXgmn{qLU;Jgtd~b2Rsn_pKkg8t0=hvy# zSAJ?cD%!AzmdQ2DE7ebU{Z=aBy8bT4i;NZ~XW8bZ-}oZo@F94iWb&&s6)&Zkmy|f} ze9dyk;o|!F^~npk1*VOw5C-v0Z;&z9LKIR`|iajO<{YboAaC?^4s_2|^8I7m; z_kaJmqopR%Cv&SVOY7GoLJbPP*led)vSvN_8g1TO`zG@J>FqcFFea=KpBmM+4+g5P2S0$!q{lSW7PiOR>2sUp|ELj(>pb={HXlv}BV;+mU z_&T`?ZZkFAP)I+u>s{IBGmK{zGBwrm7%(sX`!!|a1?7rWC#3#Ksdsw_$~;b)IMuiB z%Ob&Rc5Dh6wr=-3Pp#XUwRQKcPwRgAHYOZNynJgHZ?O9BS2yOhyKUGVA!-;7Io*G{^}GJm_`g3`&wZQY-0O39<@LkMCMqkt zpL+lQqWqCGK~e5%P3C8QK{p%t%KT~$u39;_aP>L4NVz>y9toG`9GUb<-(6C1-l`-M!r32Pba4bpDV-*+=6OQ~enJiD(NjWSu{&qO9D^;N-WD z@yAz%O%Hb85{`Lxx1!WPd7tt5(nWsr=YB8SpC)7N{O;crg>zes_TF{Q+nqM+9&2k; z&f8;8H;1n<;oSfA#vX(7miOQ9{V(_C$MjQIv%^oH*5B__yPvtWY~JJl>yGT6DSp)2 z=5O*Njomxk*-l+~*;(`{Gvv1q@AT#SYqs^wZ+KNzv!sM)v&Q4wZR=cTONC;RkBugMepPNLL9p$uL!&GPIS}a$=jQbcqy*h z{L^psp~6LbA1mJ~`}i|qYTQA0&AV;!S1}_nu?`*nN3UH&iK0f zzr%&O`=(A>{w3~-omtBT6U9jn_>voU9lx?R;CdYQb{jU4+U8RMi&sR&ww`W@c0G5Y zZr_?cibl2HcwGb++ci0gm_G7fb~P@%bn&!`?AFPayEp6*zOlKj*_OK?x~)q4;0ktu zs+5_%N(|QmS2Vqnmua;&_N=qn_{hOa`!n{^Hs9`Cn#y*2D^TxkH~HNW`P)#l|g zhu_2cH;#vlS>D~_ zEbINd*eXq`+CR+nyd_)CrY+xJ?Dh?t$5*obg7%Ni@_!b^*wruH^W*aLQ%Aoq_;vAdS`wu}4qwy_znv&S&qbC61CZkKRNbh|!mpY76wa z$Nu1T`tgq(B5Ug!9$dMSGIQ3PL-*KMNb+7Kf5vzHcJcPpU!|{Ktll1ycXyxT zUZ-AlzWZD6%-djSW5lwxv|({j|1|&lcfkxVKYn_WK2PKFijJ4ZYfGwjl<+#_zH-%R z{<}V#;b5tT-|G{nj>?NDh}Vh!O5{$^2yr%9#mc<*y@BDC-2T$MOCFnJ#n1Trb_qRD zbG+}TFe6`zz3`az%Wog=8^2~cWEE$8cC}&>FjYd*1Es zSM51YOZ0VaYUMs5xbD$&Hb;vSTY9Ibp8WHkjb(1+c5}B}h3zlrJk~tz82j{~@>4PE zyDOL*l;1htS|fh#qd`LfgM)>`t;;zQfp^b*c`F)m+}qJ|&V!i8iJulLy;|rRahk!2 zvsQ~`yRXmjOW8WVtVAwFeSPUAu|_s%^&Y+iK5>DR)LZu#amdZKjQYx~GK(=*izyDf|FY(Ty7l3*{Cm%Tmu)_r zpQTy0{{CI>?d8>PWUsKg+`Nb`?Yxk=*2F*rJhW$U!<{!IQ?04fV=dI2+f&zac zW_?TUK4P|UzDKHe^6q7x8=h`v2(;IXnyw$uC!l;g=%?fQ`G4P}Z=C43A$gC~?^wTW zXYC{|D|bh#pRE%U`8M_AM@=&Y$Fov$TF3q5xK}Le7(2VnsbU*R$l8)h;q>Q8gkQHzj2Gm)zj1UrfxjPo zz!G=;_uCHKKXogp=b34|=nPJy6mf3W>(&f5j4Tg1N(z$L>qL2WIWC$tW1*7#P5Y=~ zu@D#EU9)bUV~AMm)4o1Yx;Tc}p=~>BPDS|k{_o~nG*~q5_J!+mZOcx-^EyfCwqJqz z*Amu*9WKA`x-33qwBUo-r^@02*Dwj@=N8v1X7;MRGdOoS#L0f~)6e!=OD*-I)a!)5 zi82~9OxPvPa%#&u>m_#+&up9@yM>oAr!nqO@somup4(sDoO{?&FeUus$=BTr>py6O z9O9hEtg-2H1p`-Nj-8{5!-SVtop;^om>qjYN8^cHd!O^|12z?mX1f{Yu^YB?b1X8? zO;~b@!^^4uPiExd6CD3;hMzKQcp&lIkc%Od>t$f^*P83iA;)76y$f7lH-Y^(*EaU+ zyO(S`yxOwk?S~t$8|?yjpN?ZJE6y+barX~@d$ew={Lwn!zYX7{Zx!&de82r>s#|sZ z4NjJsK7umk3A6Xxh2N|EYRh&Y`f2RD_j|tSm6aLp`;n$GGw#tA!NY3R@4MswBn7bT z|MzwMbp4u#+=h|fCnvVPQTfZkaqqpDeZ`-f?w|5_d_P?8xoE)25~`}a;$u(J*PDC4 zT=Fiw)GDIq=+ESMf8vV;fnvMnIUQ{N;bV@Sv z&^J}{SsYB0eRUW_j#SOe*B6&RHupim_GNot%1dVdO_8neuV&h(!TvF$T1P3QUQ5r7GZ4w&AO4_TBVyj`-$Vahk!QHYY0`z4jhh@9w3g6aP9fCufUH zJx{33V&>FOCqI6Q6shR{Lts&a8ZuI(g5tIh)xyCcaQq zh~efE`5YI(QX1-|+qfYA!6hlNt+UN9Us!(Zx%9&`{iUJI*FUNr-|gUb(T;7c+y3VB zWeMU54GuC3=33?ps|-%1qdPYuf4)Lgx|oVsnwM*H z-muL3#&yo;f@QB_d;T^2v;Tcu_E_Luvjyv1tFCp6GJP;H%w8!xCs0+KvH79+eD*bo zw;C3_dp5OHC*w+e@APXggq6MHRu}pzDZiL`Z1R)m5F)n`Qcmo>bYr#t3Td4cO+4Px8^px&b*FrOAEQxh{_NDx?RrzT zU(l}j`>OZTrO)~s3tK#SMUDH^g3{*9sek{yPTz0RkH_}^9xG`~nX10@g6Eyi8;qAc zE7yN9zTf|D|6eJO1IeehU5q+oj@H;6vnI}0(5r-c)Nd4}u_0C#w;JjVh{7dgt6@(b1)EXE3 z^;wWEIZ0{l?0+w>^W4@+uhYL*zI)UCDE713jq?}y8)&GW-~CnLL-%Bzg3I=AgP3Zs z#S5%BcVL1rOAg1KYXO{#_RL$hdAah6n!f=|>dTKYeem6I@!7`Xek=kqvu%UsRRyu$ zQ-1p6>YEzTki=rYnKxSeg#mH!k?VAN^x@rA~|M8vaj#nZZ}} zO0I14bk4iUE3BX`yee5KvUB_2UdHD8YfcvkJv6Ah_g?T~&5f<9pCY8XT=$>(*x~Au zvTUOHXWrDD*aZIWtI1}zhbuV0t$r@aeIr#^|CHLXTGql@Q$V3YVbs>TT9fxI%Tfca`%bR zA^#W5cI$H#4f+4zxIwoqo zxxP3CK=Xd?MKNq!U!}OK=dD+_ z3jZ52OOCJN?DM(bIO-p)SJ<7~tIfV~u3^6YUDNZo58lctRmdv7^EuGycXQgG8@Usk zXGBbu<+yQkM|tLhSfTyl)o(wYYMlGcD|!9C2Tz_^bG@)G*m-E~{xac8iF1nkDmL%= zrTyi2?2f2;zwg_-Zhx?~=wio(K0op%ZOI$sAda`zD<>V>UDxDz_p7+dvi(J^x4v$VPm4I5dEI}* zj_CR=bAHOI+&Eoza`(F?`}a(Cr*#epOQ>HxpZ<5rtSa+841onRt~k%%yC(R3Tj62{ z9#y{gJepluGLrI*m&#Z5EGqtZ=B9D#Cyks>FF8|+<+cAFJ`o|eKHZ*s3G2mZ(7wPgN+Lw}-LI?m8c`?2taz=$L#tVv6pLT5iTtZM zED$$u`|jLTx4#)ja(%d7(78kU{P)9NQY9x}Ja^0g&r^9YEN-s$t5jKu2BAhqouIoW zT`}^mcN{iuUOtiI&9sFlb{@X5xtq0?`|~%}avA-wu7`(`LZf`=uKyU9%D`-wdEd{k zY}MA@6FetRZYw?9acs{@Bdc5IYOc$;)~$V7Dz$j_nN#~pn?2`0Hn@LRK%qqHfR&2C zo_#C^M|gkFJYAg1!eG(y=lhR6R@{=$S$F1mY<$Y{cdA>a&6Mj^oA%2bknvOKkUO|I zouTRc9Iegst7NWy*yi-o^b5zWgLgHz%&uE3qcXcRg`L~kd6#bO>zz+y<{Jl`-dNhb zEx)v3u3dTcrq?F%tIDiDy-WMPrJO%H);dc2((cyGU$#t5XK(G;ZL5B5cl)oiHSedo zRonM{C{a-NdTZ$U_y3!{nZ>f6)0TBdcC8l8p29-0IHtynK zGCMszbeH6jr#5@EG|woUw_#n-beM-_bBUq-^Dnc$oGHDk-|Vp7xBmUoNVcY?9clto z?3x_c_sOrnbflyw{ZGyN;(s&KFU-zYUHVCRaYK6jnuk{9nY(_ycwGHvm)+?gH9zje z@~uJ#Uz@KBOP-v3^~zDsS2O)Mg!C=`dpMaUICadp@=>^U#XR{XIu9AFIL}F1Ia+qk zcbvQOhkt~}%k28v8lgAb3Jlw}Rz=*uQjufEZCd=KY5L3G$Fl!!4p=hzUcu?)io)us zb(5z*HLU)}!?@*jd&YE)oU|8}^{`kH}mzlnwW@*~$^5NThhNk^{h1I+7?C4eWD_fnr(c=1gxkd$N z!vhJE<;r^Eu76x?SSFdFdE#KfT!Xz6<6lL7p7@2K+V$|sjJT=RU#^xp9m?kxXo;N{ zaJhN?{gBUweip~S?sR_t!rDl5y1$0wjg-tI^MrULI(go`uK&4g79+>M!}tHxetrDC zpP6T!P5K&(lMhUoAGN%GRCk?&i)Shy7tiNk>(m}tcpUxiZ_m!^#O1o1ds|WciNDK! z>f8`~u;NmQ?E>qTz2%cTq~)gw?YichkSxu8h9$O6!YAIH`S81|g({`9eY%*IR9>6= z?#A{BUMup77hTagZWkon_)u?h2-{Tmk6YF}`kM9sltVygg1*3+1sgb7s(&x~`DD)? zuXZ2#+iLsI|BEvg2syjD%Dnl&8m4czdZvG#vdxk|bNV8em0)1%KsS}TdnDGv8}!Sl+* zjn$kXORe|JL#xfLSqXAAe&O$fth~5F6}2_5m^&W&Qtq$7(IFtS>_U_EDZ?F-;Z5#M zj?EPw3ojL$_lKP0D9EZ`6xY~wR@`0s!{1lE^-e#OcYR(v$tiPdyQbysoC&5at5SOx z8|(gmqm+7kiT&;R>x?bZIaeaSAK&Y6!B_Q`dPwM-k7c)1w&+gbd)InO!r-Mw?2Qp@}9HP ziND=*1JvVPiY%H`E|IL|~$z^~3DMW40UUDwQ z%f|J%mj71C$F>4FL62YjHkaf`Q=9(l?nA4RU%Kl>7_yTRW}H-SQ1Di1+WpwRW8L$E z;r3zrY4IWdf6V`j_pQ5Xl{xh8S*%#p+PNusui>{o%d#K6bI?F1lFsT*4f*Di} z2={Ov`NJVllNs~p)$uj256`>1v^)HXk5AL?tA}i6dok2S|JmZbG90^3&)#m?Pi*$P4vdkH!2MnU4l!+ z^Exi_==S~;U#Po5Xv5+eAzH`$|5-O^l}*@M`EH3>_G#kvD-dxBr;_2XLy-s*JR^QaCie$llN+vXF~0fji}IqJmDlyzIII}j z-7MSKxxXzIUOc0FXV~3eSI@pWm!BX0|C#-t?^i=rn>I$a^c~_TdcGujLNVd!r(9TKn7BXI_V=FO^$(dR0LBg=I0l|5mCn z_L*4ZSTB>Ew=TJJlZ*`?~Kte!Y{gUnBPH*=p4_AKx$3 zlT2E4+3wEV+uIG~YPSAbz5n0#tNZ`S|LclfaD7$3-Jca!)$er59xqEuvg_p9dEP4T zb8X+{IXh~v*PKhd_ceQRn)}7$TQ69JwpD6qZS+V^Pzagb-R*sKdi_uDuV2mYEBvgE z`TO*>{;K?a|JXQhBz=AJ(q~O$aqpDLuOxGB`^G=8*jc?j@^+in0N!NkvuqF~sBX9wk}`Ke+ctHEHfQCA=toxPro?Dkayf>_%56G2ak)dA zc#}zsZ6Mp}#L`WV4R`VheA)O|`uz+}Py4IpuY9_GMp{f~RFY{{zgxG}j%A18ye*vd zhmP)5=rPZ@BP8PU_q=JATmGIUeANlZ0%NbG#vZTuH~BT(HEZbYPg{ED8}HKA*@}0?IIbPP(R!+) z)mM$d3(~%-$MMiW$NGAS!;it|NZ!?@TVU| z44s;FyH3hZQxz<|8++!6`FlmP%N1`n{+nQ7rjWJ$TX5Ma{y!i4>+k$OEdNhn6({FB zwiKxunx3Zwb!X0N(wrpl+#vk9g;aJ;lFgZ;cUU;;KAdE~TK|3jpFY#(n%3Bv+vYEm zXA%?-)zW)g!gI;z#+@UV9QvhKHU%$wv{6sYYMyjz#jvU;2@oN9X-XnMJ7|nU8Gc$uOfHL21L*}O1-oCl|`5~3-KTpThm#*LS z|F<<`%ALQ~hGvq%*Ix-)XH1Xv*e@n8=;in9Mu*8^PPNxQ6VA`qz3MRG_sr*lWpi79 zMCT-QrTTtI6@Pm>d#z+}{Pg1i;_Y1}9y&ey&v|~FvdnM!zb)s^-r8QQ^>~x_9z#Zs z;_^$YS57~r_@lY+)@ASAA17|v{LG*6h=D_%%mJHYHxE3viQiGe7^=UY`}wNw?~L^` zx^|whJac`0k{ny+!%7}kf2B;*xhn*}76p6Wc=cLLQ~d3b)w^Am#zd!!sotFN?b!pN z5J9eA-r9nJJ(tdZ`6$1D(IELhx2M{J)Z@hyr1fqp`N;iQu=5}Tg9C%7i(|;ddXZbZ zL#q7UEFZl3{)qpsVw}U3U!hzDT=mKRj4a#y>NZ&PP5Hz5>CcCY8ei4+lr;9Q7JX+s zHKkVat3kuX>i(@;-@h^vD3RfBd&2K;msiGEo~6^?zSQ;Ci%hP`f8sXQ&+2;+Vqkjm zTf%i-zo2RS7G~##J?v)1uC`+l@!MGTL93yF>4C+W8y}xn+)@?{JtMW{+jjoFZ>?t= z{E+?8`S)%s+u;W5OuJqCzi~4)EoN|BbE~}J!Ey6d{B^~ffBpUcC$h9P_DK5rIjt9h z1f(`^5UM%td)Me|z;qTqUh7$tc5Y>CI$d$PQqqo(wDOL6S2ZQTE-wKRqJp4z%H^yMsH zah`0xqywxc_zIUa&ik1qf7elI#VtL))Z;BZ$MWU>epvGB*Z*H^4nLS5d`R5dao16D z{-4UGqp#;R{<`?Lf3^RQqToXxU%t0nofq?5Md(Uf-NmP+fvaAZG);XrYmJ0|pP`D~ zUWW}g_Zuag$uzm|dg%Ry`D#D1!>s%N*PMO7>6?4~W38LfF&?Ypa_{{8@gQ(T!~ZY( z^{e*%ezrTSEN@%YhZpS(?Orcu7(1O>TJrkQR_+xB>x|AHVfFqeH$8_uK4M1f_kPX0KQ=ZHCO*YT=V7A2FqcGt83vyw#vzFwM?k z%k^zXQ>2zzPKbN6pzd^o>9x#{4;P#@GhZAbem&!7-0n)LjIyL{duFozytS~^XV-Dl z-;*Y|J%5oW7;vUmaTedE@7DuF#K_DlPArzL`u*d~{r;s3AT`{#Nenle>Qf!{C5VF+j+coe$(?tqjk@TLo?WV zyynl+TWNDK?yJk~ocQ;%b7wm3|Fz$Ffx*Xy?AXP*E6&Zc?s?n)<+|y#NQ+}J)-R6t z*H)$mK7M%eO;6p%Jh8gfZj&-TI>vCndwB92^Gi-M&Xti_vaOzu(yNwuS(m1sp73k8 zTE;PpxhYNeUClPnN$k1v#OLR2or5#jIO5_{wi~joI39VpLhO#Q*S+K`i6@w@ywyk+ z=g2!M;$zFWeBB%wqr%&X9btctdaz_GypZg@o_~MEy850fiOvW6fAR0{Hf;``zC2M* zAi$u*V(UM)Zn?+e^Zb-bSSPtV}$vS)}@OrSLueV%C=n?=P6_#vWr+#{RFd+})04YhTUpYx@@btXff? z6neUG!5J5Y8NZFYZ_K<>^GJEitySeUdW)_V*Um^6sQ)Oxf6cz%zka_uxSfBMWk|Kr zwpx{Dsr_>w+}QBi+-`;4zpH<5JpFO|yq#-m&GKEm9DC~j*Uk7_uy?^L!{6Nw0Rhiv zoal-E|J~ukk!9~#Dl8RdsPSa#D^!1D(NuW*`u*?sbsfHn>o`k#7f8FzJ7>drK`lex z?W%MGTiq+GZPMTK!pz^rt+x9Y{{8Wr+q28_!k({BJjSZcn|`j~(NTk3-u^q!OxOvVsmF^9dXQo^CPhFD3Aoull z>h$IE+JWMKEBa(-FL}(Ooge;J&00jF?AR0=(|_ePLi49vUyrL^(|VazelqVv`xEY6 ze}gwXH>_kb|NTWHEBfy_rgt_${s9(Ty=p%=h174nwO(WIQ1D6TxyI(0M`t8?vf`at zd+MXiXO!9d_xZL+&J5|(+rQ<+rp&7o-p(~{+#L1$=Ydz(RWj!K-qR6Ewsep$Y2SDu zs)2KT&*vZ0-`zEMxc|u|>8-BQf;>a?^4HbcJeGetNnmSt<#I-rVqISO;u5|Juj_mQ zUlunXOYA7{{hJrP`0|?it@GF2nEvwjI@uWJ2|EK%_0LN+t2p6oE-4(%U~*kU%1t37 zdUvL4=H#r)Do>Y(g~XqXFJn6RrsL;O zD*OBTg;H)xKi=D|)w{bl#CN5X7|W;6Df6F+drg=gUbfAoP}AIV(angK)jLEU^>B3X zIKO!@;|>SgW&6up0++@VeGI)^aqgdcobuaXHkT>xAIoN1$1Gd%Kd{qb`ikFy?|=W2 zKesr4!}hb6>%t?JCn-q8Pv!ZRQU1%Uwz8xrdC!}@ciJPlW^_)PHr18qA=96KKlA^G z)P8=t{p$Ak`s2qYx*M*{|CGA&?%I?CwM%xD$$I|YnW@see`Ve0*Z!;g>ppwtD0Ip$ z^|0IWKFz++N%X`E7D-8kUot#vFUrqe<@fl>#}uod>3ho0dbTGYkKuQWSv_@!#bj3D z$T+KNj-!Ng1?aOZLDER%a_tm%c`Qh8` zc16~H+5OvN$GMR3b@8j()H0*5&F$0FbY@xEkbeAg-prIKH pox=HITSR)g?6(O< zIZCR6M^?It3214S{9Q14WvZygE&n?+9_F3Ry>g5x(ma<#%zQ$^?>A~;Cc&30U{`fOl=yeC7R1LiZf^uU9Q)GG~0S^JVeIe=)P>SQ^Ln zZkm_>>XFC-znAwja=sPZGd#D#L0}dSqd@QLG%?4A6Xaceo+z*AfBXMialPWlL?^$~ zWa9~OlVeT?{Md9bv3h=4XT_9@ z6?1(x+I$iMRxZ-yUN`HlsN@s-GJ}|$eGL{bS6Z__Pgq{aE8}o|!`!BHR)s0WzjfkI zFEEf?(s%dRn|oiC-7^>Lei{33!T6tGoYM!TNSynQ3`?%Ng^(UHPAm zNqDnFJ61_NOMNgkdDT?OYT=%(pKE+7xjJ7x>QCRcs`#B&oQqaRVwS(Ir0b+So9nzv z)qDysHkMyIewyQ!|MRwrM%7pGDgt}TURwz{UI}41c>k~eiuEi_)0h94wPc==dO%^x zHNCyT*&pUK#?Cpy;QYaoP4{|YhcK_|Mv?o!&efM%IZ0Z(nn%ig$#|`_AC!cjhcX;Y zoBHX%+aIiqLX%(om|O7JZ)H%p)2&Ne;-h~s|6LlpZmB~++no@@9SrwPo4&e_@SykAv%9aavVXs+crI#trkN!V&%uD39zsty>RT3Cyh*LxrupsWqVz)f z{;I=|%NUElEnMr%`)!er%KhAi*aqt*>e@LbhCN!ZdQ+Eny-Z=hdg9l5E)HJ)58Rtg zW43>|e^6gVXO6PB*~IcU7oI3qObI_Fkad4Y=cT1p0U3{PeCM$?X*z4qu+AZ`t6w%( z!jF+9R%~Hv*Gca5M<>i1AFv4R4=j7K+Ewb3nUX`njNgt27S!I|=@MOP7~k>fg!$%brLQJamb- zN8+){KNmT>*}+Af`cXp7pZacx-q5;j@MukvdCL(tffZJV#GV%(yJmXjvi$j+_R5+3 z&sm#1xD2~&8(S`HZBAwgDpy!uv5m2>Wbyh-*P0G0-ugbBkwwxXU@=#xLVThmsDH@Y z@E~1La1I;CF>x)SgS8=t7sc;S$lA1wO<^YAg~^H^WNx1oj=W*}c*)6zwm_auZ;z=T z)>ia<>ENI-^L=pnOEZ;|b055k3VS9ZEBoR~V}gi1@3n2FoEIx@A1K{%OhU8gCmXB% zh4@=jUq5Y3coqF_owV!M=d;?6oY`}$|8=nY1i8OY|NmZ8)l>NLIDh);_y2A)mo=;l zJ1?gb;w^LG-9?}1XlV~0n~Ui?cGW&-vu?NVn}7UbW|WJu@;uemR=&53Be`B2xz18` z@IsZ;rl0#{UGM!1@U=Qwe~G1J!@ahN`@AlhTvVD+WV>LJ{n^8Rex9Gt&QbH@asO3* z`x^cSQLaHBZI+ZW89z%=iTC8Kl3jbMRXe9>N7=qze`i~-XwCG$#u4{?hu`(Y`IhBv zXJW;lZPDrXuGJR1`dNj4N_drf;oDeFn-34F>{VN%eZp3i#u_h`H4DwS{pZ?*1sZ}O zx3-@QjPjesboDF`%gXr<7v?7v1q-YW5je2oS~`EQeBGSe%b$LzWRm5%;ANRT@2vL! z;DBkq73cLGqGMv+S9giOlz$c<@_rs8gSOxmp36Tfdu*=@9pt>muJy9JW&#(V_EJU$ zJ_ZiuS|Pc6rF(O-%x`->uiVG^=I0!hM5gQJVjN6d4LhcU?yCBz|D`XxBkW6W<6&7SQ2BkSG2$Uzo=mW`)uvL{RemUc(GVJ ze7LtXOX})}b(aqCuo&)|!a28-cm4|tM!72uKQcd@de)}sRbuncLV-!esNm;=$Cj<$ z_iK+Wd2M3ltNt)K-{<Xo!5N6R5s1w(a*`xuW~!wKXfPQ>rwmK__OC1 zxc#|Yes!|Ef%YMnwVVPGem(u%9({VTJ7QvY_Gr%Rw_Ek@-d<_@{)LzOqU>h67`)J5 zZT*YU?*3D|x$9N8RL(xk)hAQVX!O9*_m{`^oX`3ywf*y3RX+S?zu)SZ(d%6Q`L6jI z)*89}H-GMA@b}U_lD*1w`LV#C_jbsvx^FFi|7r6tuhOT_p1u+ba_E)!k3Zsap)%(V zW7Qqa-TM4XZB{iI+i&olETZ?8V>-Xu?cB`QbKE8-7qfrV*(|>_?)%Hhj9iR-a*Z?8 z+(WvgSMEQybHl3p9J{$+1aHz=aED7^rB&b7Ca>@(?^i6>bm`H~6p{ZPb9nu-==L%j ze#PETkyqCq{Ij@3->f^}df<|#@9B3E-Jhh&!4~3N^ht4&)1ojE>1nZtHK`y$pq)TUbHHg+1(;T@~gqJbDPrB z_dSuDHKEv3Mc7MD4)2B=;+mv{$Lca8`D7@p{ow(`Kj~#-l-90CL zr&;AV3HZ;Nsc?Swik9Vqb$4SPl?Z*>b0BT4w)X9-u2+uy)6-8}G3%U}mu2YP=;^k< z>g~Gncw&B@W^BrdnqAbZ;BbL?m$k!(`}Jb09=<%5HnFy1{#=8vvYhjFU1*puxAnAx zfrRt7$63iY3=WqZ$dF>rl7Z~l1Ylx=0xO)lJ?{{Lx%LQi8|R{Z_;ovU_TvebN?X&I7jd2m<9&A)Zh z2HmD&vj3mX-`{K8@&60||FysVb<0N_-WsNRMo(d5BDGe*aprdHNyq>ko1&_REL&&$l_$!tHj*{N~Bmx2z7`{^q6U7Qnvy z_jfk;*|i6jO~@?UTKD5*`_--d3{4D&v)@R}d$3pQqF@>Oa?S~7eintTR#G^wT~9EZY^)#N7A&WwYZij{g~}rM__f+qJu=GC9I|<2r-yjQu;i zEf`Mlg_IQg+p3l>o%px%SmUNYQ`$4+UxkJ1Gyb2Gpwv{ayFEAWzyV>m#<=Pbzqpr$ zC32zS4ilc5>4!)vTgIgAU6Z~)f8)(lseH30aysmo{lV=N=dH<}%kvBRze;@5V_;eN zuS4EzN-_8Ai?9F4%$AyDxBK8PM~`QQCDS9fSG3lcTIn+E;S$)pb%Wq+pJhK7ip@99 z&-r&qz#=ny_XlxKmi1R1K1^Hn@IQmVo@N&T1&QYzT2;0TEV&vdW6Wa~Rq#AfsLXnN z>-xWR;}bR$Sc-(>cdz*`!6z_-VbK{C=97L$#LNxPB=Nd+AJCU>*)`3edy22^tG*ML z&(&Y}dFOSxfy?{gmAQNF{m4J{IWbBm-spGGtH9&!+52>7D+GB*=rOt&XtC{nr5!tE zI%k;O^A<6l6VC(78aA~ZJ^IUwDP7)v{l72#_3QTi{8POzDSY+L<;5`@r!Sq-W%yJt z<$CZ=y$h4w^6u}Gb@(7;#{T~Pe);2lnB2vNXK=^YzuP{p6d;gBB6o?HYUf@%Cb#w zOD6YPrBzk-R)2c`V`AThzVJU;njPQ8v~SESPm!zpCwR`_=B9UNOV57%`2JV;saN|M zn%F+e-kYY)P(I_4N2zb?mwlXZRhkMDLU?aqTUvBYBul*0NP6{N<*ylg>Nc+EPVqYW zLQRvG@yNHU3;0Xl-H@CT$FS$ej1Rhn$~?;xmwe#3x?uCdmY#o`-79~2W=U&wuy7wu zZF!Ma#Z_(_>i2i~_Oox;t}r|hIWnRD691nG3mSeXM;`ukNK4u>=GX?NAJGZV_hhq& zO6D_NGOOI)80N_OYEP z4n9$5+WPm2_me{1GEsGb3enF-<lX!{PV!J(I2X{rz@3OO9d3jw2`K-dyAT#?<|hh3D+yidRQP z&Dtv7+`MWXzRLPLW7ChjEF!xipU5ol@F~tZvthQJM9CVi-i3SLt2|Yan=_>@#r=>b z>*R1N(OoR6KbL*a{G0GB-!J4_o%84GKWt_-XR_Wm(fze5v1VJnj7hk~2%5 zJbbFNzoWvdJZqPPmgp>QM&YH0Hh(;RWX0<`P5~cR-%9gIR`0};L|e_*Dr|UambWg` zeDZ>|Ca2C-J)RkL@z_IG_gWqUBiq=w&oAq}zJ2MB&KKjZtQ6HIFLq%GpGhu1r4nt# zXMSy4{_>K|y(M8GDqiA$*S`DDe)<4=oBW7nyr1guFjl20J-{?kSy5bB{FquzAOENSSN0 z&=j+lHJ&e?PhWjpX6Hhc8Pnvcjv#KeusQ2f4%;ap6?zG zCf4daCc!^{PaNa_dza_ao12?=h;y8~td>0^va;#^F|{o9kVCVkNIqabU|N@c^Xu!p z>#tWd=ilEM8=Fx6Vd?HS0{gx@t`Xc*(L327fW3cyVy#TsmpLa`ek-pN3_kl*t-oqB z2k&I5=I$nY%jW+rjR#pjn790`>G%;DG|_p<1-2CjU0cizCr`b2>)SMir9xV9@3X^_ z?|0OH*}t#mc!uospqDm9lg%6^IEielbG{e2c30lCt(+{jF$yb>ur`TJk^gDEZH}_e z`;H(Hp|9ItE3GrB6u5TjSZlV=O}o;2?uCk%>}DBn`h-$JyVcY3|X~#d!XO?eJeWWS+m;dczJG7dzdndO>3dsHx}WSPuYac7kIeZ zo0YLerXQC)vHaDP1Fr3BPD}5s&fotqYJ2XgtVK)`7IyPwECa)TGyQcwxOGy}^9vb=A%-Gj&I+-%5wAD+p-m;8k>1GFk zYJWzS{J7Wa1dsGRILgo@F{O=R*7dH~!}nM!gOWcod^B49Fv_^$L%Wzzpu&tr94tRS zY6!_cS{lE)ZsjQvAJ+tl_=^Wsltll_6kJT>o!{}D&5K3Y!+Yu0^Xa=-t-GJ+sU`(1 z$-DmbO>w$O@SC`$(beCVH8q9&Z>o~m(%z8nqU!p~2i^H;C`*IJsYw{}=g>7*KD?W|yYSg6g@6w$j_8MU zl)8H?HVi!c$@KUWPm^D&`}4mkzWFt^l0 z(nReg7elMr^%onn?wwvyWBc{dyT7-u9+&^mRc!ctHTU-AtE43!&p%T4;K|RE3_Y_> zZn8b9Ew|By{1OooXegXlpbf7+%2Ya-Faht z*!j{1g@?&+6$C?O=P7UO<(#o&%?cIO{~OJ88WOy$|870d=kR>tt;qPAMThoKG7wu-VG+@N7g4^ z%jSOD!w}@TW#upF)RT>`naWjH$^UwIUP7_w#*z7Nm+oIJY_{;Z*}UfydFHY6%yZYR zZH_$??7^~Le_iPJG&4i}&Cz$O7U~|dy(TMEEYX?mef7irqH7=OSDlyo$DPjm{NCSN z=cMEwIh(39t+3I%f9%S^_3OgTW0fPkSxn`Hcb{~4EZVJJzA$8ka)r%F&w^Nk`6ZL3 ztZNjv@iaSRMwGH&XW4d(rHzsI_4j+XpB_GcZK1KdcA;tSk0t9a+s^HNsvTJ_l9p6%DhIALArm4J^Lmuk!Nqu$7> z>M{k_sn@d1QA;@Ucl%8Du+;SZGRLy_O+WB+@3HBnd8atn1#UmxXU%i-@2ZvqTW8G* zznQ>PaQ&gy?%!ez4Yw-iBwu!)BXEc>f!AsEtoko664$Evl`&t|^zae-B)YU=#xF^G z{s(r)m(42{PUL!~lXbuP4d1@s7w^7$^z`%9r?cPiq#cg6vQ3lu7qMC0yqTr>vh)5g zhJx~Y=N3kXFY07k5xcqFwZksitTnT3iq%ckd$ZJOU(Bsf42XyZ+6IpHUmMOLr*yFuDE-l_T8?7zxTZPYQ&trA}z7%@E4o!TSCv@ z-q+8&Ht+f0LQAWxx9)rODox`|URfPblXqt#!rKT}pdD>?K#Mx-)git?XJYkJ)+4jb$Wx*;Kb z$?oXc(qit+<>qdSET2wko4C0@IZL=;S?A2qa^cO2=YuP3YSX#*PZfW?apsY^Uzwab zvqISd9v>6pHtOx4<`HET!Nt_UBAv&7Z}V{pnfCd9izL4;5$s>~dCep56`k+TuVEG_ zUsZkny5%fCQ^Rbw$jz2c(+;oeeQc?GrnYb1?S=2OYd+Lin}pde_o+W$H1)rST>r_> z`VGa=KIR)=yH9+Ur=ziS@dxJ*yQ}mgI9^;4xVx)#^{+3N{Z}{I|NGegyZ*;v`9nWe z@|byR8*MhdcqU*kznk~1S+3o&hj|q$7PB=~_9ieji7Xf3nB|{k*f~2U{lLrAy9yr1 z*Yg>7TJo7sdebukB5{GPe;)#7S- zCC)vp~?JVxz}~$lIwqQgxz6vMXU%e)`&w<% zjSiL>n-52~~j36TGMP2&>eV%(&bA zEx&QWapg*t8;3rNU!5#Jf5EgEN2#wXW>xPv!XNPC?)St45z%G0-vpdKD|5UsvH9(x zo!vL2_w=lsX}m^p&&gv#A(Q@u2(NbASN6E7!OdTJXT?vU11WPhF|bKmG#ku#?6=@# zgATL7`aGADdcU7Pue*N7z34`b>6-VSey7El7o_~Zmu(#LJno&x_v<~~sb>F(z98YJ@ zO1#$6@5O8HKi@uh?(ULxzaAW(eO0xLA%2&ibWOob)27EOTJ$$*KCwAAF_!zp#*Bu- z$9$XnE)+_=yef1s#{Br^TIG$as^*kym4ESV(Rr5t_HzFm&NvC>ub&rp*S_dYR$SQT zygqKG`-e00Pbv9p_~xA#ZZeJ2KDqJTTkdDiXYUs>H(9VME}}iTsmJ=DuWtM&%PU8} zIZK2vRc9)9sv6JfN;&*?$3&M0CsJmc=?fnJ?eRLncGl%2sqg#N9}ajQ@X~GOo8(@r zQilcli?7@hSaiDj(Bl^S-Rt%~-QKz^L3-+1dw<1`9Y<4jOxG+>>$~h3(YH9wLHWw= zgGrZ-w(7WS>RjR-z-LuvUc|e|Nj}9_b(7b<%^NMsg!`H8j-U7}lUaA<_#f8B2Y0Mi zJzD#UXLrZ?g+}ujIQrf;q%!m-PG;*344Anm%;SCat(;k1wjy2I&P^;no}We>?Z~N$R^7HnW7YBWLYh z*ne)Zc}iX0w%~8o^>5u7C4}yC1>Nvx>p#AU`-u1^Zr?Y242`Nw8jY4L_n#kne&785 z`{D65p=WJobFRF4=}wS@_tb??na{Wj-0ko8J0f++cusQlyE~Rw4vVjA!CV=FYpn{KCup{2MaM zuG=5a+;{$aT=n7f4eAfNh-}FZlvdmmox_AE5@AFqWo%r$e*T+l$*^bOVd2HW> zOOk7En5I9!Hj$evbynEM(p#A^PxilE^mNwq*C#hNeN$(*mRPhz=!gwN8sD;#Bf<^J zQu}M&UjBKkJjwdd?X%W1gAVn&aR1Y?JjiPBhC%QCqr)t-4*jwV6F7GD@!OUOoMM&J z59RZ$yRuXI{I4tf*;aU)aRtXFAFocH`?yi=a>ryL-^{5@2fx&=Sl4|e_V@8$dw8d{ zyisTkj@`58!Aq6do!g6kT^74^@T}>zg7mYR;d7I3e0-I^{oCfPu~mx;C0MF27=8RP zK}N~;>Yg(yuMgy(U4L}lBmRjzStYk*kIg@`rhut)RZ7q12j)5*Em;wUJzH!R{;@uA z--hFhykWq9a}W0Wz6v*9ZVNaPwq~ySM2)htLsD!UrxM&J%Klw> zd+7I+e>1%0(%x>WSnBX$g_KzMo;`9$d-P|-Sxd?CgvQKlzUcpWYL`JS>M`QU#(uhZ*AJVGa<$2(^fzC4-{r*GEYd_ zy~dF<)VSNtEztCMo6tF}GUt;fv-iBaw_Dcz;@zFK{L(GF3LRSljE#jE4jQU-t(tka zBk9i`&7*}=9TOX7xb1$qK7RdchS|ru?-f}3T(@auIMe7$m03S zLR%ESXU{8+IqdNFI(vBM)P~7kk4@ISeXOagYRt*uW+-(3bj<~Whp)2Z6*4Byd3k%c zkGA>Dcgm7i&OB3l&CJ>)eM3A%YlTZe-%`aqjhjwEJ9air>E}PaW!;Uc4qYPw9~+Gh z=GwNO9OY-{9k|}Bzq_Z}{>S$T?{?0vkV$xXY+~l8J*N8w9SUZZcF(u1J;)}c)3vet zhmP9{_sIP=OcE*A*Lt70DaRy`GP!Nl!~eh5F&@l_>$q*LkuvFK<#Lw*1Buyg70YLx ztxj!?dOcy`F)3D#tRGhti@BB;noiG?y#3^ZR^x-fpL>1wS}*#wSm^D?{B6GHSMTf3 zJfyvNDzl+P@O_bbJ^vfgQ&z|RW9yw;_bvMO=D#7&j;|;eU!HXndh8b-jh2PH$Ho6UY(41b5IRwKPHgqh zOH*%z6vAr{;uFh8=X2Fh?QScIC{)e&y>x^=IVxf()Z)1eKTc@-zR?J=jTY%_s61)BsXr_CUbsYFw>5n zs_+fVUzL~gPBtihIm6O@JXHHqpC-nB>&iq1Q)rB&j43964$mZUfJ7W&#OL-}lA8%#U*>)!S zEA05iv{JDq)YxR!g3i+Boi}29l~-t)!1V@iA>)=^8^^yX<5iQRj$ zu_XM#<>vu{{vR3t-(39ss_TV&m37yjF?2Cp_WW`GLZ3sy{wU?0`4N|G-J|OLXa383 zAUlb}?Dkg6N|kpr@9h#)`K8}0@Qqb*-?pVm=1X~nU(eg&bYPb@^Z8sqmA!ll6(P2L`mbMS9DeLw@F6#80{h>-x=ml|EKjNYncyj; ztjgHA_0}f6!V7(~tXr;IX602+b-n#3E}{6t(LdccOg=sNeKSi^^w?x}|5fVtHjYg@ z#NL-Dni#D)8|#;zV8b)v+7Ai$8HH9SZ)*CS+psc4B+cTam6Q1-jh9x{(`45+Oy9iK z>gL=Np0g}u5BNK*n1A5X>TI6W6|xZGUG7-{E9q^_%xh zQRBFn$z@edXbzl2_E=HK_7bVd96x{&7vtj1=oSwEC!mqb)ovMsPUmoH+v;aM`9 zp{U9N{?G!3+6s~AA9qf!5lnx(tu@8%gO5Fj)Rp9rU!JG0D+$^(^?%tGTF1BU^8Bw) z6x!Ec_;SVlO*9kB+zU)4vdfa<Q}V*WLfK&dH46#U(dgJ zpV^qJnZj9_%O7j3;vP5K!QkujC32*(hpn9a6n}mb z+%F&b<4ha-wOu>S{0?k<`i$+4C`w8*sj*4@yE&uS@KWcya%}WuT`)!u}Ds>C^8yDYKDILQj zkX+*?yT?JHat+#KA1iI(J*aJQA%teMeu(Fy$rZKM^aB{nr_q>V6zuCi%jIr?>sU z&RY)WOgkoDj?iB**YCWp++*c>9)%y-)0W0CvT(80f6myuYfqbER>cn$`CaqA?mhbc zwG_v{=TaPY%l_oQO`CYfVr6F3pI$#F9d$WL-9WcHCW}g%+$0mjH)gZ`<$auf*}SZJ z`-ul%SzfAtwKIFZBLBbRg*iF1Gp8^+uAIu|Z9Mn!yUPn~^^P1YznFLB>D^)j_8Ad3 z-Zp*YVF_rsW%APO6@%oazmZc@*wj~5|J~l1l_<*nReR1{%imur=PdvE<#+nk!}4FT`p94DGjx8Q zb};Z};eEX~ar=U$lkClFT2$6O6Zf;b$=iQOpCQkS;ka4=bFr=ST@!ZWV=Luv{l9$X z9PgEV+bz^1lrLV-zqjICoOj|mWzSHi6_RpCxvULxLw%z?lFuI3i4E5%cj6HG#=ZF6 z4|z@&Uf=l!McbF`JhJ{*l-WO}l1LG*7%|0HZ`Q;-iYbYH@aAvo(M=)O7T0!Pxx02n z$Ww<2pG5o=n)Pg6m)1?VqNf{`(bA}R(tOtA@B@=GCq`5(?$zY)HeE0!k)`2~-Ldi< zor`aJE;&qVXepUs-f}-V>D@X>pU1~`boxh3%d4CuA9v$ufb$zS`UD%_lDX@)_O;feShG2Aj=vL_EWKu%n@Qfj zaNh~<40boTJJc)ss`lsZdSRB8a^!xeTlv~GWGOQhtFZ%W1D{Zs^01ub8fTxE@a{`V?TKCcij!I(8QV9%WmqWr8jKjj$>|{)@Xh3 z)ak38zmDCxAnsUe+>_s}X(nPA^%t^>L1n zq%*5kXNmWO>Ge#ujPtb;|8B~%ST8H`hm&QkvoMF7YSq7#2`jdL-M0TpJX;f!^;P3I z-Syuijb4~~bL~CPaB+2z^WUE3xelsz$4q0_C-%ACXy0UfuER zao}zVee0LVQN<*%;^%bk8Lff0%0J%v`ASPGacT2&{n!<1=N4wkOY?CiG96mOskDBD z_;rhm2YwZ<|6-c^&*LlKBkPSp(-_WPP`=E_A9eHJ#Ex*Qtls!1T*e+Nr@MLm-JQEL z=v8Z_$dPZN**v-b@@#lP6WFNKwryE6DlX8h!Zb;XVH%O<)^OEB#SHg~hp(*3OjDRpaOy(&%l+4%$k+X> zl~ZvSS$f_2rU=_JH=8VGJ&)WYwax7Lo3ohjKTd6-|Ljcb+P_TvE_Cpo*t47e z((m`==g(NU%Jh0<>t6kXioFl4%cbTo+r0ai>g8*$nJ+X_ml~DGHhY&hEQ`4uQ($m3 zXj#ZEy9;x?KX*)$*GXG-z_5OH{LE+chdG<{+SccdErRtf@k^-T09Z|d6eOqA^-kH<}Y)1AF1+EsY}Hl6 zG}v*1KwpyBF=giC6IL9Ha(Mk@gSr2!DGdtSrx>q1eR#LAn~`r3=i(Jdy#M(H{q+5v z?V{Q1am?3f>*=)yYv1+X}cqn!(BmAnLM%DwCe?q1&RSF;V8n`Q5+oyKP^!7$; z!=F|S*;mdizkZZcYODR6W#3C5-|U8ANnysRsh1Ys`EbL<`d#+DlzWNx8=jrbJ5bEr zc|CR7y_VkVl_5uqGkG6sH3V3|uxnpm8Q}JO0rN|is!g&>n^x^H5(o*^5lC5OHRpo%7tf^y z3$_#+_SA6+tl7*NbtT#8EbCY2zx#M?`KR6Z!G77|$G;E34YLm4TYp8pxifs$i}Mq1 zY|!yt_ME?M$>+G36VH`ipAFc2X~MPxVy_r^WFMUGGj6!a7r!W4FYn@P0jZ9=jh-61 zA*p}9ybRtKVYuMW*Qz;vA8Yc~{d#vg-!dpuwM=IH$D=QIK3LVmI%(T&xlAq#gDRCiE*sfk}SXG{GR>&raj}LE6Z!>*t@}ssH3p z(X3m)Cl^@8t1_(0JHBA0UpXUAEKj=gucmQ&j&dr5koDN$fBPb9h}%^a3pV5EIWsh zyzBiZt}I)oy&9lb6DRbg;pYW-@ox+io6IHa+tw7>)Nb-lA zpKssHJeb8)X2;66?^n{~&zL$4+-$=9VG6 zIL}hKMfe#fi)N8Wh)t7TnP7XDL}`HSOQ{8qPW*@EgWE}YKOlyvKUQyh=Q)#;KZJD%y>d~_>u;btDQqf^BsYj%Vk{hFEmrl7cY zPBv%!p99M#v6e}0p7`kDcmBs2TYpCSosV#ubVBK=uS(0RX|eXpZFPCqEDGe^`bw^j z>9p+(e~VMk)u+`Pr|N!G=!sL9#u#sJw1TaF*9i|Dy5C>&TV-WXSC&O*TtsP&U^2!{)6!!OT*>#yI+jL<{p#0qg-X%MY6g=k8kX1o24l=iRpFz zUgN8e>_Sx@Rn9&vwd$i?tJa@rsr~Xh{m*PN2uhq8^#9ejO~T#D3|%1+T1r!%I7a-a z+WdXHR(PPo@97uTEl?9%tzz>uP+?N`y)&A3f49Z|brM?o>A^)FnXji-{+Mt|uCc?! zXSVxxGduHD&bEEJc5RRHcbR*hK0i$_rDa|JwEHKxCp`(6u%rKp!Fu%;Z9&Jn7xqH^ zN)huzrg`Z9ik@39;(I`qBV=<@ugs_sr6t@1AD;`V_*{ zIE^P^z2H%w8yY7y|8(}by`4Horr^iR#VkrWTu!{|Vf#7MF04-5E9I*^p^nJR^D_(D*%mYis=XS0)kGWW!wKYzPU3o?4j9t#l zG*mZe?XS4L);-8|S6e`+PEPmzJl;DdlOI`$nS1W3*d(xwKa8>6ctzWF#@g=l(^r3; zRaklLSyse_>nx|Mwr)Nsb=34tSmL^4`uBAuE}2bx|5JtUW%3)jH#KRV0i4q|Z_;64 zfSd&|`;;VHFuh;GQ^kdbOE#;5y3cUWIQhooD-qFK*UOc|hr#@d#Cp_QM zziOFK>Q@bJ*(V)N` zpAUYPnRW^upLjqC{ohElMi;zTvo5?&%{58RsqI%bQtGaNkgii9C>D z%5(0l`0EvFW;Zf6oyyx8d+7#~02j|xxn149nsEhjze5Y=Pcw1RDmWl})h00BIV)y% zX_v>ZDeqb%#jhFedXxO-O~tJ{j5B6Col@UXY<&C*YmN-lyJd&gct^c1f2Lz5VEMj$ z%8ukU|GVd2TGbJ$uQB6}Y-*rcCC3l9NbQ$DPrsagtar=QmC>O~n>^Q5E>Kgqv5+kJ z{f@Ko{)_8>E1rI2J(v9PN5IeAmO9RT)gj@hUdruSwLbgpn+eN#S=KfxEL)()>KGh) z`t`);r>`xk>TH-bO;AZSbH0;`U0P!sCjpG?IC1?noTw_Y`GKU%eW7DMmGsW$}o zY|6X0AdBVm# z?T3FIh_zerbn+oX!;U}Q=0#bT0yn+n-_xa3JHNlOX0_lS^^@sbD<3^=eVfHIyY;dM zvv%LI+pbYR{(Q{&8gFK(ch>J|Wy1o6fWB3kQggr0JfCqR%5LhP`+*7>Pw%c3f4xRw zQ(9`w{?Bq8Zu>1h`j^aaGAxd1YL|#szAMBt@zV--bN<*1*U#>KK6%0KMNihvcJ*8n z%$pr6EZ~#iA|h6MyV39eHP7c0!mdtQ?YP4^$<1JSLed)UC)vf^Q{9-FyszH5Q(X2a zuVvyZ*K50VHoZ)l8@v7WifMNX-=s~Jm6+GP#GG@x?1BrjJEt(OJDer{@4|vVzx*Y9 zlZ4KdmK}Lzk^fp@TkMvV=L6$cvl&P~JYf^M=MPJ@a$W}G3tyjp<)eqEDQex-r&Rc6x7_WoRe2oIslo1SP5zd%@~T-^DhBP* zwL9^2;z9NA4=0KQ9=x*eLH`jZj-dVp0?!guHU^z@WcbMP(`V9g%l_HPn@>pk+<0?V zz4L+0@$P?>nH#DY&0-q-_p>)m3f8)HpqFj?@6_o%pAKD^s&=4-wP|uk<>p|e8IPyc zKYbQbcgyrtwrpLLk#3SWZ=;64rt;}6TMYg>I_~j&du`E?zfE6mpS^Qtd;FZB{o!-t zGXMQO6s=b8sl__E``mn|SNa-L4yHeUE5V@kRpOx4e91+_$Yat|&@5YdxRDcm0;;LhHpF)2{vAX{Z{qhhc|d*(bHFdaGiV zG`@RLy1e)e!?7o)B@*;~9xyQ7m09%H{_m7;jy)%|9~+(C-MdQ7GkU3R{71#VuP<3n z-5xFZ)Ajqx=;MpuuSvftVPmy+{&!!^^*JS1!&s-UyE(^wHHW@n$Ft4O`&`a^3zV43 zqW4<$ZE*d~30EZL66WW>z7&xseXF2P`gQCi_Q$eq3L+(Q7bNKS_;a&N`c^N%Uh_@A$0Yx=a~%f&p;*fga%u0b!3N!>JFmRk00 zTcm!6ZOT30bxPhWIeioEeN%G#aPid{+j%R~BI-R-eA}=z|FpexzTYQ?U8I=k>Hd!iS{} z*!Xk(n0$Y_uhTSjt31bje_!35UUwyYy53jkPgWoE?GwT<&% zCm!X!?7OmE*gY0$rV%S9*aB)z+3Zvw^t zEm4(;iFAG}dAf<=J!^B`uK=zS<}q`AJY308_(xi3ub{t&qnAWBL*#$;fHT_|lbbop zn39`0tT!CL`Qu@m(9$j@zmrLp&Q%AlZh9)Gsc`1I`_^2U{FxfJKCS<%E8VOsT=({1 z9JfHum#1N(Iy~}=AFeo-JN4no#+YDf=5J3H%oR9!EcW@vtG>m1=E^kAy8JWQXP%6O z)0EF4$0z?;`OH%HQ{oY0``t%aGm_bbd6>FPjNVoqWN2k%VGZEqSjVH!{=#@R&;Odq zPg*tKZ~1wINh5c%bmY2kdGqg{J-GTw@)7fG8BWKyC*2T;>3aO)hDFo2l-!A5uW_#^ zcpmq`khebday#4dRLxtGXMdi){^;<`5|*Yt9rL+9-nhHQ{!f{Jo$ZEWljIr|qGsM) zZhZAtdCdg<_eD*YxVHL+oI4$xc=Y4Pp7NSA&$eyu-?KHFMYTy!*j(<7bKzro#{{Nk zA(xdL>WhsQE>WG5n7SzK+_$|piK&lfI^9$-X4@%duvFu9qtSAcxWD)HLT@dZYgL~( z$L_0LUtK4E@K2`i>zEv0zBu2hw0W^}iZ_ezy>H(y?)sZ@YF~HVF~t`PA2A%+IWHi( z#^ckr8*jHAzBPSA=hMBj{bTq&Bpz!i7WXd9j=M8gXU3F`xocJ1p8d|f)Kz3P>D8u) zYZBp8w62{#aKut$s>9lUC3YKK0`l@|8jDX~*suK)11X3>?7Q@^)t z*F1?g>6`@{_8k{*teV22zVYxEYdiM)(>`4A=&cL*{%x|bx=YBzRIY1UU#$Wf7ETJf zx&G}u)xstDp3MT&ik=$YTxNANH}O^A_is%sOG^s?-P=039p(=61#b&+H z5AJ<3m~H$c{qJYVV~UmSMGM-n~Z!BALmG2+Nf03Rj7W=xVyTvBj9{%@`J-_Vp+&$-P zIOW44?yT);G4y6JH{{;7`H1C-8O)nsHlI3neD7rk1C7})7#8m2eDr};fHy-~&7ot> z!bdWVOUf1{w$BZasob$$p2N*F`hTO*pVigjuOp7Lze&|#lU;SET1?Rd88gtUbgZ`WCc`IqC>|((G$fR-WeD`Jd0w;cw zyxrMf&!hY3!~v&Ltslu}AL<gs| zX1-F-eJs+>Z4h$9{e@EIl5OYTR{Xm@o3C_P%$G;^#NF-0x4ZU;zP@Y6f8PGuk0Q03 z3=i}hVwOyNr)wOec53DMPXa;*e{48nzocbFSg7)9yKnMYsmT^Qf6ooqJGz{$P-JGZ z`B|H9srzNwJp$~bwST`o{C!&7nqsDtTwzkrCfq1|B*>80s{Hs)#-^hiOT=8N*!C|v z6Q-|Ib>KNm)9*L)zP%D}d=RFvgI(Z`<0TD&Iqs%={#`BFx_3(7zSGItQ(f=nemRo< zs6_norGuyMS9LB}a%Qe+*#o!#-g6D!R5_}0K6N>Ma)qLAhwBRuCAKS;S6jTymxKjh zT|GHs<>`;Nk94PXox7m+PP;>}A^ibu;^C9^!0Td0pnWKmzAL}j%vf8<`?~v!eTcF1x`k&m zCl%GO{+8p6F3{Z+e)i$IClQaEQZ5)SYD`_)qL`>$7q&j?))cvqKVoEMWYl-hc&n6u zdKQDce45w$4Z)(`mJE&W9&OE8li^c&J+qQiymNL+@sR#GTz+K7Gw)Xu4>=B4E)}Q|p_Y3_`B{e7E&o7<%mV=k&;W?J{wk zKIK%zapP+?8oV>-)GFWKzFRKzTiHf`^^h<5T9aN)Z}450y>C{r6nn^w|J73FzVlZ4 ztH0+HIFl(AwyH|Wjp1NNid>KC4&n8pjaT=@WNeZUFEa7DTJe6@+}x0Jb$aP9Q`k}t zHYoFL`_HECp>G%@eQcYje6~ir$xWfGr1z3*8SMhgKTMrd#i{u#bAENv*~_!PZlCZh z{UXzfqU6dNv$R#M?|E+SRrAdLwmN><@qP8pjNfaErz|hE-S=Kj^s~udVOhU*`P+H& z^#tBb`}kz{3-+DHb7X8Kk;vd&zer_v+1s}!ul6Qrc1j|i@3af4~M{$Uo~vZ|7XnpSU0=0p6ge@;v=_S zEf6}Lm=vq<_1@~n1qpi02W89n-YW}=aOm01Su3{hcwS z^}5AxrZ7HEVCJ~BUT5-w%QiKi=CT;Z{58LO=)RlB^8{%tGhdt7Ah(~)=YGg}$oH9q zoOB6Fxe~egvA3Y3D<~-zR^wmRo1o zKkAaySdh@LPqwf6Hmi=BgocjG_5;Py;*}S~?(#>^YF~CSFFPtLr~2dSR*x)&Z$C2b z-o0ug-u83j^e&Z2_4(HT8O`bD0Jn!|_cV+$M?urvXQ!k{(NG4fa;`tE1eD1G|D$%biw7XA+pNcwe$oS{1 zlFGzCzWx;lWP&Xtqg7t?79E-YKy&Vt?E2T!5AV3QLd}J*?9kL0)lbsTivHdfe{Cy} z6|;xF?n_c6{#wp127rZ3hlmEL_6E!NjCFRl_O$+(B!Nh#H?)&sUptG|BIn zXL&8{Jule7bKIQhRNjYK5wRaEcEvU-NLJ{~aWFWr)W)-cTY^XU zR*u_ESEU`|4gxEc918yZewrn$u;U&(2V3qv83m7r@sB!o@-)GBS_{rC-;X#D6(u#lfAIoOeX8pLXD7avXOB47gj{^GM#)lA z$$i691NYeEnn`xy(~H@U=d`@Nw))}C9Y;Oti&h@ox%^6#wJK}rt&{q!w_SxEJXx^0 zZpx;@@Z*P%*92d3a?cQ)JN0|Tx7VxB7FnegZ#?rnC4JYl$7hQ=m)J5tzoDd-B`5vl z!f7Kf*{*ws7T+|}ZF0ZeYO=@o!E~NrK9p!Nx*=_Tv*?fgyM}#T=!ZV8P!P1QjUr&6v(PDN*@8+g-#-`UE z?C~4I3K%yV&GujppT^Jzy&6&OXArddg*?yY%URr)qOeD&-3G3)Id0g4OrK3kR{pvhDg{ei|aAFFZ9eT&iysB@6|HFeM)Z0x>MA}5*AELzghgn z`2UkYr zlF?c3%wEcPJUY^zwzsKKChJK!E7vSe^Vf~_bvbM=r`YU&Q*p)I^25RJ?DLD}oRRwc z`DA!o!p76iMw{PFF8ccSVGiH#5-z8wa{_j~o3Y`pL;jt)OZ8+opXFa|zRro2_0^V& zcRHna>K@1)fQl{4p6_stGw-f(R}DaXcn@-Or>Z#zB`H;W3tVcH{DZ{B~# zCU!;G%>X0w!xQJp+~0Zl*~F~t{V!R}?(RR}ykzDzp-FaS(c$9LZWbJ>Jm#OidTYK1 z|KY2*^n09yRD!*%o?MD-yK{W+|C6f{i!=FIGW!^sVv1j`xbC^`b8CIjfoH#+);)is zBOsF)xXX<7cz|HK!VHeA_NGZzr|!*>n)H13=k1&(ev3oQVihanS4k}Ws-YizWy$iK zErq}CAN>0?RXZhfm-p<;&K-nZ*OG!{!RPt%|507^{1_X&E9F%GYx-V^I(xY|2M|x zO64>=fdhpV83l42g)bUExEgZAh|J@;AF80S_Vg`g18Hf+pu^^k33=N;bYIszV^$V= z*I?62Pt`RCZp+?yaL>4>)^D~~&+E9RHI=tyR_f|Mamfw5*Pi&|mj107Iw7jh->)($ z|K;{oZ=3JMX;mf9-&_`7BmSl4(atPE&HKyT{+PEtTB4@f!8QMoo8r%kRULB7GbY@O zaG5IOP_QiO=cK#G^GyYGWXzT}pXqz%cS=W4=6XYJ7;k%rdFhOdc%kiq_d>$WGEQYH z=Ek!N=;%iN6UvtFm*8!y7desr%l!TA=fx!_rqt%=+tw=FSo8hj(%+W%zFc~=!^q^= zlfr{i?=O9?@{}|B_^C!Ja-ZOKedDzI%mG?DM=xR-sy%}y*M_BMIf@5UA{xKb>fzj z`MW#Uw6FOzees+vpO$->=}cvbD7|Ycm7vnh{W*J%8IwZIwg6qFr?-!Id=aX9-C%RR z=>ElPs~m(~b{;>M?07=p(ox>Ne^(ZKDdzE7Uvt!!ZRvfl&V)~-G0Pz$|w z(|L8^oU<1lmgT2*U4B3N)X90Qq5TWoJ+)k7Yv<(Hnyh7TEEmrXNJ~x-J-Hy-`%2Qf^D|lyz{z6`-Q%LzOy^8 zAUC%8^4DLXTNdw*c41;MYkY8Lar)I)*O?A(4>A3-t6{;0{E)+2nH+Vh`Y$Cg9hBI7 z*6n(Ch*8 zxItSx(D!Q6rD?7eGe3sxVp+ZA-g@Pl0L|M4nKKu@{ulD|n44h3g6q0h4l^BG+x5BW zuE!z!tH(3VjjphEl*WcTIT&3$!2W}0u0hD}67%0-5|5ut{b({&>%SSrT(n8A;N;@x z6F%iCaMt{Jpvksk`s$}sMXw19%`Aw@zmU`Olm87*$ZYR5+%8H#zFeG~^;!CyR9&=r zH^-49hg9`8ZunNnqbVTs@rPE!1D5DL_n8m=6REFmNU%-%9lrT}%7-GiBfovkn$9U3 z*}3h#pzk(o^R4ftmo46Qu8X(y|5QD*bM+Rvl}Ar!Y>nSx7n%2U+0GT^i5u^QC{%pe z@zVe6;)Vn%^S>RFsyzQ+iR;b(a$r-Q$FWqwxHOx+rVbmDwL><^`kOOGGc~3*uhjsAVdf3_}LP;V?Rc=o{3Y_pjn z_YAHj=z1MLUae5!GQEQJ-bL2#UkhhWbF1j|lTa_+)5Ik=*@a)vTJ6c{yyb5ma%WfY-W~4QfX%&eE#{=!0xT5 zinhc=F%G^w-q7gPIeCm6=WOc2a_f5kI`Vk!pF7)iK}zQII!%QR-USyE&xNdQOjyyj z`0<4t-*fMj|Ec@Fu#Nq&wz9_7VZ)ZAb6;Hgkma9o_*lqkF~885!LR*6Vs)ShPm!XlgY-%k9Z;Yz1=sS6`aYsXV3h z+o!FE`&MkSVbN|ixkAr8^%Krs z;oj_%Qv^B{6AG&9RaM%aJ?=}s&bRAy#Ly)ojG-~z_**p z@gMI_`NqxHSi7njY?ju|ni?4|`X@I;J3D*E^hmDXO>(Z=O^)}a<#H~Px)t_2GhZbEG)h;)~!wUjSoIN(5PhM=Ui@5kUu@Nb4G9E z{TnO7uA4u4GEw}q_SJ6Ih6iuBvRONKS#~(SG&P%*6LwziypkXb$G)x4k`?-^ehQiU zG*9#DnB`C)Q!+2~FeBHcoY`Ft)%&J%OxxmCdE+`WOXhJo&7@#nnYVFAD*3M)Uz>k` z<=55aFR$<6e^+R+Qn~h?m_kJgYky_oguLS{YvT8^H>qFNXs?KFP}rOsveI(f*B5_1 zRx=-UWhnTyPG@qtD95*Lw>{rJI==M*&$~K}7lD70^c(K+u`PCAwXl}=Bqs-J+OkKQ zFT8#Q+*Fc0^DO0B`!pw}j1F0bxk3l;+KQa?vXOQ$IK^0Z^S0})Q&vX~3Z{#lJ{EOY z_JWMx8Y3g4XR`Yj-cXcDd;M)g_6frx>Dks-@4QiZE~tO}{ZXCSP7|c^)+Uvum94zx zkY(}t@#U=7(dUBxRfZl;U%jz&eg}Jt}C8SkX$j@ z%=YuvE!NjMUo~HQdA@POq$q{*gg)`9=BiChj=m>V@)CQd%-gId7|c5-%xkXfgXwSi zF1)?6>e6L9^(T{WneZ+aZYqnvEn+LX`tqH*0rqRRF|sJHJ^c3GpKTs+HFj5_Z@isXD{L5;bK`^WB-fmHJ|m=U3nssAq_|N-%yjvOgS;l ztV2W8WR1|l-i2Ft>^fhOf4^6CjryJId<$Q*)IM61w4pDXm9?$uz~9&g1^2Tvv!=Af z9{T3{pEq&ik=4JR)P5AIO>xM4toNGLGBPDCZ(&qa#KS8Sr)E8rJbr5J`;hF<5_9X0 z^*wre_SMT~^{dCqZ`j4$e7NS()R5Xu?-qz`I#p9Y{qfsRhF!nce_Hc!dl9z?znDn$*b#gTU+lpJ(b+N)7wJ3I2Vbp z-O_u$ou3=RWA|2V-BtQJ?CZPi9&0RXbky+~}2=I@9a1Oz5&pC4Q?;@BZ=6Rv_p8tNfID z;Zh4_@g0|{jTHZ3w~ZPn7K=lgYx>ENMV`Fv`nALOL%Y$o|>J}hfJW#)5+MJL5` zHrtAW0eLcxw<-c|KW15eMZfma*X&gj8wHp2ddZZp7MGa%jbm5nl>_?o7VyR0TlGv{ zH|#UNWo=8ar(E6F6;Xd1V-IWJzN%&2Yb@|)jgIT7AE()xCaiw)+PvIiy_u8!boS7F zRc-OXN-s_-J#Jnny5gdT&o-vyc|Y~%D7)=n;{TzVpT%DxV2_{A8s8InGww`_o&Wg# zJw1hrn%L_5%jQ<^-FMtpyD_V7wVb%wUhB*^bLSk|Ewt#FA?sCNhYhtXg~wmdcyfEX zMr%#EYSYuR7x^`0{NMkdzc)KK@5#1J54@#rCx@r*d7PuQ^6c~_r$W#5pLq8_Zhd;T z{hIj4NBXY!<@UbaXkz>=BHycKa`ida<~Pe+gq9zDx9~`t%QtQZ=I?PaGI0#zZ&rug zWHN}H_p*2XGsY&bg=^j$RO+u&yOMh++u{%J!;D+!Ra*S*=TrxH6mV?F_-N5Aup=>Q zosM3j=kv&;Ra*>RoiK@sz4I>Ve&QOwXJ#etTR4&|eiZyaBWq{NCa|Z(fB(OebN?4S zWSgN}!Ki-aI^#i3ohF_$@4rQ|tbK7SoS|>E)nW!Y9*$+tIhJjo!M(n%(~QCK{IN$Y zx_gSE`zsq3cxh+X-2Ap8ZKILh>xJH(Y&+gO?~CYny|&9$^wV1x-Roa>wwjgyy_~y; zTQabf<#Wdr6;XjZHaj=TFKQL{o+u>3cJZi45$_(IQzsV*SM;8a5(yW6#O0LszCr4K z+Rx8n4#ifv%*SM`o+Sw!ays^~c#Y6D2OY+8ArR%V|Z%9e?*xy%Rd-(YrgO1`|(=-2fRW@$m5aO__ z|I}^WzWHVT{)$I@|M{mK5@tAfI61%0Ws=%K`99$@taF$gx#Az(UOh{B$3zDKmU&E$ z0`Is4R1SYQxLxo*WFQ-dRLw)KrwM{<8WxE6ANW%6#KD_8?MB$-+o!H>OtL7{klj^i zr0-!cbDc+|+PYf?#+|FXRYf@V#0aT=?wF$yB`N&oh0OIS5zB%miU&vb^{v1DDC=6t zw($3#`cCbBUA%K`x%lPO#9l3h9TQAG^PifayVdsTW$w?W(S^N!UT>F+Z9VUrzv-Ed z8rR(yi)^kJ?PpQA;jy>bp>J;ISxFOZg*2X|ZhwouhUq9Ub_4`L2t}2HU z`LhkU=Oj8zn4>I^^N91ui9Z{aJ)8Af9Nv597+&8mv*WV(^LNwV*OxwT&;5R0e_!cu z`Mo9L9}Fux*1kOB%{}Su0o~rc!q!t;Bo}Neu>P=i6UR9#1*U_tJDFH5sTR+ePV&{O?9TWzN@vGh7+9ln%uy+}MY zyqZ}{Q9VKG@9{5Nt1>&Mn68ak!0_*{he`g0Q|B$P?t~V>4E;Xw-MswtF4U=$K^XU$~>vhwKJ%MW8}5TCZrIh=N6KVWH~f?;^dY&1Jpc?%-l?dU=TRxz_pCHO20x z3M)RyG|k}WsJbf}98kvc#?MUm&eYJuS=FpRGxFHPfZpA6RCeyPYEbyz@%;C%TpjC|hgNOv;}zp6*3*ZR`MX`K7@CE7B>9E2 z6BwFqShHA9N@z7~T=4Ye&ja#aEHlq6y{7bH$F;K{pTGNZ^S0``f&yKEEuR$kOSN@#8mukYeo{%|^cewtet|o!_Z^~5d5*Cuc(BGU z7Bg*A<2i22+~nqZe#3`*Pu+{A#H>4{7LZWfxWI0WqhM&$vM)8~UNbd?r0~3cVgKpM z;p@wGBC|y*3$=TWTgwiarx*cShRb z!ec2W$0f{pb7HRC`FOB%t<=9ihxHQ#YZw(O9?p}sVHR+)`*HthUgnhZf%COztZi7& z#<8z)Z`;l%mN|yg)30s_bo?IU!~RYuZ)iIyKPcuEI)1aX~y}_%dU$G z^elgHjgMD4s&lz;^0UdMp@%bBH{bDQxYf2v>13+u2}Ty>&D%5Ptz!Nnf6vK%y1v~4 z|A(4ff*O*2cdGIl_{IBrgjPQ&=*i~c=HGCs;>2C|59aIG8#-5CJn_l+MuM1QT3qpB zJ)NeKKn{h9E%i;7P0!!G|Np!7_V0Xt7XEMXi~>it?YWWk&UgFoTkEQS^S|HGUSGvt z&HMk{->2)}@7n(V$F|-7Kk)KQ*c_zbDV`xFYMS~|bNi>;;kBt-d|KMJuTNr9tNozB z{%0~{+A3D7Ws%!EKYm*l$@tKUO>R$o`R;AIW_@VbSAOHekBtu#Ps=V<3;+1=phRB! z%y9jk4vNc|HmgLvn)u6mvS)V0-!-hi=Ppp)$-GfBJnO>L!bK8O#4Epl_TsX9=d&z% z@}wxKqnDzCkL@|SUHz?WX1I0cy)(~KcRqT?vL&>{-)HChESbfUqOmC-zFe<6^5kOv z#G{&~QNqPLuL#^}UGZ|!Yv1Q7t5YqX%ffwCP2O5VEUbdern8e z$KSnpse0#l2?NXiR@V>K5iI_9KmUDx?*m)Xl?^U4G?uZhxorNWV>Yj}#5a{gtFLXk z{-H?W$AP^cKkQq*@IsoWE+*~eKzb*W~hD^HPPlmS^e%^bIZ5EVS%WFSiz(lj11=*61H=9D;Qi|%HH%mydhyz1j~^dSqd}G>@ay0%g$o? z=XQ&~9Me9rw&qMm6@fL)H~u8Mdp15z=VI~QaiE8bV^!|wb4S9bN~CuF-`E)Vo=ZSy z`Q-CV{QL}?S^V#R{yV23FG;eT{jsDdYtYYa6Q3T}+B8L3d9_#J=jYOyf@cDCOQpK& zUAOIBTeWtTbNEy9|9fNyrC#N`6PH*^{J+%kK1io&Rg2q{ z-Cao{8d05+&lMKC7H{C`UZ7?4W&2V2NUw-phpaO9+wC`T-CC~kbf)n0g}*tYQDKh_2XH?>4Tnl+?~ z@H}r+kYiEs__pz;(3^`wI}ZPCEu6#T=(50C^1k$8rHr}4!Hplx`VW+=hzhWHZqpH2 zd&Fm}!=5)03c1^vIGXDIrQhY{j5IOMi`cVh5_@FN+5MoB+UwC%=h#EuHTJ414HuRB zH*{y#9A7Eo-5+fraE1Fx>8|DaFP~<*`AlMKDp9_?KGv^s!C7^e80Kc5rk~AbCU?Ab znr0|h{P@D;AW+PbD0t`hgLW>Cv>B6`nx?$HpmO7zMMa|XAx4fvQYS)>S^KW3O1$3q zd$MFo-ANU@nlrac`agY{j4H3XVPvamfGxn zQLjsxzLh>J-MVCUwfc#q9M0`h9E*w#yD5j^AcxVV7VxS3GNw_mTCe&+N)3mWbTLn%~)&ge_HnR(fU2&nek0 z#*o0R-Tu;`&0)jUj7Y_2jSI}57^$|Lo)DvyGHrcr3iOVCP&Q_PM_eU9`Voz}TD zu;I^^FHswpo#e7Ux$y86tsGMUm;Vb{qS``!Y5g>Qw~fisKRon-Y2J#R((gG~7COH! zdC#U0A^p%}r(@cde>e9yNSr(t;b^le`JKW!{bSEL1xoTfrt9xu7uQ*Lz1g*(!(?tC zE6a3Ko>@V@tTc|o14%+(Qr+ja*fsG;5QCV)(=_Et+3SLQRt|+Ysc_Nz%OmX)jJRE z#Jdan9++>>?pt7G;^U~WCioBwOM1E0TVVx>Ex!s2Iog}c4{~f~TU30zF?E7h4o`tZ z)7y{JmuyqL^YEarmGd&)2!}|Yy_5A91~k@PE!1Q^!O7IQ$a2wXkB<%)IE-^Qc%Ph7 zb)u|J^wFBjx}K~o!B66fq8JaV9+_GFM7QbawohCf=LBner*E2dXm{iP2E!Zn)x7cS z94Z=1^p>gg6gsItmid)x({wPd*Fm6|LohvqZ#gID?{&AWjTI~m6lRyKX1aM8@j^<@aeWm75;P*^h!NT3+!tpOR@4QW&zN&NuQ`6}cGi${TIDC6o zwchFf(kH7v-Fdz@vbKF{+UBm5lttYy6i>PK9$jfUg;8owM98);T@R(Y2HFw6CWx2(5vObYzbQlQ1kgx9H8p6!jisDSoNSCN z`qkQ%+AlI8yqrv7Akb8d(!Ebe?P=ncAaX9eEoj5_J>oS7QSoa`eMHJjFqfo%-xe| z0R^3xmfl`b{4;!~hemf^Zt~()XYc27B&9xkqV;FO?5jGrjXN zc-`-7*s?8|B{xlpnEQIolGTr+ctSery-pnGf6BXW|An9@9dpytT#8o3ObrvfnYJk6 zU#qe0=Tk{~N2~&vOf_9<9?zeq)oiPj{@=O1-{l#a z{bJ6aeWZm>oSJU)Wa;FL7)VRhIjq9?kH0{E@JQeTiENQtd zF8S!8s{OiGQ`C-yFIhE(FZzv7#(97i2CG_Z5UtCongXPA~oQ*HmIJ&7$ zE>+strP#aTO|6QKfFg$s(}f;GpOd;TI9PViohQw+F=NT)LVdovvgOOu-+ffCFZTcc zS-iZg;NiFVatEIBs4FN*Cn?J8tbM1#XsJ`ZK=Ax^CYFuHv#UR^-Ok0@wBl+=;U*?E z=@s(YhO939{IbT88xaZ;ToRR2 zZeL!r&~5L*=lc6uE06zw!EMONvXl4jjWW@PcMTg7j)(D<>+NP^@$d7$`?%lk=!Fl) zwyDpc4rHsy;mu<(9hlmGw?D^T41yo!V1)i{+RXV(kk9Rr~i?M8?%+%7Vqfe`!C#k-5S{W{PtL@p+Jq}9G2P~23GJ@z3r$%qS#VgQvSjK%FW=pf zIf6F7j08^{WtHEY=e&odNtnrzhyU~X+wXTAWN<$6R<5lreupu`!G8O?H}m%VzcSax zx|-Gb@PZB|7Ij$$y^0fITQ-K;Zsd>>U|GR^P)C$ggD3g;8>zA^>kWSj|H<#-iu!+G zi<_{RBZJUvX%B~)k4~0USf<1r2o%q_a!n}HNlSch&%%dX9H(+LjTq|{JQ;IceH2sY zn-?*M)u}$Yx!2|7{KECjO)qVxH61EBqWb)p{X|8Hz+J+QqOtr;ix=ErU|=fuba4!6 zd(`>#Wy$YOSB5kHK5b*)d;d&ua<5-hPQ2XYXvd1&X*La>5sopl$z2hMR z-*Wu~!8^wb3>qG!Z{Vo=8(;nI$IX*%j0aP$7F2EYnCLL!)I^>~>D$ZBGdniSQ4{Ze z5Xo%aKEqUicZp@XjiClkaW7F8@HVf>`?pIo+ljzw3s3)HF=86{7Pm-7^>E z&{{M{UvEVOm%tV8<45g6HQJaKu08T>-%5u7S*gCY`BwAn?2F8j1V2SiZ9l`GwPjT$ z%O^eCRnCXKjiWylh}Mg%Xn!%QvV5|h^JM5r-7Ot~Gp8pC7)UHg{I7YhV-<_#LABHC zUog}h&V4cAh?}e7kHF@{ZktzS)oFrnRGkmAG|jL1GV}MR=JgCL{c*jn8?HTC^)O{4 z$KB&84G;1kxPRCu&F_%9?%0c>42k5sjE$~>M}OZ>3~93Ge_i9mECL~|OucfMKQzYrIVahR(d_rn?{$2Cq$+emTtkJ+A(dg~`@J2~w|k|{_f;lW7R%TDc=(~2-;P7R z{!gI<58F3MzVX{EO|5~)>_$A9|uC6kcGeMcp`W6LpW!0|o zxa#gT=j&$W3HK-ItYEa=zeY`UYgyFgV%Lk`-UmE=`Sx5*+^*bLqW9;%?fi04V?mLB zxEJ4IU;f!Ue@5Ijd;9a@zfHHz<{n;RJ*%*I*Qdlk0b)mYUXV*-s484%ES?c;aN%5; z`IquviLVpQWBxySUGVgC)>?lk--0+}v^>luDj#WaU0wJ~xg-PvKH!iN8 zqLh%o@bbmI&HJ|g6y+8CmvhDI@C=E^hx#lVa!TAAE&JRS1oz&GQV4;wBu7St4;bZ*W}&Sg;x)iY0Limr)p3z_hkgXL~Q@U>@8OXqLP6E0rM zKW*E#l1>KM00F~eGg{^Dv2m3BPE0RWkNN+nYDfL=x*xy${~7*S%y=;RxI716s-Vo2 zD3+rKVjTjC94{yG8z@-Z=j=A{Tu`vkSif7r;ex2q{RJ-qU1uHeGSeLM~;?xnfI@SB+a@iH^jF)`<2nQLfTJuBFk$EE%f{|-wP=$Fx-EM&C^JP{~*gjcU#<{RzA4^8SUCp_5pI7l4|2o(HE?K9k`GTmx zo_|Mu=S%&2Y9He8Ve@iBQ=9!Fhi)BnW8jFpB6aX|lyb$>yVGSj;;hB5>8)v9cp+P2 zh0yI{rqVTnJs12;OL|s!y}K;Nyn0{oEY=Ilnp6J<&vA9MyT-a~WkSQlrbFH>jCKCM zuV1M9Dy?kl{w$Oyz*oY%%bndIFi)Pd=z@Du^P4zXMcx-bOV@2ruoo~`@;E2eHA-D@ z{%3iS>aFda3u_~ds%x&YoZFvKtCsC;(Iy-*IqE`z-c%>mkchCT)7gmu(Nlt+xwAKm#pO=bKLX}0e6nauOts4P<>i^ScP7OKXled(eCV(}J@Grw z0-H|xi?a1+II^nP1az)0yk6Cv6sbTG^ zM}=Xoi};(;Bjj&f-p9+_^lHi7wYkhqw`cDyc)dFM;lI1TA1EAsE>@&BuyTR)ua zZ>PGgckXW=%RTcCF|vc9569Euy5xC?ae5exe0uU*S@R4OrZC<`r&41I`;&jo z)t+tUsch}{dvvhonBf` znzknXPzMI*h1>OaQ@&dYnznP|dFn^_z`DvA?QMu?eWwx8C-Ir~%KTQ_i z=}3ZaGp0sX+3IY&m`~77gKm)WVviob;V2# z^XlVrQ%*|feJnJ;Wp?hDmCePo>w+IKR4uZ2nIHYZ~B+RjW)~2V6?ths*<4hfk z*QsB}>P$8pJU;O5+Ke+2J&KESEiA8nTs(vE;I~{Sar>)UcD@H{6L1uZPNvk z%1h#=HJ#%~`Ea#8_8_+pXZG@f%u|M~(EpwA@q^tE76F?74^g=PG-4AbF<+2h6e|K zTvMCIe9&x)rSGJG@5LYUem%W%^t;!EU%7=xoGSJG_8S~>>Vv1c0KiP zUdU z#VoZ0{i*!zM;Ko0cy;d24bK~M?_Vn3@*{G`UjO#>R$Uqce?iyoy&Vu zf1Wu1KRJV?vFm`}R~d#|1Dg|JIaCJ1iF&-#Rke>}+5J%f#e=-go{vG%+qy*=o4Oiy=1V(TmAPMKw=8P}p+p zmeI3mr}K95-QE9}FX-ZO;dC~Z+n?wDn;6Y9(fD7PlE9tHkbJS9NB!#s?f$+0|M^Ld z*v+^X*Bu1r1w_^cD6VtcGkHd3LT$z~69DHP1NyNshAvWJs-c@qFm3%kl zM%k_1MU8p$zXb-#u?m#5-rpCd_TlD&LqSY+HXn|!D`s!nb=gm==Es{ew%fFKS}a{R z&CpAh>tBgH_v4ehm)s~1o+6^|mHf>9e(W9AR}w!iJ3OeqE~G1vg>~6w) z7q8PSlX`+|HmdkG?LB>AiS;6N(c=wej%7>tSV=6O_11i4#qqDl6MydLH0tFl4O*I9 zky*XPXPaZ#srdD-k+y6(ZI^>A4k+wyd;aLt4i=W}=DQz$yS_d5`iGOuO;!O_3aj0P zIILWmnmVke*|TM?so~lvdr-Pt`)r{hk`lqGtOy6@hDepUpC3&vu>eBN_fTZ!33R+WaNv+2lJ_i`w~F zCX2ied?EZKmWRdrR&-54ZQ!X1X}^8DV!1-pmX=36eEL|eYFp5uwOxU?=0~YoIfX!i z$In#Y4kO2_^Ad|2CoU9t$Z#W(^$1hPiP@eZE^An0-meKe``|Lal#A#yUcL(f8{SHl zZffRqigec&f3b?|_^W3XOpf{SB1QrNorzL2mal7gpy0>*z0LZW`{(apo@cYw?vh|U zJpaeF%&$2MF1kBRp1bGh_enGF?AMoBnKI$VjkYP5AIfjwJAU*=yqYqv2w`ulF&Vx#Ej>3v4{Oi+jqi+#D5@V+@E+gHa4Yo){lY<1sZsCey5^V+Z8 z4UJj>-e;zqN;ldhzg)#pSt;a}oXL?ZuMJhd*<@~7x}d>u&75%0=UcRMGiTmf`s+!^ z)5mH>yXU`orx(2O%{#xOMgE%gd&N?}W-zmSE@tt+a;4yWoT0jc#8eB}rq2wFjXX`> z+k|gik3P%Iaw&6~$pR(rdzGhlUpNvb+8Cz0O>uR`saaPRPc3iK+P(6wjJrZdL4giW zdn{8CLsMic+#XT5-< z8mCL8r`cYstx-mkQZJj&&`=jma#UdS{O*|)f2YB|_|OmCm*>6HXD(?nJ9SfIwiajq zJk#*)_qSxn9gF@wv4E#BVbb+k(Yu!}D=Aog`O;jeC5qE~4}9dW{<`<$mE+g9Psuk{ zh`2QE-sSG3o_`T~op&Z}+j4gDzO0#hCeF=LxFIf(@}fwAqq?bK-h9>@59c1taxv@p zu&Lml#36+)(WN0LBMz~~8!OzH6qzNTzjfM|10vEA+-xDtO%b1JUWr@W;E!c*I-GlV zXQ*Ya*g}We)6J85nH*1@ys{zwrWd-JfGX= z#jXULG4$~2khhtXw_E6Vx!7@er$k-V^zg^qHm$fcCBJU{s)G;R=A=JlTz7c(tl#bN z*^ghXSefHw#`lTa%k{S3RxyzopO(n)@(g=1{p_hJe0gVYC>L2uSv=dRcs%)#e^!Re2;?+xP+!e!@{;~C#JwHpqqJ!P*vfz)@mMW$%x=cT| z7!+0R$dGmx6aTZuf$g=)Hub~}ek$jTcJ!NBooCivqf-hBh~!85PIvFgvT&SAT4R1; zgBaKDc>fFMm)Ehfo64>UZF-hJ+e3s;;L!xd>8xJqlMmSaW7HDuW7ZB!p6`;P7wwn8 z@~i00w%u(c@pcoXiX4s!N_*K7Dk4F0<{qBPKVmU#)xaf-}M+>qtCrx{_^b zV^HOiM>le-J`_w^|9QotdB3E02<$Z8x-05*@1mugJ1@?!t-4rYJ_N#MJVL?Mp3H zxGyI@wbzqnzV(>t+o#QDH?<4q>}Q+Da_r16R&f)9R0b}E$NhfXUy_44g7>$4O_gNf zVdB}DJZpx@PZbH1<%^>n3i*DWXrA$GX@2?5AMOT=6S!8b@7fh^{dM(smh>l)wr-3K zsfm)7whj6BKD7w#R=9qI|5IvKg!PlJ$0sv7UhS;lOo;IL+AA_Sv^}(Q?SoUMtHVR5 zpIN_+&r(`r?#CdLV-u|=*-n;D?OHhDx?Xak+`F%mFU*>l^f&IlP}<@vphQ;oa2=>;Ato2j{xSGVZUr{^2rH)2qo02frFiCuXKv&Z&Qy zwByUMrv*>niXYx>Ut>LI_ph280s>FAMiyJeY`;8tYX3r4pOC*b$sKne^BbgSl$3=s zxYjxQO4@g?Q=aF0Th?WP_i2+0MGU`uOAl-^GJQQ$Q+um^`ty|sZ~C5FzJ7a42{XG( z^6kr;uRW9eG5Ofr^O;E!RZhLO0WaHI@0r$ontSbZ)~Oqg@)x@IEvPfzzM}5n=6@x6 ziqfk%KHghYZM$1o|AocOrJFB>|IC=$$TZ)`ePieHiO2rVS$~3k@8mzh73ZFx@_+L4 zfbl!_D7p8UcjR4XCe$DOtQop#kKClGhx+C{58PT9Hvev2R;|mj15Ycrbg3Ov`kcD1 zrcC4i!jNg#Jr_*Vd84>sTUh0(&>Onu!RI!(eqw*QdF#2{i3b@yWjL}}7&uOGIMqL7 z>6&}ox@^IhbIFVc^<_EgzS!3Z{`+~HsVV**=lq&aD~qo5TW&4hKfl~dUiov~ajQS4 zr|Y+`4qxB){a&^Hnc5!@+Yj^G{ZOd+^YOUZ)>B`!dZ+nsHWLnD^D>WQna;|hAG23R zFIiATphmv?!Per$$B*1*y!QTKvP(kX$`pBf7Dgr+p0o1#+=i=}MO`O;@;o#7{(@Q8 zJm#H0R$8*^|=7g|?K4tr+__HLU&4#_EVFT;3eP_>Cb>02Ex#V8o@{4J!PF2c#*`5e? z(tWTe{AtnDh6TRMFMm{8I`MV)2NtK}njZ`6G~X5Oe)cOnDmDAXI?dFeIDXG_JRD+M z+W2R%3i=7GOj#%uGyCW~#)E41->PRZ9y}q-#=vq)rztb*M#F=t9~LcZyZ`^IZ9FObQ$)=mJ$7PYCL7CKMfD%M*Js8#aBOJf z6=qAwNho@7@SEanE;9#?E6KhK80PCVHrTCcYHDW-JY#g?t|n{Ky)*apgZLlb61;!J zmN}Kd^#H>HX8CJ3qS8fLlP%dNd{IAS+cQPfzmUVXPpshi0js;$_lceUB+dQn70a5n zL37D$+5^^Wv82-s84PcDc_$x?|5BFsYI*R zW{z`98JGGkIePabd(%qYV;^^XJ1rF%Gn4V4*djsCGzSBtMQlxqYw|O)DoP^{_+L9< z&e){i`u@-I@~<`bmbE=k4NHicVA|xvsoYV+(6oa!lI<;@s?^lZQrBfWTr4(oxGkH1 zfm^|!S5tsvO5o{Nvu;UphxqfeeM`}0V_SAsamHHC^5}$3999-8jhE8|UA|nd;H^Kh z^as1Zm(Lt8H65~QXMUBb`;>l4cHb>|F{kYsMjNvi1fIWk+Qr#x>+1LIh2HURC$D(2 z`2XGJdam!UmwZtBdeMF=^NLSKRlBDipPkop<2|3@7f<|!E6r!;)Lojf$uViQX~0|QS0(|^f-BT_+F1&eqza1) zyj^R5jb+!_{*{T02NmTHC@<6~+RnbqtK8v*gTXT8u0rbuf2H$mKYwy@imocRs0g+< zw12J3$8uC8x;(pVpT&dohP^)jA5D9ZimGogr1;ZrO(xB9a%@+286RAe~)HxatU%c89)bmVcw zG}%a|T4#=I)=2pieu?$L9om~&I3ukCex}&p@mCk{S^MX#F|4 zw63U2QXuENv+(V2Puwh-o8C%1+q3q!j_sbJpSgAUPiDG{Ca#yx@O~kA|FzNEsjmWm zpKo{|oF{g&@xi8LZTj)mhI^LuDuv&#RsHj^zRo`8n$$sK@f5+3+qcsu&h5Kdw&BAQ zz5l9B3!XUTT+luS_tfyc4vbWYdS@fc}!;gaowc*Qz z=YL)Ku<)&;z5Mezn;#!OcF~$cXW{goGYti4m{ z^}putPj>jQ^K*L6Ej|T{?aif)&Xuwp-;Q&+GBur>DJdYMtl0jdRK#IIX}tz-+5Bs- z17^JYnyV1InPZdLgsY8v9FI6Y$on|qKxmb^(v++ZmR*i71SI#n2R)urvUjt&=A~Wh zikVJxav0r_mM{qrzs@Jc!192R=_j+zp<^tJcdy@K6VR+Tn-Ma5d&{2G-{EUSs{5Oq zC-NE`4}ADO_S0c*%XJPHqW_(IwKHF8tH-u;PZACkva#GYxKaB2hug{Dne)OV(>pzT zycC~%zOAg6`FiM#(vKx#jwcC^RWo# zy^m%-GW?t{W%`|(vK2B`r;f;+viz{>v#CPH)o1QPU)TQTa1e;w@JzH2|}+d1Q{ z-|mULb^696@HXlFGA*_ywQqW@yMv|QA3i@rDZMv*ntR|ccb7f-0zN`kN-Jh$o|382 zdVH0KW83o&CpU6Jl)v*D`fyJRSo5`J!O`lleO~d^xF$c|@QeSs@MOEa>Ca?b0BGOcRE0$j%r)!Veg|(;d zc^7dn{3=zKxv|yCiZ9LFUB$K2-_XR?as3~YTAqLx9c2g2W){RVdo;J++Gvx1`RtSV zkAA`ShumTleSY*FJV$CZD%L0ug#uYaOyHA%ih3@pld8l zEZYw!&lV}GRycG>pZ)*F2Un!xl#Q6)hhCe&!BRQTn#;wywDOX`m1Kb;YqvF<=CQJ@ z+%dthwl!Vm@8SLn2e)5)WmRzU&_nOD(`LPhi%$i+8Wu1cWKCms z{I9F>E>gVHA>i-P#)QrB76Kw`+0NYxu#)5WC1McfaA3YpeU@^A0yE2k3Ga^{>|#7< zBVNzHmt#_H-v<$6z1v$U`zTR8?D%r?C*HUf8 ziEQ&30jDBMC54y0no?sau;%H$(3>F()7dz>6f0*>V|J91uf2NDH`Z;9#>{|i8dApo zsfG`3e_4C%q>{z*n-}Z8b?wZJGrWHJrPNE&;_`Rx%YSuQPC0PtQA~tw^)bFF`_?>8 zUbpXS(T{7p!w=8@|6%tn*E1gtUsr{%DSuGs&piE}*uwQyzu+1ak=eV0~mx>FLHKcpRk29H*$OL^9R9yPhRSn z|1LT4(!+;8!t8mpMYIE=bwvYNw5Ro*U3tZ0GoSC*OFYVdGj}PU)OC;7)pDLW=eur4 z|AZwHCf)``H*Xw$CKW(wL+U&-q9-XPP9xs(nviMt(e)_)Yo$5RM_iGB3@9eL(|MT~Jy`7gY)W+@m}eywl$r=_E%D1&a@XYuDeQnU(eGuX6DeF z#U%e?LB=%(CYI{r+hqk?ZnAEDc+gS7LEs@f%R6?K=rmhpYZ1O58?R(4dp6ZrEjqS9 zVZ((+g#!W$I%+nYyZDsl=$Xm$d>1}GUlqvSvi0U4b;|V(RN1}d{!7-T6&v&%0>ln-ahy`JU~W?skH5|^IZj`+NKKl@>$Xg#?kT4)sh3-fyA!JaMFp$uy`UxacKY|9 zVH5p&TnpG(Zf|{VxXft@x9ORUYkV_pBkG@7C$ckD{5?4Bp6uDqMy94U99Q(qu5lS{ zxV^(~Zf@3&kVbj$w7HXk?bs9ZxW~J6dwk~I^5q3T z>>e*`OLzG2;b+Ye&1v0V1jRR`mM#4%5YrJ{?#y^_UPFSsgT`rv<41W|SR$=YOt4Eh zus!HT@aa!yPAogi7;c+94v>ZQ17bBXBP>xydevC2PIHwG0uT(HhjIHfe_LUcs<1BLnhwHp*}UGbb8 zv*rAW)Md7NQ%;UaZhkrUNUoq>umCd*BnA=6m{M6ukutiaoS7ArApDf3;sIVYi zzjva3Q<~SkyuN*p&+gkLL7J!8D^7+uuTXp1pfSyt*ErAW$jmuqzJXfXpYB=p*~+dw zjypNRabc0|CB3MfbGCSY_gs-Cc2ND{y^X!qR#wZjH*D(bO!}%AeIb9x+Uk4Cn{w~l z8Oj`7h_#SPVUr_>7mYFJTKk8wr5UwZm^w~)p}RO&5O2aXg&`- z;pthqU@qgqpuV{rzb;=ij1`<->SHyt_6*yJG{Jb~jC{e3>g-J~g6)p24BA_+l=2`& z?9%PjC5~Sre!En5JdhPgKX5Mk5}WOxKl+Wfj8?sEa=`|E`T83RqN_W21oT!cIMdje z=4|qag~f967QM#CV_ka%&2D96UrJFt%ou#wSRrELOU?Tt{^8+oZ|-}bZ1(u1VD`jW zKGK?L4jW8Y7cIT0HR*nnn*L|ANop1fo zS0iG>7j=af=l40X+9qsTn1B9;sPy+d!;gnd%6Nk+xQ{EHnCNoWsz>B+h}|K^?C#{S z-H+`0&P3ey->4+iAN0Y3x#{ig#aBM1>Gm~g6nW}z=?{ro_f1oN&Zm%QmUM>?51I;X zl71bC3YykfS1KWJM9JdHy2RNc&t6FE4WFUj%Tc)J+SG&bcmLm%Uhf@IwPcG%a?EDW znjJYZZ-u^^inATR(#BvhS?W(u+Xjyu&FB9d#M-O3^+$*~t*K>G(3O4Uc~N`cdRvv; z|HTC!P4l+>Zz#FovG3b6r_=9m{wnIT^zREkJGo|y-sG+IKNap<)pE>sx~HX8{qppj zUw(;pR{lFK1TMQ&B$`&p@G0nk>-lr{ldkBUPD)#8%O$-e)^T1(78{HE4fD+$eFjff z+D+4z&}q!!dbn0;@55w9hie>G0xqAwl`6>WIIv48eKHcAv^z>7`sbecGwbV z8&t)ts_-Ir`qWJq>++5-^pzD^c5L0t*LL$76zn8$FFRVm9f1N?PhVGcg;fm+8nD3f$pbe z(o!xzVVG_4qx98+{y7ZqPBaQge*g1P@A*dzv$0dK8t{TUKezl z%u3e?*gih|ooRuA)fD@>Kf8;qY}TyU^=Xy!BfD(AX$R&$e%95v;OfFPa$os-US6#O zO{8uUDY)3p9bLo5V*fLQx9CbX%XF*6uV>osneGwNtAE{E@YVO8>7Sw>+HM!cc8)B5$zt<`G;x6J?Y+spr6_4t@$PR% zwLQ$1Yo%YmuI)4Qchji+9sH=@Og*D_=2iI%i7%Qqu;@&g#CU6qWFyN853ca7kA5rh z&I$Q=#MbrW%+AJ|lcv*@SLfW5kJ%C`GZ~T4FLYLEP=0WGjRb4^tdi>(PVSl=}wjXf+!TaW8HFI4b%U820OC{!ATD5-3 ztHNyiPtP}eK6SKYjZNrRo%XIJ%gxkIIP#VIy?C>5qe7|uJ00Dpd**+x3kja`!RY9% zt2UYs1lIFP=1yGK{7bB*(zk!JK)_jqHYg$ktxu3D$lwzyx*d|T=sZDM*fZpzI4Q+EG)6BB?XT}{``WcL{@E!n8t?Y?g z8!}nG2}M zIZS9g_%38w1RM9t{d4^N@@s+x94Ik_k!_f^E(~oM!7}tLaTFhG(3ME*s`qVbkg)w3%9yNP8Q!j|K+knn%UNeEw?4| zvK-b^s5sy7U_B4Vy?>wlemq&B+axMblc%hcBv>P=@FS_>>)h#w=l?&U+jKs*pgSQx zV&QR#%&@5^d1sraWiFq|c<|((wVJ1__P>2HWf4n*flDvb!IFETxo+&t9C_{SWvmQR z0$bFNhCKiLul$RHzy!19%HAf1xnB>kSS;V#byY!{{effrVKY&~+>2LjTbEtwn!iqv zp25pAj&b-;dj78t%7Ej1_U>7}aIL~l;b?qDbt?hesdU#y<|F31NICXc= zG)oPi`6)5mF8o-$%t|_VqU$5S%5?ve-(BL0=iXh$w8iacyP2R%u$35iRRSMNclN}u zKi#gie@pmv=*cdXlgmt|ADJViE8Dv-?19(Q3zPJ74>f&q=vs2S|58(hIvWR5!C55@ zg&kWaF*^G4{?C?XU^LM&lxW>W7G0#)Xv2eHgWA5Pi-yi=3SnY~r z`F1)rWKGC2p-&fIsQ=n&ImLHX7qjD6-`+AdH->K$D}7%6(hbvVQ26F>PwUK;4gbFE zNq){D$F8uVN?Bb}z@%GY!67Zh2^urszP|3geYI)tuCgy#Hqn#QZ-g@`7nog-3Ox8y7982(|7q?z(fz#v&dF1p5B0j8U*^QaVP&dtr%OS>gXL45 zn5?^yWch=c6=#;tyT|(I;Pev#cT2Y{6VSSKZ0e?c5A}VnvoFZF(jwivZ2sY{q(>YJ zCyFfN-gGc|@@HAk-4iRU?wl69+_1pbQlRAEhNSe_1w9Xr)a^X8U4I|*W2Rr!5qfa=t$}w2rZee^>3^$myXkx~57T3VtGSqgzQvuuyWnTcZNQ z`D!gG5eA9*p^-ZEwYJPGACFhvn0uKo>F4`Y!Ibh>7nX%TZm`tVldxF)&V)<;X*z@7 z)da`3JsIoQ>dH3mU3)mMEacr=*~qP-+`3m}8EjI_Ug_wxJyp$hdcon5u{S4Ou>R78 z<%(i1*|OJC$>2U7P&LAoMug* zpEX^*EW_}WmHnyNjlG%ibC@09eOa@Fp@uDAMDI_&LxFk}X#A^V3)}w3Of0p&%Bp1y z-ATm?Cl=W9^vl0*S$q8UuNS+1UeIZdV6TjpoNfOsl{Y3b?$VbH+ve$HD-{ZESbmg~ zn@Ox&cDvZ7O2;kSK8l-bbS;w=w0cVVqi~E()&G6KXN7Q$kUL{_V05I z__Tk+lK8W01bb$?#(C~;tN&taZ|4?#m}lb}!8b+~n<7)>Gf%MZXR}TLGGqySD zpL&Rs!{u$IHK$$bteGnlWj35zrhoOEo#`1V$2A#m6t1;#A5Hv`e5OovRbnWAL`2^? zB@f>(8#gVO8zMJ#`oWcpOY7H&B;`K%TRl6m_;X;zj}L)6%KuK&X|Yap-=DGTHk0B7 zt~+ZzzKL6LCzjS)u34vd%1a|)#}0|GYts&YdNt{;bNl_KLj}{;e`T&{d>sANeD$i& z*F_i=H^vxnzl-MScR7-NDe|lJpBDwwzqFm4{L4PvPAspc?A}iOLJrnNj*hce=$`f8 zeo;~0`|no?FY6D=j=Bw^7c*X0%kxi^jq=D0xAO2mbtsj${@uyh{F#@8bDVC@`?;xr zKktruQ^@r%H9_l_vvW+_+Hifh&--cHcW!CntpB}fsvocV%>4O>88ueAB-(ZrFI3vN zU-WpcWTRa#pGKiN7l)DPHmSx3N5kWJ*6(?G{P>^zTRM}LwN+>NEW4D`yI_sx?uG|5 z+)hk&sZ`fUEMKx#q`|I?u!?%t_MZ|pKRXx2) zM(<_2a3zD*YHxPre9ipgAe)=#Qham6dj)6Af9f;u(bhD< z#4Uz)dc|&;ffdvCr!c0AT%7;B@|>0l*UG|-E3s?-HuPp4XWgoteMD#8yvJHDi%v~6 z`g__*m*1Y{_I%g8W>dC%Pd<3}eVKgvy}xhuVh=8vE4R*N)p z*SADI*;>B7&Hnep--eHvKxXf^nubXx8rFFBM{}`smRKBnbZaR8saY?}M z+__I}nVZ($*eWj2a{E}}Wjm`WsRw@6n3#qgc+A0~xj|>*zOPrFq&94gV&2W{D9gHN zYs2=uJE9VM^bLMEIDDAKcu;q(=$$H;xhl(5taGMUTI|9+-^(vArr32ZJXx=H=&Oj$6W^;96aFoX@!w*6ts_0= zVVm#d<5H$Oo0mH~92Ve-b6fuYMEv{zC-0y5$~yHAkHRn8g7ddj`5H3WYkw{EpRs@U zk>Y}am1SF|G_#QYOCEU8$qSXjhl?bFyB9&cxFUUuen$ZxrKv4-opUh@h(nLLMo-B#JtKlQp7 zn1u$2nRP#L*l>E69w&ovlK*9;j4%n_Puw3%1hgm09%mAW*;0IdckJ9d|IWTGcztbd z!S87d51;ere&)D*`1Y>@tk-7fX5=ay$n%`-HZ8nVKj4JON2B?od(Suds(gx$jN|j( zHZNeBawOaI6wMT8&e^^UT{X{A6OW%~SlN*DO2j94c1Zdy*~+HlPjlx*y?+unS6Z+0 zoN86!m#0nLUB?bRJ+A#}(Zha+8&z1y-d6oN1eO-T7$UKm8-W7Pd zf3b?T)VnDU1B?#2O?7!$xL8zBQYN9aB>ef(9aHRI9&;(^T2~sqWwnS++OvdN=XOu` zbX=XY=Wg=v?OlpWzqf{m^+)O5N)3wQ589f%@s_Im$_W=2aXdY8ZT_i6qOYA_1w>4| z^v%O+;Sx1|<6-`!Pvj5l`g zS|x!g>!VpLtuHKZ>*p5;IjK51^XxpYJnN>rN*W3pb8g*z*}i_?4#~VbA`(}gzkA-# z%CP&F&H}&NNKFE(-(XgP;m-oE1#g<-GrW$SSO%m&L zZ>CM!x-~S~o?}9c{c710Oue#8cQ5JJ)cCmdykuL0o!ITZ9iPnPJs+^x&Fbwxyzgkm zzK8q&JGn~dDiccI_fEOIY{ACDJ*8LTI0j}z3j%FE8OvQmCASa6yCNgx4XZ|SLuyZ8oP}bufU7r+XEKQi(qoN zvdWOr@tkT(;N?YgjaL}IOyP|YV~Dx(<-@9V*{_+Jyt^OvTocsGQ07cLzjD9M37^c_ z-Yg0yoB8uoH}YDn)K~BiE4aE?vHP90wyNFr^Dp_{y?-yXH2CM`B^JMzSNvGWR66Hg z&evew)k@c&%5bv;JI2(!J^5taqsi(mKMpQ`x9OI_;;%0jt=v?oFk_Nw_X0(kFP!$3 zs>;*0*?aGL(yxEMCOh+>L%QgtbB2QJ?!CLHY`0u}xzCl8<$p{Ar*5kZb1agd{bNP` z(McPx?6&Ro-M#nw*O_JlU&?ahg&#NWbF18#uj<$9T5vzAkJn{g_nme7%q`1;<^7gz zKc=l4-knk`R8@7e&{N9r;@2>}qiLMMd+uM%x#Ez1ds#W}Z|!Fl*FWSR4z4^p=jEoQ z0%qstU7YPY?eNdl;)kc2>$i)uvh4r7_`6Bynw1Z`t?C?^)r}jQbtApDXlQ+undq?c zW6t+oo=riqq4kIP)a<#gZ$5fyv+VZ?M>h)C_H#A4DjGaX-CkWInVXytx@OAu`w>3% z#z*8jd%lJ#ZQ__>v6*9viv@%3*A+jFEgQG!t(xW5aiGP7jmdV8JIibN=d9m;FfKTM z?vB|)!@~2r=P%#LUieavzxN{F&nD4X@hZ#*;Vj*Qoi)5E=f*odhCULb)2)FOj&m8f>ps6uUg|ko3+_bHf?&|S0yv;j)nh< z>v0ULmaTZ-GtczGMOC}2;U)5^CARJV_rw+Nu!-odle_quNjFz3t4<-(Y~J-p1+E`6 zvbR>P+B9$Vq$38(7sPk}+|9jZr*(g_=5D*IYoD(ySn7UCr)Gin6RGY`yZ(vRPFemX zXU;15ML9=#_&)|+-IzM7^SkcJUY(6wd}Xxzm8MKv?R$$?>ZE7q?8gQF5B)o^=I)l* z%IXXJr*=eJHFxZ}?Y5!m)aElwj!eDQxaH#cZ9X1Vbqh?tf2*thdQNt2AUj8y`R<3; zu5V{{_#kfoJGJKehuFQ@KfWI^n|m?;j6z`WOPSv4p5SZgOKV|^TuG36S=TjX%^qzir$~yeeZ~L0?=Unsn zrJ0(FX9=h2NOE!fii{OGB+6&o!Pv8{ZTpjhSLgpoyW4x*IRA5C%tc181^EiOO8q5g z_9Ra}U#ItJxnt0A&xxg5UDJ3saq=HIdG!@b5vzQ-LdLYSOH3Y#?tAJW@ZorgT9}dS z$u$@Dh^k$$y(QA1!Dhw$CCfW%T4wmHt@@|GCYKs5Yux|y*R*A=tW5d$_{;ZIF0f-v zy==Ll$o}2xbm<9KpGhf93|`iGGvrX!p{Gw>nVW6&i~saA$j|l(n|FEdy6#WUe@I4G zXFM17Iw!h*aWPk9u?4%s6&sVy$3KO|YKZS`^*bl<;AzTsyE*17RHRlv-@wT-H>fj0 zA^zQCQzgFMIZ}6O)9*jFd=UJ7UCUgjKi;{@+m=-yI`DCgY>a_|2LGYn?>8;z8wv?e^x#p=KmpSs@ur=-FV3Dm55zm_?_#?EXXJeXUUzzNuV*<8i+u0sobbiY- zjq~5H>*guEH3IMM2np=@c%flY_cG6>lX_frlj zUb(9GD3x#FHTU3S*-T9gM@7pNvTYSF-#C41%GO1`8b9=Pjn3*Mtmt3JrTShp@a`3b z8|jSOcurjjvUGNIJ-dEd;;(tv+r3?%UvZIG87^wDTk@d;FN?Ch=)42+MU$C@tEc(B z;JBgs+&;@y!{Avq_vUS#F5IF5CAJ=ZFFdoIKP@oU`nXH>YTY+2SD^+esr^dp#WpWI zm(nOu(W5ePo=PnL>^k2f)my=qu(JSsqfT*OIMKiF@w1{j|HV1STtA-MY1u0iG;8Dg zWyd+gw|W%L^y3%E;rPtrcTt?7N%*7`i*a{CN;_}Gq_dWhEZ5KPaQ$%SD)+-ybG=sa z`*n(Y{x+8%VqGg3vww$No3)iogz`lP_w_gXE>4Vl>~%)eD z^h=j^t>=un^?cg0WfD!39#4(G<+YH}(Ym!g+RT85#j486MarOX&74_$4O3*+H@(iy z)|hTs`}Q`TaY*-%Cq)=ChY?9_d>%w(fhEF07YrdF)fy zGO?%UzZCyv*1YQdQnU7V@&WbrQ?{SfYcTwIRAINt>m@AT7My;3=G{YwqmN?WG%Q~{ zuj0eX-vUetRr-_Me4qI%xvtmEDCYcoe%YtwMSmQe!)KLUx%%Hm_w+)kogz-vlh&_$ z%Z0vYNcCt^VKT{zLo! z%rI^82QQ;$b12YcVA1F1ND{1h&Ys`?IZAm)U7;?Il7Nhz*p|TAW_6ivdAmc;PZfz< zcR#>nmY?_Q*u9D;)_XrVuzTF!xmQxo{#Dy-rY3&5oVNDw=7$&m z{^gi_Xkpat4*vbKy|j3h{KSL(nU+2)Io(raX20F7O8c{Jecg)}hhM*#w#c<0H0;3F z-qc2?NY1SrQ);K4RlOCeclK4nWAER`NVEU*Sw0pc{VP_ z4Nu=abJlJbel_jH&jx+{In(dIPrq-TE?6(PMK$u(%h1(m#>zZKCn+3kiTKo3#9s9eHMJVmm`k)9XTd3clj;#qh1|4VzYZvKwXOOlz+F4#NY;JeS&m3f_!x}PmI1h&NYKk|H} z`Pei5vVRrh?1lw>;S+yOKdV&s=A@(HGV~1`E~grW+%+n=0$i+Hd?d3&ZKAQLf85wxxq&_eJPB+ zSX$ZpUE=lLV^({ra;KWl^f;Ev8x!>d`2D-W-Bub#yGQ~%U_^ZyE~ee8?3 z^hWlHmBe)Z`?1_AjPEW_MdPM*Jg-hx&Sg;Zz3H3kU$S|1F@xXR=WajQ)<^a~@7wn2 z$GfL1uVz+ByynWZk6yO0yW6gt%W!PU z{_$w`^h2qUEcZnPO1c*`D5!g${;}|;lWx?sQvvT!N^>twTE$jxXsc=RBR{ugsnfYb z3q%;}8LYZjb~jrukDPm%L2K$%2d*zIi;qN*)Y)K^IUPOw_AI`8eAoBy65aRnRo}9X?T7b9_dim+RATpbY0uReN77#(@tAq3 zTuyt@kFd|yADgvpzGw$^S@Ku1ssz}WwHeqlIIvt`WMZr;o@2V=xvK5$XzwkIt;!kK z&i}Y|D3ourSVKzl$u5V*^2y2!nj12nhRfZnGMFfPPpkFUtqG+v7bERW<(5`05r|#* zJo}jz--7UC*0<`)If6IX{%y#5<$T@O&Gwko>rYBjsZ*m2*h|>BRtxN!e{28#pr;eR zEPvX>6Y+aj-j^+%j}wfi-pEQ#oycD(wX5f?%c}NY)>q}9I>c?Ca<6dTv?L*wvyvxiZP}I$^BiZCJYI0>rSuwRW{#v^>g%3* z+Wqo>d8;|2;NMzlE*aI9 z7BV%t6zfUG=VV2sW&h3PzhPQq)S$2_+2O;(ZH@MQJwJbSNAJ2Hq<(wb-NQ1f#twbT zyQMx^w^d*3oG7r>{pe#hfi;!WQ@H(%I;_0~4gN9|`NuL&m0G~cWo_km>`Ckcfz|gH zt;4W$|R|)Sy(dZzIwI{y{d~}TW-S1=mJlh-Hr)+Ha&^otm6RVWK9jOg&0jpWBeputbn&Z3gpBGGf z|EkEp$~YnN>EnlgVK=Ubd=Rhyp;n`*aN_Ub-LoEDW1BSZ-sFy>lYjN`iCFSq-dmcq zboS+C2CJ8{rJqU&65&q%bY!FNr>*`W0dJ0f@xAq9lUVS%N3S#lm$iQFo>#}k8_yqne4$g8##$14-AA~t`g?JG|Ku+dmz?-?@cLoK z&Ti(qS4_WR)oerTtZeR916-?Mv+W6d9BXxFH(%Tk~Z;ll=6>n{P(w+Hf6t&IyPyM;gcS-t!owhdQKq)l@OcINw%!aY%mnc>qLt^RZo(K@TWXO};GafvB-g>NuNWZSYg zk2>5dwN=f7o;g=vIX7$9v&q4wa(>HBYkEzYcQkl!u6yF8Uxhr2=U!Ubm?pR-_V7Np z35R|AXMg^-n0GPHiB;b|^flaXKK{^{@u2>{g1gsP?e?tqJHGl%&h@45yY6(Sm)wz2 z=v`a9g{wN6@mB1CJu)^))x{gk#T^yzJm%HqeST48@h1M4b&mPEj4w7WOo?>AU@&#h zg4aPY={vUV6MFwKy=$gvJ5#sSmRYfOoK4o1haz@QtX4+ae(}8AuFl+ak;&WOP3c}G+o@LjWB;*gE(lm6k2XP-=Z zXHsP&x^~y|z*dh9wxP-XkQX)K=X&$C&MGaj7(|IOkL>+S#Dy?oQO=c6X$L04aI zRfUR|bH#HupZIJQP!&4cwXG^%{P|`>)0n?6OrAcwl;E><+qzKKyI&$^32m&&PMU40 z%$o7huke>phKTB_$^2dy!g*gsa-F!x?lt4$39UslR(}pS(d;6UU_GhRo9W`yWW#@@ znZidEfwaJ-$_+mBoCkXUgZsGRNCtSVT0nRC4SP+F9R(o#h`W|mlfA?-`cSQyHt#mt+z#J!(0BFd7-Q;O${ z$&*e~m{>yo|yEzIHvdVhqvV|6XYIjUYwjeY4f-3M-~Ju)a{*O)o-jYqvGnT zTOw^I17GxSjqqJ2?z+--LRt8luuSzuOXM$oUh;Ye^B?u2mRxs(Z^=yAx#t}p%kw3h z+i#{#+~^Q+{J4a`pI4eP^2`#K*j#*F=W;%7co4Z(FlP6LRpr~f3O`wiQpJx6e zReLVArB{5r4K1|CMB;?Y-(XXI0a;tZClbyytyIX{`H|4If*4)gpwZ z$}tE#ACy_YQ~CVFcxju@>5^#=7uRe&asEK~CC}ZfZ{_UPipe>9|Ab-q%(#UMHg|p( zJ)gncb;&-k>$o0+LT_(-@5py zVCuXlC(q?wHJ)|&-;V3+TaO;p3OsxDt-p;?(Jh;rkZD0TJa@VEb@K<8opqZ#XJ*8| zHB1Ljp2-aIFnM|^YQq-G6AMG`EiB)<}KyVsS^OU}&n=l%WBusmlo$MNGfrV1SI z5BN)`&%1nOgHBV9Sf#W3i9N-Zdp`f&e(3Y{dHk!zm&$xO#ESuk6<4 zi3x^n`LtE6W8u{L&62C-ojPNFs+hX?EIKN3X8zZv*HLdW_Sc9WaGUJfTc=^wJG<)H zc~RAmK8!|IVJlyRool2e4hDuh2m7-&z7XE8^ZMc+^`k*QR|H2tuMxRm#^9iH z(4MjMUzPJ*r4`qw8}^?3m$;0P$K+Mjls=4cP{os8t?7m5Nt(@d`gWiD=ezbbU^8JR58DHiVQJo=`IeW^>hc^O$I!hOaE?D>5N-5-wl=I3D7fsG&^K5r}@oCYS*K^ii>0kA4(VaiKe<#*pd^g|L)AWF#qSqNb7#z{|(oQr= zzh1n4im(*7yuNz*v6&J*`m)c-TSJwrvGFl#W_2^6q(I9J^8l_Y>hly(*r_>4O zb91>ywLTF$DxI9aEhW|VhYQZkG!b=`e6{x}Cr8nn8UGnB?{1sV z!4bqVc}2vugNl2yBVN8-BDVLd0@J~8C4rjPlVmk`1!8uuxUQZ#!Bjz`JK_HCctK~r zrhVQ<3>@p+6gVWFgnuhyY4VoZ!ND%3b~Pi*tIohg(|cBBy}}B|Xy$t+cT0A6PrtK< zWs}Ga?G+a$1#OY3pV*L)|G;5`wnoOH{9g0BRsEl?uqj@CsO1>ambt)@x!Lu@GiHG| zs}Gl!|9W`vZTq(1AFI#jx9Hpbc6%=^CQx%B{5SUv&kHlnrYfA?vGyRxf@Qk`-%lxX zH`=^uhaN+#tM6*Rt)Y9B7hJjev*yXhwVzESTc)f%$yI0beTrIw2t&sm-mQI2>8Z>5 zy(4(1EZVMjLNVsrr)c%3tDc+8ZED)Q>E)|y9!r;=(&ysXbXkJo#1zBJ$9>q7IaBs3 zSod4DvHf?Aw_?TT- zV-%6A5Vmt|87D{g^f#}{e}?W-N$Yc*|6`Yn>V#L1GgYjX&#RS}V}G_)Myc@n>}GYT zlYd{EP1?@Ukk~CMP$FqibSo;5bNSQUTE+04taEc;Tw42KhTh7_!uOqZCV1VRHS z-~1WRJf=+0Fu!2-t0P#`n!S&cP1);l!-BneL5WiWouy9RI^OEf|9gj;#ocxTw#Z(M zy2k7eyIpNw>s>315|CH)d~(5^tnEZ#Z^+b?);1=N)BzB5Nk=-OX`aPm`TzE_3?Cw>Hh}?8J4` zc34@P{OgYDS`#9)N@&||%`3WZg=81rVrAJ_!Fg@LqTNi5v2Uf8&6}f{wr9h<`kKas zaOs&BKP+m#S{^@s=R)HptMCG0g%@IuXAb*Z=FNFE_14StI?eaa zY0nkSopY&w(bA_M?%awzdij9TMurbxS>J6d-*!07KU@86+?-e33PSNrshOM-j8Z3? zOV=LC^18tuIcs6iqM!U+t;QWkFYVybvaA2Idos_YK3~~vg(>#?O#*fHtd=O~Xw45~ z=zpAfBlV4#F0BFo%V##xJIw}AsbelyHjE@f!XmqqvWO7CwqUUe*fnt zYLdDn@N$BwVxMokwC*h7`o)(*j3#)WTejftea3}{9lz)or6|TsdA35$)Bap>V$p>s zAKPXvT_JNaGV60*_!g7BJ{Km4#{JS<#;&1my&`M%c%d6~Y|W)Y zF~iR_x6Ds~P6CkJeDpw4cY^6GQ3G48zHf$Jnx+$0>itP`RTC0mk@H1uHlNV_TTwP+0=09N}ZGTnyi1;=$5eNTnMWvD=T|bG2{4b>xcJz zw{z5ee#$GWQ5&5vbWyUYKU?9&W#eh9u6A4BKD)XlV*kc%JH*b--zyOoe(liF&EhGF zf(={bc^anG-MCXJ^UiLE^tKX%uY238l0D;JYdqzTYH_Y%xICr*^WTsl7LB%mgi~`~ zv21NpogR_7#%SWCYJO9p-nk)=l z9P2p$tX;G2$3~MvubJht%nTcaW^D~9?75z@!aq((Tez;};Tqo^D^kz=n9juE^YzQ` z5*EQs3(*JW%iHsw@pUtQz8ZD(NOJ7e>3ijm#`w%jvfy3ZR;nK>+z>2%bN<$?mzTX~ zy{34nZP8YF&Cam!%SQz!shOzcd>6X*LWjTUk^H^7_a=9kSv-%)8ZA!wu)XP1Kzr50 z)Q8i|ysMfku2kBG=cnE2U&Z(N*Ol{Y-+j|Rv`!^p_p++;R-4%VPey?s51oqE-oAeM zmBd21%$?!CVyj0-r0hz?96g;l?PGYnSQqv@JXRttvsfxn(o```A>VTu z-)4@?Eh$#K58C4rq*zLuCwZ(oDLso(r)%AdSAOwoI3G+l+5(W9Bp~{k6Mhse0tV*E^qP7CgP={qW2!w~B{{rfyi} z+!>~#E_3=qxO?4>zZx}P&x${McrES6uWfzHU*=`~T(f57hmK>Hms?*K7P!pMzxL(h znV*syeS(jETcf$@NyG++d%1Iqg67q@yYDk-ij%zlo6$*}mm^8`%h#qk!8>+sOS|Tv z(+Qyhpn8-RLkGQI8Dv!G}*g;!?g*!E{NBhUD34Wgj}BVv=Wzo{!?*g zuV&ujvlgiBGx{_==4GL{=Djz!nwSMS`kEB-*@dMp*IwJ;b?&Li0*_nYQl~k*yQC(3 zxs_%1<(%$m{3=m(9yj;?Vk)_(`lz3)e}T`0vii_@OSJ<(RKzGM&9nQLaQ?HDPxkY_ zM>fo_of!O%V|vTc%Zx!DbK^c`#%Z6q^X1;>lSR2{d(_`LG7Hu7N!3SvJk`#;`s9|b zxX`xt9Xe7{yE@9s{?y5BF~AKL5wJ*P_IUu1iFRhhF`hV0QJ zdhypf5)5nBXg-aL4}SM6Syt=7saGqEEO>IZ)ky8QB>FD+`jKwMv_DT+ZhcHQ+%#$0 zj7`t{r#Y=vEjlv|iX>|8&F3C0{ZD;AY2=-*Tm=Gze#b4~cw=1prd zQ`WTYGJh5rBmGkH%hSc%W?r}QsS8@V@>|JQr_K{x*VnWw2^th%esDmdB>42@caFTi z2QnGot!Z4lKXU$L^9Pw_CXP1@)2GX|4sYFZ%7M{k(6UJO_(WE|0*HT*vxT{oO|nESvu2#4*8RybL$F)Ad@n zuiv}y<-^Yp-(J7RHGNtfhq#!2=G?nY4Kez6c9m<_e0d$;mcOoEw(jrjcy5V%f&zE0 znf$)saCwngX2H8>vvl$swAQSOZFn&4Uils2xen?-4O6>w5~unW&3ZMnSS5TxOSp-o zz!I+yo}I7Tl({?{i_TYhRHTJ{;NUwMzJEf5@QJF(cNg2&$R8=%vCNorx=Ak&!<`!f z0wNJ9%_pVutpo#(%zvEeQ|96BaPCvUyix9KZG=B9J=GHaHnWh}`( zlxU}?Ub;X&aPnfkD(QNQ*r{=%(mTEWuJk&T`8xluqWG_)PwS3M=iv>1y~X8$ckzM( zhxBqbIothwula-J!q|k?9v8W0^LW8Vt=G%)UyGcH{@1ePcggiVeW{_7pLEXuwC|3Z zp;zsds_mgWyJkMETH$-EbJ?ZhlgWp^u4s7BlJthl?rQL1_Kh6R<`#-?=R4T^RjD~A zz;lLxXrt6dUzJ505Ar`%-rsAvcj7^Z1#9FkIyL($mmavn`8Kj}!vD(~vTryvYd!uO zS;nAwHg1m8y^B>c4GPijXTmhpW-tjCuJz+zcu-Ac;-@8RJT)aAED+fupWv4%P!`^h zpS}7vLsNNP?kkO%?YBJF{3@}$?jL6H$S6ZVTw%pF^}lil)@WZ)cKPz@=IMuj^Y;qt z&D$+;@Bg>m4^RC%{qWK$(aqB~8a{cpR{G)ozkl8z5|6JHtoz9?-+G%ruU&SnILmb1 z(_A}tZ4^2eXDMzr&wBA@OY@%Tv5Y6q9-sa2Vqd-yW6teo${(*ethnkN&(z90L8NjD zo4}OVN&78x8>Dgtp9kAcxIIhvV^^clY<=sQ52gQH-v8qP*R8(Af&x$OI5OzGw`Tj2 zYjeEu>Z}vO5;5t_z03M7k4T+Xv|nP;ckIBjU$T{r&V|>4PaKxN<6pXVYU$l&g>TGf z-Ms#=Na5>jo2x3`JL7k4m;G{c5-W3B=>FyJRXQ*4-MaqPoZcXo8O}R?IJPeSI??#a z`FD%fm*ldt#PY3P`B22&sd1m5--U@&-drqF*qd>dG3C~=2@-j(fo;h>3%lMw^?dm( zeEQit&p*8X{`l{XJ3Y;vTOV`Gn@|hpEfX-^uE6b~{e<);ak~(P`bm?wvP;9Bk z+?CT8d;Hj(nfT76AotA6Kc>u0QSL`2bEWPuv^BW2%zbQ7a7}UPj0zv-jjTQoPoK7F zZP~2CXus@7i03~G=Lx)gKHOhfnRZ8UAFn!iAbZ1?_T&JIu1!mmW?c%o7ItXG(%gWB zB3axFyutlGyYKD(tYI@r^usfA{zG%~<+5TGcDKvFmY8`wjrUFYcHPLs4m`m}uIjh$ z<2B0)e|orWf~xF>@~>~aANI#p+sD||Yt}q3WjtuC-`c%;x^G+=i`M>qA4`AC{{K7w zki6ah+8;O1*Gs+2zqfg7^J?kU4|i@(Km3#X`C;$%`(@6>?-4jR*FJw*=RAfdf8DXVDs zEMjoBUJ+H>TiTlA@X%eP@Xdj&rKd&qFuLBp`X<#lZ1V0yg?1XpGJi&d^Utic*X6qr z#OWNhkwwkHW8R#1uN7+cC`R^8C}BzQ%ayt^f00Gi?#KGF+3mZJi*P6;Te8(94ZVu_T@pGS>BS{nX$3YZZFUK z+W9A2KKs{{rw$jgjIK8AyrrES_RG-lY}46>gk!Pd%@^lQ7nC`s%hhW9Xp`%gX^T}< zp1yzO>Hp1M{Mz%oN*UH&rW=@;HcF_OUP%-Pz4>PG7s1V!`B*lxeJlCH=}>TDUDDU8 z)%A9^#S(8#6?ubaB~?f(R6G}xcG-5gcRef1{%ay@)-?0K%YAuc#__si3l4~{b>Gc( z@#W&>EG!eHpDK4GALrStrSRkU`g--4X|5lt*YB6t%iSYzZhf4IVnX>R@%TE)f9v=E zv_Jg*|A*fnF3&Nh2zxOZf0hffz{B;cv_8$L!cHxjWZh#~EWo{!Z*AOET{ngP4M$50Jrepe6B!hr3+b)R zl8Sk+&d#w(Zqj!pW`)k=%#%eYq&0Iku}JgEy4_1J}&m? z7mfM|w%WZ4%R&!2vK1YjWq-`!!?oVuRkKfQJIA|6IzWq7<&_C{XUd6*ZPe1H6zsGrgeJqc(c6w>w zf@?o*>tz0YXt!_K|L^sFzWH^(GJl-(|F^qL`#aB{n7vh|d%j%qet2v3^+V~=@J3Phn%EGe^vSw3jYQyubE=C=cF3-QQ?s2ZK=Kab7eVZ5excPT~cg}Zz%^7+v zkKdtV>Cw5K?^Yy8bab;^b=_)GDZVk~x@)}d8tM9@l3&$B{c|LKck>2JDi4^|T5z?U zdDX@@7uO${`>jmqX?A;9c9ev`iO3cP_hm=V+pI5FG%j6pR;{jJ>pG_1C8;kJymzr% zoRgj)+otO~-Fm|cEyLZGCVVT_?p+zZ{KYjB_3uwjRTL@>62DYWR@ z`c1DVO?fmiE_TAgX^SeVK25c$n32+Av!uCm_My&`tJk0L-*WQ))-5MQ+l~2zC0gd3 zOuD&h=h`{X7aN@B&tIC_S-G>QAj-Asl=6+Cro^Rjg<>Saa0pRQ~RxTi7c$(k>p9#=@dsh82* zd}U&)bMrl+YXX|e>`g1gkBaJsuQI56>*@9L8XY+3Y(In@{K(&pZOr;y>P91NYcxDYno2&ezh&E z>E`vs!UMM~w-(OJ$hv<=|K4qr>^=)eL1CS-Mh*1 zR;}`BnymetwR5!|O*>TD`#LdLX5EY2U&c(?`CBgXhyLqul@)8t)=X5LcIi^?*T?NL zfA#Mc+WNiQ!r;grle*`tWb>qJ4(`(~c$a8NYIldb)Mhm-=5uCGt4nH|YVxh%kAz;p z8`;eIe-)39e_j7hO5o3@&Cw5kiAS}oEByGeaM^a{4yla4vJL{uQVjcrkLt^ZU=$56d@k#8v(a`l07gFm-YAwNjh2VK?sF;o1ND?fXOj|Hc33XFTYC z`2UZS{yt%0Th_gsTYiuG{=aM64@KwimHhXjo|Pj`RA7&g)hs<$4!avw0(mw&mYO#9 zA3AHjy+m%|DNTin=kpvMI5>nk2xLE;=I~(Jr(2W0PK-TuTV~o?ZEv9+zjpVAHdijI zI@;J~booMJbKDeG?$6av#4Wd2+&L{BxjBH%{n91lhd$nq*-mol+;hy|-8(g)^w|QP zdTle)Gm$OciLS?=>2RoQ$}5OGewKl4x@qbgo3MChkFNVZ`pK>-0dW^*IddgCZ%R#y z{5@S<`Ljg5b?2E^7Iv>zemgsBf8_Za`+WWDvltu=uX#RPkmA5;r9V-ve6OGF*8IfK zs-?L?3;{`K*`+(`O*j(ZWdSJRGq6V z2cPjvKeBl4>ci@Ly>LqP@1+s<4!gY!%D8;Lc6E>$^XlbYH>dL3%wMKlnzBe^dRt#s zxYZYzna@J9Yd{ce?pSX#!@4x-7JbLV7s@M7%yFdJDEwJ2|{o~Ho&52(hWl5B=@@h=DcGq}m ziHMC(T2*2TtCVWj7WwB3O9N-MB~(?k^1ojmIyF-J#Cktd?+ev;PR}{^CP*Pd>%xm| zlh$=QIc;HRU}O2pEvvxs=djX=C?lEtxWa@+R^A^jYhGHO_Ky7F=kj!MRpFlgsbc@S z4ei#xXjl2ZW!}2mZ%-*zxMwq&A5Q=O&v%F3YK8YQ?{b5sAH7(-IniTs*#ha0=W-hK zWY;YInxB1I`r(>o^_8nnWIvDRt^adOK6~?trys6m=W{D?U3j5>_;5S_;bwOJL;3%n zns4H$ThaH+^T$j7dZ}w$Pk%cz)A*tOzeoCqUa#LTcdz2}*$?Nc-?xd!*LdnP?N2$t zE^vJH%QBWvRkJ?TvYfbl^%}>kw<^)i#}l<}wwX`0xis5b?!66H`PO9LcwP;jR%Tc_TXR%DUub9gq8xbsF~UZP`BihRG%d zrQQ9asyg<|5AS>XA(!_kQ*XrMw;%GnJS#JfytrWbSxZ`vF>0OG)X)R(O1N47S=gR> z6s_(5x!=a1=|}1&@%Or`+|PUZo&8%EY8+>lHEYGgCwb2=J^A-olS7)%QMGvwVLd)&uPn!HWtdZ@4glA@MW~k(Tl4WrIrMK>545)H{h;cQxaFs zd+zKJb(=tw*XGH;TwXb=Oni5ed!NatITPAh-Q~6@wyJFnjQ$m}Z`+q??uzSUmWK3R z)Y85`K`HNL{5RF&C5Jbr)$SGB`hSJ|zMp^E%xvy)@Bj5e{?PtE+v~Zv@2}}{C~$7R zIq9BR!Mj^aFEBK%XJ856vN*7*{#3()-kBRMGYuS$Z(63v&{T8nYvNpm>T3+mTb^Yy zHbvA{F{m7vf1&nz+5berCwu4Vz1gQX!H-|JE_JTLrfpx3TJ7I-L!4ukxg^I$HGXw|GZe- zf2fsP{7~duv48)*?|<*`q1XJ-_PAB{HBA0i&S-+17G>{`t`S4=)lzqRzw&Fk}9*=O@_Ird?fZ0O;0kN*AH_Ud{4 zveYFRjG4@_tHUl82i^7^cpP`#^%FKSLxzIZU1Lu2>5(m-47S5|T+7acE`xa9phGtZBYeZutC zed~SKdY$FxS<)zP^6~s(mEDtOv-*BjxU96ne(_f8ukp-HUGpy)Ff=xpv>qw;xb(y* zr84r+tM7}xZ{4Lfuj{?S6q~b0pLjGzr_G<`5HL@$rt1Dzqbqw|YYzx{rEX}i-5(?` z$G$|WE;97>pKrdq1YcAwdbstyvu5q$HNTg|us;)fajX2jb-1#m@;9}!P7|cJw%hS4 ztk|9?DR3ov{l1@P8Xw&M|0w)n{Qq~`j|+3y=_~9|Q?L*a5b?4I6?0spa`L9Wt7fOF zEXQ`8VAkuUyk6X|zA!j4D85s0FnD_L+pON`wTpHzoz^l|6mwR6zv}6iziI+ceoV?) z#m<^>>Qx1!;}pwjs@E=*mPUN}x<2pKju~e^{Jvi&y6@kguotJRY+rcBcB(os9#o6n z$jEnP+NaeG3v{}pgf?tkCAqz%Xo10`aMbl6@mYrYbney z=lt`%vF*Fc>7W&llgrqc8g4VS%+fn1R1rPxK>MwUf7;jY=lK8eX8nu5$G#sDzrKG$ zYQTOKR)zL%z8k*BJ>mk5WMs}d?$U6beXn;Ji}2mHfR!w-PRXsA)Zu?;HcRLBXFCdR zELyi@y2x7X7aqZ(UK2yrt4$XQMTIoI)KzJ4bhy`bO^AtQqe317%ho=D)emNJ-`cQr zTgr07#4WG)G$`AjIQ>DZ@S);#MSzh|SM!i>5NGwWHJ z?v?*-=UcgK%16cH+xm(=+`Otk<$#6#rQ9jYQ{7DW-*(kldVlqr-%r1pG(PBSP?)i* zKBn=(=k+l>;xnb{eiv2z{+-|Ye7&vwHGfTkBYWn_F!RryVSM?9%cdon4?~$-q!wHW zoVn>xWW3+RsF;@vmhyRrb{gMJTeToor=cT~#k7Q(Wvi{CpD;7a$vZzEJ!ptOG0V;D zZ1CsRv3{u`*M3fAeQK=!?4sH?nY}y;93mxO60^2zU-tG zYIu0!!o(LL*6IDrnv_?3lytksuGh9X{aoAWs>LTHeFgWIJuF?zdu5~H`Bh%x{_y>OZ|}FQ-}g%kboTzkTU)c!{{B9_|Ig_U-)`qi3+!34 zIQg7i`L$&|XMc&`Y$%pZ{-v zfirvL|MT_#&1WmMxn+1C-+H2It@+HDJtY^fJzl#;_x0W5{W;S=ExRV2^pw@)+t+8p ziD}_)G-^*7E6q4F?^)c5D|_aCKgOU|8EAFV@ak-tu*j&M%&OV-VOmD(Za-jJmhwxy zo7?@|8is!slMAMPZQk^c^TXQQ6G|KcQ(DViO}@=bo*R4O;ngS15nGD6OZO|BRnF!PKsaq372AEX$71yxe&|VX(v_O*-F@JS(Y{yg zYI`f(ZW%gEu$#QX^2+@F%7?n?Pp7pv8%{1eecM^}d+BwbxZiPW=V+Dd{eP_VNVma%j1L6pWlp0H03&}+uh7~@Y|YAUkiEOv9WxOviw`v z!n5FlXg~jgKR--VSLDYl->~a%4w$7BdQG@-!L5$7@_V}X>0kJMH2iw1;FT*M_SY&J z|Bl_vap`1acH5ng&qTHu)-yQHU$nI4jZi$-dHZs`JwNVnKRk14=7(e4`7Q7F{HojW z<4)^`|C_(d-6@qx-&UsR-jpDus>V1)qbp>auJ_{t-P6gxZ+TCCx8|qw=lp%C=cW8N z*!DfnarK%ub%wFT#NvP7Hs4=YET!P_AYh5lrR5EFcVlB$YQL)sep{WfK806&OX^)8 ztIAJHRyGB&)PL-bU!onpZpq{0{mcLT`}gI;VgBXUMbR4hi+?KC=pS(^&Ix zg8LGl8CxS2_6 z?b9TO!1D6xKHI)5*?0W+9@Cic{N*_!eVv;$ZaU@GvZo5pJTJL%*7K?A)mppl!!CqO zIlVSkqHFP9P32rh(~#++3KHFoDvp2-VYg!}z72K^dAt8C7w0cdFF5w}_m1xP+K`?1U1n$rq_lC& zJoLi3%I`kgrOy2B7d$u4RccuO+A;T!apJ;?tb7k1*N%?IQ!19YJTdvg8P{@f7i0a! zc3B7eH9&-q znLx?ZmGc{>u6WF&n6Xv5;lYKBs^4d~AC;Q6>BL?I@_aXLqx zpKD8}>TMN<8)}n{-bNMNy3(X;mL__Qndsg9bN`iq5rEyJj8UB^_KOANXvlXD8zl`}^X;6PL69G2QS$$VpIUN5M^p z4`)6yG9FYs&Aw@;?WZ)KJ5y|P)V$mRWW_&-7IiQj+_ok6^R_Lk%foNo*{Nx}@pI>w zD~sDNZ_9ftuqiiumMF&@iTNI&n|)b1{yj6_?-{@zDACBpA@HZY{zp5Pz?-*kwqZdObL5B zLsX-*e#yTn{sH_UyLXk#?pzZ1|4MQDw?}fjE z%WOR)*jjq|>jGBe{rk0C5AdB@b8PmOzKceA6aOTXZ-4QLsWvuAy}X1~T5?s=@+UJA zP0hJNm^pY^eCI7>sZ#%?`Si;C?v?VVO^!Xjw0{1ycbb-oqWb$2US|IN^lv5OF{}Ao z%JRb4Ld#a)j;+1aZ?pM`sBEa-ul%0NI{L9JVgfB%5(*a+r}AfesLs2jaI`2sYjW=4 zEIr1TtG>^YPx@lPtHyLM$y9*Hj!896_Ws>_@_R2%?oPR8Y58Az^^<8E|2(WZEinI` z;?c^2hJ=rLuY4pqjM^9JFl9@0Etu-c&@@TV=GW`}3IZ+#S(CrHxkf%oa}e06ox&ph zY{7;PMO#hFDjlwfeb#Hc))XbnarD7-{$}5x@Rh+=7EN<1ToS6I>%<`Ne%J2PGq_i< zGo*+Ms-5|nx{;5&(y?XYOplDXde&m+^Jn9Cm;Zh`wJ^0PWZT9Cw=Y|!2V^)bZDbMH zqq25&fY{C%>rSpP=~7}isJ2ypvt`ubBgIiVLP_bfnwD0%9sa5)*?(_)a{Q~e_vY}~ z))?6C3|A72-J2PH{%~eaPRxRQjlKW>{eJoC>gs8NHNW3(Uu$EuAl8jf-foV8+TZj4 z|D0!Q%HVV6JtLyOrMdY2aenp{r|RyQ8!X89yeIBund7FW$H~br7cZ7y8vpOp^jnwS z#Z)~%A*k8yaXI?DwOPKGwfw!AWp8gzjr(;;{Bl~E+0C7%v9f#Bj7@}Jekx@=__FYA zgpvAYb0cr%Zy(mY(PUB*XPA_v&n)y;aRHaJ$^lcA0M;2vf;q7rsqJDbPno;k4SZ*m z!8GCQ?U??!#SA;^+?PHM)A=Q+zGD8l25;RNZ<3g#cU%>5tSw>uapalX=N-Zd8b1$- zZS0O_5!!8@x!Ri1<)NFb)Z|?mBC}<(dUj_R+8n$Rr*l&N%4zPxNXy^bJ~@l8-?iI@ zVYTGd_3xZ`B{)7gZaB14dB^#%y^H;S?ECUH_ms?Lfxm8l4;gmXO@5pd$Y?O*ckqw! zgYnY}*Y+t~o5IjE(a!Kh^G!X6xxcmREQQ&hG%wrr?1PDu%Nh=8;r8|!ZeP0A&AGhm z{#WLSM<6pz}#d-sP+Bl4h5T2SgeoaHS;fD_nU#)QL4}I;*m#7 zR`Uh2L~p&pz;=6!K<10tp*54s_7~q<{d|M<^i9EBHz)J3h+mR9wj|YwP2)lUTa$wD zsiJ;HNBvt&!Q3Y}x=d?!GO@5<+S(XcpShNoS_%b|1mT%9QuB*+MgkiZP8J=x@R-fwH!WNSm>Pj z|KH!F?5soS54d}ExMWhhkT$CW0%MqS&s z&K5UFc|IxfW|)g*>sywc&)(E6{I!v15u0;%>ncabtr0787&5f_%osQxeMny}@PxJU zo$G|}4;tqxs5yQW4tx>va9U)*)w35w+zv}5UuD=^Cb`-yJEGyjbq2?5ndBxnAG5o~ z&oZ*uJ=jtw{_SII&1p>kw)<3rP_OKD8P|KRiA)T?Pn+F4F00(Wa{l|>QY)AadU=b# zKfvz$vefH(!2M099nRLeCVI3UwRsTMVq|*3!Qi-3%tv(w&zKsfN3Hc6+Md3z>3;sM zzoo0X?ysY>#9fEv_0MEpy7(>X3V#&h&BnV?O#G)?oOEwEdz189O;gjej`0iri(D3{ z{lM0>;LPzoe}CCJ2)=pulJB!&b$LW&ihH8_hVU{L>+Pi(g}e$KvIoyMDM>JAJ{GNu zRy-}@$Q##h`}aw!-cRd^05vo-p~w`hM5yT%GGNGGaA8$8{VOFWr|>P(rM3_csNKg9mS({hcHmTb$bGCe%trd5sLvQ+2?GSs7h%={s&a6rKvF=38nI9Zw zEc)5$f{c!gM~05^_F4g~U=D&2l?whdo>V#d(mWFaE zElPTKZ~JwIlKYFRFQ1ODv;6Ai{PW@7{tW)dl7YXTUHUO)+g;~G7m*`{nsXPp7+KnD z3Y$)5>IlwsdcLqzFOJ5`cj*YTMAh!R~#8k+Lk#-y2z(8)iSugyB(l$ai^%OWFUuO z6z@@ko^bES`-KZM#EiQ%yV_%qik*~L_f&v?LB;7KPk32jX93J&|Dm^_!13uB{f%L3 zw*FmJy7AlRUGLMwnHd~?8M4l4Ijnl-XU{7h@@~hv4U;}Q&z;z+z25oAnq$|dZaT4G zBA-m+!uz4lX&cF3{;GmW2>1l^ojwAz^SpI2|c+uw=v-CECE#^3#6 z`JC5!m1q6a?=jkWKPzQ9)`dD}|K8cZ^W}qfcu-6?VD7zl8E@UbHSG*FG6+|{K}HrWs|3HV}nYrZ6kwg(Cw^)*L%+X{&{_h zb`IC6eX-H*x3(s4U)gZmJlDIu+*Wh(rRw1ACLPtct1gMo?6oZa==AI7`T9JCj%5Z? zhl^(v3ZAI`cvSrI;#*PgKpo29`uh4?d#krM&RHHV#&!Nx$ii0wm##~lJEHM(w#Q2O zOS0mo0@F;c9H0O9%kr0pTDk9CT@pTJ|GIU0noDH@_Wcfu|G)Spx7Ojbld790b6&C8 zzu4hi&yCX>oo9UfGt-6NCK#D6O1^V^$GPzK^-&X3Dw0fkJE|;n4J<5I@10d?el-8W zI>DRY5+z@-7%XWoII{cWzMC5xlID5*w|g@`-iZCu%o|~UIvBDRKT;Gllw4eWU0!?9 zzrAlncTe8JDNya7+-P%K^$MT5#?+GX%=gKGA|I3IC$HG>*7lc1K$72Tm$i+zgqC(} zdRE?$6|-9Vy8qh3*AL%2@!q-6V)*S-MNe6OjcweO{TA)roDp%Ymv3C1%HN-Er;ucJ zQjsBV$y1-#(^zJiH&yUX>3KP!EJh?{HKX#r+ z=Wn%Vdo^5_W=QWWFnZc>>UY}9hK=u+Ev`G!RP6h%ZTgPVH@Bv`hA5kgby?o6br3YJ zZFs56e6add&6#*@0iMTOvhMJ(Ts@)ov`dNE)F-=7#LXpD;CE+jhP;S^MyJ7FP8Uv& zuvC_CCP)5-OdL_(J`Nj>85X<_tk}H#R7$OaM%O%zE1Pe5<)yXFb#1%!)?MtJ6Sw%@%FSzy---#;6rC5&j6NT>v5kMJdv*D8Un9M{m$zy1c5qdEJ5(9? zv@T7d;}VBX(gCSHSyuza&)@6+e`jmy&!|t-sEP|K`J}R7Gh;3zOLAdB3G3xgi#?eH zjx2H9IYC=SPR`4@`TFIFSfcg(+deNnvCvP%yX_gQ$!%)j5~ z=wX{E_pD2OO2>t(`=>oMyL-1y+qLVo$7Ri_^9t*?H$KRnV%PO@*S(52`&9(y>=)oX1D#iEw?S5AZQ}6d3dc$A)>`$tr!R8z zAx&-eHQ_fxPCWmZcSSWpu;JPRt?NpQo*(o(*8e)6ZbF`63`J# z5%ZrG(^_JmA}IP=;-~;)AcO3h_%o*#q%djkbX6<8)AD&dT*osM%#X2N z|JiSJOkTmD?ElJwWQN(6OMK=$-7WA)A@Sr^{Zb2;iD!SQi#Go`rMF7+&!3#9kF5lB z!mn9fcVsP7UB7@MY}*Xy>>W2EpUk_JlxNJgRGz>2l7EM3PtSs>t`h{8+&^y+cxmD4 zxm9y_eMr_nBF!1ma*}yzn}(G0>Z&(Z6IXwmkg-B(oda9=w4)ae9q41M6gMLe!xkK8NIp z_g>L@oDEN2+o%gn{oXkxJNIo&gVcG~G(9uR)h~25%;PBSws%lzSfCLWY^A2ET=8>P z8S-w0vx69Zl=%o-Cg$9tN!=)`fOvP z9Lw#~w3%B)|AxF@e*KH1^qF%WE1lW9G~T3rdM2IUrTf>I`5?ErUYAgX#@jnPjcb2; z$D6Shoxf)r6j15oHp|*aQz!UkktM@E?(WZ40bGIn5B`Ss=cFJ1y2ruvK$TlVenrWR zpH7lCmK7$kd&{mid^vSOlzAyz<61V!>TQDQW)H+JESm3-m={)iDf!2QMKUwqpUlyZ zIHOZ#qLet{@{yY0#bQ??k~6ih9$nSxq$#?7VT6rvo7=Pt$=;7IACPjse9qs2-#00i zSzzMcC3Du!E^)98skGWm%C#8L9Ui8>aGVJT^tz2Q9>)J1_`RIM)>i3)ZTkVt8 z+s{2O(vn@qA-2)vUQMd8d4K?GyKkwA=rO*4Nd__6OSn#Cbk}i}Op6c9e`R)}xI@t2@%Hr#jYs9baQP?PQEa1nqOPB8mox5OX|6%5oPqVf@ zI=E_fh3d1FOefY?)oqTxez59qMrg{mXJ6NO%!+=nE@1nT!)mPEMu+UpE%ghRIZ95E z^UnYCZ*9q!>+0_nt(%ydtha3TU^sXq@`yG21&+;GQky%9n%7i)o_!}TVa}QkPxjcm zykRU6kC)wvyk1e$9A3HSdAsC|#C*TiGsK0(IBs-kbeCjqXI;S=v)w4<#oAx-j4WFn zDlbm>pU%i4es$v?_d1@cxsnIIM6x~DeXbE z4EDB9vE?FjY)-CtVIZn-Li&{@gHkZda~7s_h9>6gsju^+ZXLdrl~-^n>Tvh1`I=Lt zuZZa~)w=$?8C>F+c_uqRZ>8_<+q*9%TYq1A-u{=*t((jOHdD5hy%$)J5xzr3wb%IN zlg{LOVSLj*L^3*WX)+XSwo!PNyg~WLtJUkJ7UbUCwDeilDTRrgWmQ$Tu9$y%RPngi zJjaf$OX2wE^Y-um?E7_fy%a|fTZ)LL@TTT$M#oG1AJiKbXTQtzU(tW1d;6Nn@|zl+ zlRV@1sqF3%R(|>TbiJ7CmpwTWd`r4FdEZd!jf>cL_7-o;Mny-}o54bNou+de-Qrz6 zH849>*0#O3`8Xsl;a8_JW zf8m+W7OC|N&JBzDw&_jrzH!xM5yM^CRoXmZ+n24&+qP%&jrJ+NyR5BwJ}~y2Ub{+t zZO*$+9)`c}b3f{?k)CSZ&vtLF(4xd#VVf$4h`*;_x}OhSz_Gqa@ZQTTnP)qfarm@I z%l^Fma*pv{!;rhn1&lBH&wY0}_M&FK2#?LCIEPV0i$pYu?In^sCHZQiWb`k$v{X}{GqWQwj8;!5W z+=!2z*gJ0>Q8{(m&MV8ojdrgkAW_z6bG~0!#e9{Brew z)Z}-9=|Drk;%vc#H`bbpnN}=dDC<(Xp{3AaFLKDO)Ti9-y6W9oC+ayBR+KNa)ZG5x zgmZ-fk3-6nX%~d9$zQP#W?A~Lc0cpMo1U6ZFS@lF7W8OzD`hCm&}_@bmNY-KM*b z8dbj0?l~!;QKG;9Pf?T9jmwvl9URSXtoUpZlF)GT$BrqMDYMuvunW|DK5H(_w&r3) zo70b-=WEX~h;TiLdz;zgqa@;~F(rWY^N+MM=>Z%sK83HePTv|*BX(oueTLiwPkw&> zXvwsc8kN1}e>|*8f2CN}zT0x(L8WBPJCC`0jbi>@5PQp^q!m>@TeGQTk7aIpyV`cg zUowAv{`w_1<-YrIp+NG*ggl|z2!XJlU6-Q^zr;TK86$6VVsd_uju=mZf`d2X+Zp#y zeQ(|F&*1!4uk8l7bwfIZq0O?iR-@X{W(`*nw*>ap2`)W{x4chcX+u6c0cvw zV4j*S@73SRaG||NFvNk`QFFq9Pg$a`Gh-DZURwwJyA|jBNlWmk!h}t~`Q@YzH#>HO zC>RK=6yyBYt-D9zn?WDz)WdJqg*Izi?Q7P&m;PYUrN6(_ti&Uqb!rB)Fj^LWz9o_G zC9;K6vwO`lj(c1jSqV}cM#7m7?_aq$SFS$7VFQ2HgKs4T&nMq1-Vy%xwocf~N&C+D zEm=IjX3D?6_y6BLz|))9Aim)J%jNU83BHuIE|XZ0dr!xZEAZ)rxvP(+1~jjne(~Z( z6BCmu=jK>G{&TPD_1Z7LUayyC`NX4}y6?}8+cSzBdRaOSU1H%$WB;(|{G&(C0q?zk z?^^HDzOp9c)wJbTG%J%es#8)d_I`eNo9W>3OCN*PxAflsxux>=vn{pH`@XzrwA&o9 zds`W|LFSxQcNv#&Jky>EH_=oeKvL8eCsmHQ_`I2b+wY3aQU&4Mmow*Rd z;|@PFQ<3;yzw}3<wp1b(+js@|%ZT9u({1BD+U=b$KAvn=}$wB?2 zddvrtzI*=^e`&ciOXm{TYJnq1j?Ud|sBUGsB^ zpI}IAjhaKj+G{&nvLY7u;OU15fnMNj;+Us-F1R1&$JD@RhIA^ znjF!oG-J2+J?YY|C1#g&m>v6-Le1_s7;>?GO3~SMO6JwQt4Y*^G`icAbbili5AblJgc@cEqvCN2T@^C4QJD;&^Y{P8JsFEeE7I>@LmU zmvHSvS-#=*n|Buf%D%=YTWoZ*NT>GG$9A@+>+9pqxAIgsYP8n;`#k@-9S)TjH_phebF5!FZ>Ui>r)#E*3_mA55D<5NjeEqS+Q6YzUr|$MtN?v7OATZ5f zvg!G#qgriNH`Jsj-_Xrr)#z$^@we}zx?ExDce^`|CNJxU{vE>~~z9x#>tx$?AZw>HHzQPvTr}voBbEs#pAV)BWjj z-tnw#VJmAJj;L7~_+1a3R#4%XlaVJfJM!b4eVddm{+`+Sva+Z7#O@iF{@MfuM6{lC zKDc0t$tUMnLv>S+b+gS6&fjpc|7-X1Shn>`mK!XxQu;O}Hg!#Ezv;QDh1-v9o?UrW z==jt635^Su#a#_v>Y5jpKL6DGb3yOqq&?S6b5q)DB(P>l{ymX=ajEDQ#aMl%SFdJE zO*Flfq$F^oZP`ODg%|Tye>k#y+7GAISFiq(n_+igrqT)@OJknB6&qfd9byr&4dA}e zq+!nBXxO369b9=~%KFn!3yNLL%HMCFVQTYZ<(@-RHJfsh+a{*nn8Dx}%%ZQTY@w=P zG38kMGM&Y3n>e~nYco#fuw8F!e6Z-2Pf)_GSvn057#R4Mojk@53)sI7X?bLMK#vYD!ZtapW7=ZZ}g zxVEt?RC77&UemG#`z|(ref(j{>V|4-H0vmQSZ|96G^VRDOA zTiq-c9?>K2yPvSmW_^}CKlx;{*UFS&|K)E)PK7OWOq5ugc6_p0!-7}-uE8t4o?bZQ zA~$8{BOQ;UbDgpp7v$_)oU`k}w9VWHcRsmOUHnP)e{|d@yNQoR3K1*&Z}0k{)9@gRd4Gu;vtm@hW|QwF87H0x9KM-e5xkh?jJAWo zwStSCj1x+N+<%ogT*$l#pbHlyP`fk-`O$GyuN z6OJ$Ya%A1#mq(d6?DqXNY|Xqnt?M+CtMbbuor{^Asd6=jLu!%+zR-ul+Ld#^vQ}U6@{rf9NdY za1dCfQn`4?COH8W{=TBwQH{+_tM+WjTE1k3kwJmy&$(XBi|Y1$ZZE%dd=ZD7sB3{w z&dcNcavtYxzWe;TR=#iQw)Z#YmA$_kyP?fA#w3{EpZ`?H*Al6a8=SYbr$o-`Gzc`d z(-pSw4nCLe_gn6K$FGiOMr`Yu1y;Ftt@5}%qv)hX(0$(1hC9`}n=~ZvUT}G~vwh{g zPK(0x`9EbVpR1-U>iTz?!L-j_V@cm3{ZCU2%PhBgePlDZfAON;G(+p@TfEz%9>*26 ztu+d6p0C-yNbgYEHlB@kTtDA2h!nkl@`6p~)a{$hX14Pg{Jt&-N$Z;QoAG+~?oh#N zd?DZeYOiJd&Zq0Kx|*|=?>s~6zSUO*5|fu+F8Yh^iw(-%CZljR-?lU~LOEt?p=z1x9Sw4POqS1q+ zT;lH|J{^eP?#O=D^7)1BcGI6vi*D~xvbnG((RXd&0hi8{K6`C*RqU#_ zWTO1z3GL2-sX@2T&9$y~47rf}^4HbZFaK`8=YQO#*GAFo>yaleRY6^b8M^h)xBj19 zCc*K}kb7#)j}=lgr7ww$sVs;*4eIUX#BKJ&&X!ow<$?~+R{ZM z7V?IF6cz}%%d%SLyu`|N+Mh1euKqUv*q5GM!LGmED`$qKaHlS7+dEiw zmE|_L>*lXIea7jTl$gm^?$*VgpIxtrN**#^znw;)wul{u{^wF!hn_}Dh99X3)uUre*Y9hpX!d2_IvitAV zpN}+5=&xGztSFdexAX;*DV)7crgIt>ct`!2(Y5f$m7vq<4GYAQd_Nvo^mwPlngung zD|s?_&mZ1%*=ZAtfJpTY9e>BzHP7vuuNz#QI`zWWd=`PFpX~NbNO>Btg5dzei3J?9 zOm(b%CNnjK^RlG#uuPwxm%=N&pNBJOOS)a2@ zFQ@ByWIkSU_V|YD1`fPp+HY>|+h=#1uSJN%!P)P9*^NU}H2p&Yq$l#Wi2iA}|D&il zx#H0g&dsfr={F7pu$+{Zblft1qPLEA=LEUFqO=5$nBcA6!t%w7BM-mQX>kr@`S$tb z{p-RT1u8arOFK<3?ukAYZy#&X*yPKmOJk~^=yq_49 zndSMwFJ!Oh#wKyrcVeZs%CF>e626(YX>n-COuhK(V`pJ7>-wzyk7wS@476F!qTs&g zGUso(^V;*On`Z3|WH|jMTw`s68rS|qJCCpbpx>VOvP*S+)OEqV9`28q*swbkemS)4 zALG&qIjs+4*oxUyf;)CfX|(9-PLiBfqi8*gLBde%-pbr}0WORNo8HPgY?O>{XK-EK zE;%!3=H2ICx9Ry!dD#{o()ik;z;*HU{IIJH)qU5R7KN{8D%_}d;q{`~AGt+!-`$n| ztDrEaG0e|H(U_wu#B&p+90^b5HDnVFa6utUnq>1%?O zL%w#oMXTHN+jA?-*yt9iFm2PXvsVtTc9?KMWE<K^h>^S*t3 zY^6E+9?83%U?iY=!cdlQbzVBmienhdj0*6NP+=ywHiyO^9 z9Bw(vD8RyUh>xv;&#Ulp&zAO$x*g0pX$mL&)Mo0&gbAIznajfQX=Vd6N0M_v$WM9u zGMl~nKaXSwD6_KMeEj3mQ^u+54}NMq;a(Rmb$Uu_e+mm@)3PQ`j&r*0jjt>N#ed$2 zxMryDV4?rPOm*7F9X%n7CnWuJ)SRf`UlG{0%2+@~PF_!=^A@Y?v2~jA^=7Uw)^+MA zzkD`NFn=~<{>}Y0YbUO5IC3&U`%!3JIHRM!>nZ+IY}_KkjBaaeFI?qyj<(S5=HThF zm2oh5;%pe$tfR=Vm-neirns|iOO?c$#WSL-gkChgHdat{+b^z?_K|RL_WiHm+!K3r|GM+r^oBnu~ zU)r?|TiR~BvNkB)ICV(hCiKk9i}s?scvuXrVppF|y^*n}l}jMxx&8-Ptv^eW6*_ni zHmUL)Rdcz)%<{x0iRbBdzWbt21qAlpewXH85Rnzwzro|?xtu76f-r{yw-CoO$5Rw6 zEOlC08XrUlvK(HpWrc&#m-7xEmL9iXF6*lD{o2=pU0O>gZ=Bfq<>K+gp z`;^x~qp0D=hu81luRrnf;q+e1aJ9u!TBqMG+2&;Y<1oMdmZlTy>%Ok;^0lADl#pb` zCeYQRka{3Z@y&}j9_r8I*_vY9?c;8?%~Kbhxo!Tmwl5z(bbR{n@LO7b;;~PunLPCw zylJPd-o2SRyYsy5_n2ST?$-r76wG$mpwT47>{BvrJL}%lNAJ85JJNl1$hgCTSeHIp$q-?DO(np)-DMW?#-` z^X|%gi|Qq>mE891U_Kh!_~Or{n%fntZ35yv?=)G&eeGDU9CK#>zN=M-W)_4!d9X{! z?|O~HOS?~MJhtXD4(=+sUna4x+rCn)P^8;%+mU%E3uU)4mmbeG%sl!-f!#q>aiMlt zMDjPq^|P&?J~WzqEVhJ+xl|$I%KF)>uLPO}z1{9Cc*kScQ-cJxF4kiUwWscO*|+TQ z&Og6cIg;#_E#_fy{Nr_4_Ws0wLJkI6(~a)%a3r}%Y4z%GtlDzI^W(Rlx}~90V&{o& zPg30J-nc-siJ8^4Ai*Q&ZZxx_#tv?y1=|@cv>F~fto2_qU5=R}&)fQT`I1KC@Jk;q z%wV{A+~`e>-?NZ&(P8{z+94J>KNhMq&5<)>S@`FG*trFY!7H>xcb;SY$dJ9E>7rQO z`@P@y%sz4AM8{u->L-j0HBYC8*Rh{eyRAp&Gdbm0=sfwZ~M~mL}@O2 z@{(Iq&+JmqJus6|DK)sVY1VF)0`v5vQ*N^6F5O;n^7iesC!akyGUdR+CtQq8%1o`7 zlO*|j`8!It{~>O>f)dC?w@^p`R8=5fGg!+;u*qpk}B5sg|n32E__?HcwLgm z)8otLJo$JjfotnDIYx^!=NaD3vOc0EcA(kn)~%Cq$C9Qi+iPSkOyy=}yUog#TjsV% zb?w|;VjV40b5^Z75I_5uvb=4>NuS;|0bv@m6HAwRypB8ad%g4;xd)6Z8G9=VgH}0A z&^xn&L-%Ke=f$O3`KM>ZURjj*Ir-_ob=m##zmMKv>?zE?#B_VV=t_&2Cqcg3BZN1z z%lrRZF{%CZV(Ig|PZqWO5p+-7Q6|y5bm@-+Pw&n9!?DIlPO0aan0V8chDNFGG+6;T zd!?{g)46Y!+pJpC_NMar`R}3vQ)+gLi*mXgk2`$(vh%&9cMadA-rc#EnONiz%e#5j zm8(pDu0C3HF{{HdeWjv>V>a*k2@iB%m>enX`=+t7UhWoCawV?j!T%CImGn6CO!@0m-(}$EIhVU zckQpc4_C*qrAJ@Uj+D3~!oN|T!?hqwO{0meNu051lHeK!$EmfNPj*ynO!bWkSUP9g z2mJ=V)Rtw>u3fo&b@IGB-z%yFyB?^$-FSDG?Of|RL*7_<&-$wG=PxbVt8wkc(GoYE zD6z07UnZPC9K+)zoM_ajEChUcl|Ne+o4W3Tdizox!p0JsLb-ix4YHG zSi8ZZCX`E6_~oao-Y-9G)n2Bs>GsJJcV_S|`uw+lrsRPc1|h8rCO%i)zD-^BP)6aI z$02ok(hPp#H=kOCqJ|zp(0wUz-Y>F1^M ze=iS8yLXh`?q{WD9A5^*#LKEO7iC)i$pl88(Owy@rZKO5bD?WmD24)ODGd!}nN>Amur!_PN`?CsJP zJ*QunJV(Z4-VuFA=>-0)KZ^{u>1-4`-#N=ZE%LYt|2gk1nE^)clHZvAY2SWXeZSSj zHg>m5GcP|EiB=B2y8pyG6^lu_fq8GA&$r%qbdFJy_fo$V+_P4gy}vi9Or}D^_REuV zUyfYo=a9(rn;UH%A`v+0h3RJxv5;kpvm&qUJk`6=Z^P|6AK8UF0=pMCuPeA>&doUQ zVs?$M`|>{=tIJNe39U(NP`Gv2*Q@1&;BmpLVNCM7mP~U}5dAMDvpJtPug;U%;c4>T z6V)4UWqc7T3Y#RLbK_tDBjd*@+qTJMX`G4W=weF`DR@)Y_;ZHjMx*p)NAs?nQ@Xyy zG$(c9XQr0J#Y~}D!dE#R4t~sWpLi{R{o>}-qwQALZe5vXR$99J__sIy^R0jE+_E-3 z`qs5QrgQ&XK50^sYOq&*?M>}){pG8h!+mEmKX7FHvwQz2Tb{0 zwQn6m@1nX-wwX*57EIgN|8f4mFY3$(=l}on{9ds{eHkAk&!)Mu(PuU;=5Ux$b620$ z<65!hewn_CC1)i+Fbc4AY?^!becgBK_~c`46%8?`K3oa*zuETa`u=~V*|_FE?l zad~NL7|l#t``YsB_07!bmp}GT~WX zarow0Q|GPg42@Q=k_xzeTW;YqbKm`WpHn0DS?!tK#KxU0etcWSy`Z4$%MxDM@e3U5 zbni(^xskx2q@mGce*RL-sx!U6PMpfs)sJ_-&A_qn)52OAd7hZ^udDv#GPUQ*8u>O0 z7HQ7RIBmD0!ah^6EgQo=-sQ?5BRP-uvJR?ZcB}f zk^Gz5;A!*hn#AOvYyL%V=$F(MdbUDE{!Myb ziDAMcP0we{#-BW98=h{^S!byF?d3PAFviyo7rsjBy0aEXhZtQqS*Kpwkg(Wn?ev5{ zds$e-6$-1TEmLRn>A&mD(#6np?LbP<^(D3POpaoCQmtkVyRSL~#D|<<_ge_sSJ8aw zR`!o;4ilEn(buWHm?f~StHqA;GDvY-b0@Jyr*m9cpO{v4bK<$T7KN3jx=x7!@2{-MGFYzvyqG!t@`DcvzZ{CX zmY<*Jcm3waC!dy@m{{gqGmz=ImutH+T<7&!>#DyCdmbEKvZ704${CM!6ZjS0D4+At zNviYPv@uKhiL>nm(~ubvZ@W0>6!MjdbS3Zzm+xYT+!bS#(d9X#f~}>*=NZq;y(dcp z>@JIcVw9er-F(Qm_0EDnR$X&_Zk4)iT;dvXSd1}7qbD~>*Zify@5u8EEg_|g8#b(5 z$kfTU{#(!Wlly&F1+#|!O#1jyRU-WTYA$`5^A*M6O`lIXTge&70TLt85%DJZ6^vwdvQk|0Zz~elee= z-T#DbJHL6qoM_*MCjx~^`syp?nH?`}o@w4I&wF5}N!(;~i}VrSxD z%PvflQi#y#?wQ)KAnXN~>jcBdg&a&Qt``LbVlG`=^|ytwssC-Qj&1#epIb^VU)!>C zp?d9?bH|yQu3y@{zy7>JK~B+?E5;0h3wU~C&jmbXP-$4|&&+a>Yn}+V*kwaWj(@+d z?>7@*F;VF6IO~w}qwvGm?@uQC*JUYis0z9N4CHWh{xN<3pH!v%70oAfoQ@vyON@`7 zuQ@4zb^n*8`jQOHY@1I%P`{u5MJ9d+4vryb7FbE7RGnki-1fxkM7pa;g76t3=`%S=fq$7q zvcebXJz-w>qqS2qKeN5fu&8wr$2KO0qe{nAc&|A5oZoW7hxg@#ee+N6=PX#EdST8s zpLqqDt}m}fEPo=Rf7^G-n>*DHwGRcJtKobQ!^raWfPc4@LjH0`rX`DiE0rw?{J-}4 z0ofIeQH=^YiM=x4k7v~{%YSvgc1o*4Ro1s`!HOqR?sXT>o9=sY{m0Jp;g2_#wVcVD z%KTU{yr=QihwkS~jz=gQVTX!>g?%W4GAn{v?lNru?7Z~8 zx5I@3AKrU!&Ntq!T-tpszQ{z^!FjTpwute%4hm!QO^Cparvl?$DPDoeii17?}4}Vpi5?}T0WBTQ3>vUHp z?^CY*an0Sxwb)el=V8IqE6<*q!Wnf?=ETc`Qb+3)ta}u8mm4cc2zzdoHEvk(tHn~r zAz_uL zUdYA7!nmTr_EU2G(`I&lDV|UFcG?w5ZJn|(Cam=QD(yJt1!d3vWCp9;uX^tL_UoU* zU8~l<*IVh+9ITwi{Jy#*|JMH>$uBoD{|^5D`0u^X5;G4wYEHiqws6}PX<6CLYY$Dl z`Pxc3de;oKr5#Sc-h|8Q+)FBIvpUgoZcVJko-WgcoBnIPm%jhcQY8JW&Qi(1)gP5v z-U`2r(ukY4PP^Cr*RrQvtbZ7m>M}jq(8^f*_AP^JnYrL?iB{noCoj3>ZGM;)n7RAV zJk2#JE81rUaVV5*vK4ia_H*+}ik$+$6mmU|sRH*a&=x4UI&U(Qr@BTL-#@1~W-)O3%@Z+0w z{?h(BRsorno7-Z8w|{iDy?(1Q??l_p^TM{BJ7?a#kr#LOewUKR`Hqtz+-nv|acIpv z&%z;=YI@aQMeKzZ_pR%q+h(kH)qMEoUi5_JPYcgmy)tCx;hGtFIHtNkN;gZRmw{!u zq5R@T6GN-1dh_>BJI2n~#8qLeu)>|kVc)Tg^L^L)wxl0__vOet=9SC$s&75FW!Yl) zzGbhcyY^Q7KA+@zdc#I5u{Du54lpeG|GEBOf8-GclNBvGZ+7mPvsnH@>#Fw~ubCzq z_Vm`sIZTLk*|h0|{L&4Kuf=pz8^m=o8x$O-Y+7Kz#Grb2t3$+2nJdv{JLf$8^nqua zf%U9EKaSg*g$g8e@F-64h`89!FTbwA(dUGND$5dvRR!5o5At9887O+A@LNan8;!G< z)BU7-{(bD%vatCQ!}J>sD~b*?H8H%{ z_;RC(lB;x%DBro5tqZftmd>0KDfMbTiOC2@rKsO((#Y0iUPVYSj6 ztL9|I9)GZf!#eVO-qTN?ErjEKzHH!HzAoaTL!QV|fy>4kGZTv1vNhVj>^IvuDR;}R z*|9kcjfuwtVjcfFp48CeOy9Qsv_xE>iP4ddeKF5(KjJwmeEj66)`lB0C;V60PyMyB z>gxJerUmX<3nZFMmx$Khyle5j@c6Oz^g5xJ3lAuU-&{2*n%S{ey7lzmyB98e*6W?^;}cYuBQ_cMBF<#8qg_6`TJ_DVVM4nhh(5S6D$k}s->NP4lc@9x>Mb<1*D+uN7#<^B#z_jb>km*b^= z-+pG>I=D@s!gWZ_WQ*RLN2O?@#6C zW%WM}%g<8kU^8s!S^N2f^apkh)&@oO8NRn_vJ_Tq(x{gA`NyLeF?o64d=rbmZ`aqS zPPSq=xNxE4%T>BvwYMhCtN4^q_3UPP%rxioGS|u)Z^^nk6qMu~sZ9=AmgeT>o-^au zsV}NGwWh=#YOR#qdQ9)(9N%j`-euE1GX1V_tD80JXxOs#E{$RjqIa)nxsfaMAiX~^ zSpLpdn^!SqJKpS+{WP=cT<*N{KT?lZ-`3Rq^ySOKjc1%L>$pnXI3UYlpDCvtzhmX@ z;|>B1H!g}Y2pZhzvRTNGF!_MNr`CnOXPHEdn!fn|>N4)QD4%-u(371Ff4HYNChXJS z@BP!t{`}kd?_WQ!;=R);wL+Am>Fqo4tP~c3 zFYAR*ze%?*<4AvHc;rTd){5B@!AC!*y^Wr)*>rP?n0x}a@url8mdpwjq6!?@Kfac; zvh*)I$Uf8b&8#&K)7N@F54(7`(S_Y z#(k^wnGeQnFj}xMPRk*n``4eIoJ*d5A5OI%G%+-rsW*4;EVuR9>mNolI4)l+V@rmzJq%)_R;vNz5>ewJOx~J+a`+ftjb7Y@!;fclq!#Pf=9zW?vqQ%5_&$P;#Z)!(0)$!x&Gz&0mE zVZy-z%k{l6(dCOdJgz^XSY^7G5*>%Lw7@^Jn=f9GarA?6ugva?+~MY_M7 zbZ$RuR3FCh^@DLcOVcb@#`Z_%sa_VlXD3X*kn?C}_A;KN1ywFaEoQ;W!luba{>Iv> z{NHTl=FaS>o#47~?qmM?4?kOSJ9xoKhX4m{F>br<9E#eteBF7CQrY9TU*{PVb6ZE^r!4UT)cPf-Fo*MXXUv*)!ttYj`KEbs_uNXKsdU! zi`jbT&FF`kJ+~&V{U9(kBUt8rp3;Vy_8azaXytc3>A$h4-(}^K)Ac9MzhAb9NvZg^ z@V0laObeE0EogdaHbX(7!18pPr4rwJ zSLg7vX-6KOc2Qv`&!I_07QKc~u6jm4=2kdiY^U-(eX2!qcf*5HP3u{ve|`yWZ0onb zvF4#yZ~lj*uP(bLX6*cBE_5w1<3&-zUE|fa`#mH3;?3v1Gt`J>ZTcm2J-lpknqRw$ zT;Z2^2R;8a&yH9vm8vuG%)i3OAl`LXY>kAHz=@u}my)>M}Optg~uC!)?}^bF>>C+%RoeaPQWd#9PkXF^+;yT(^|WR=sd!L2K7x z#mOFLH*aFLSTAd~?o`J|%eVEb_jb4I_n+G0o_=f7*6SjMKF1v-tAD**es+`VWV2>N zu_K?hvhVwJj$8Hor=(NH+b5pzU~t$rsacepgN0|)ZjR`)g6%f@exA(-&87z{X)<52 zh&X1mf2Q)^t;Yg(@@xoTY|hX*EXKz1?}@s-=Z2+>%Qw`0e}8{IXeH4$lQ$VFngduF z8yR{&{l2?KXZxq^iTQ3bUa9#1oAUB8|CaL`4`_;<>Q70LK5(Y)_-(mcY6<&1*SuPO z`SKzTyT4~Hzq}CaAGMIlO#h0VTHU&vyZE#oJaKwc$YWiRQsgu1=q;y!DF+iZ8IRsO zuAEtrbY+UmAN6N0wl0q=;zY_AokVl5US@xv@-uqt?%(U|xK6(dEA^K)kt$^U zpp_<|x@O80JDnv9^j>t%k|++*QOwEaoWXozYnK*>w1iiJc3Me-F!!I*MU87JSBC05 z{dUg4U6@Pr;eE9%t&g)Jr%Y*^RD9R?se!$L-3;R&<@Qhe#Lv7xS$#R|>GZYnpyt_i zhk4v)v(~gvKGqvs_$lGg;-d4sw&qpui<;H`oQgfO)Nc_($&v1*J6^nHD&U!P=ljm2 zIc{B6#+EP6sUQ7nEpo;Ee7@9lx$9oZkq#Gl*x$-o&1ife{eGGMzwkRN8ZZ8Kb~Cuq zzwR*a|23wD_q2-EKFptb?d&|!&v{=BW!*NgledqLpX#y&3K?1ekE?#w=7=q-m?K!`5Udmr#GP^ylvBGVk{a zDsX(@Fjin{lJXH%u$ZLTw1|U~Lr*tj;^n5}D|DD0eY`i@DzIn&{l0+*z_ulNj0N6uxa-zvr~W zN}fYI*ghmIV>Q!R7G$O>tbn z*4N)}ZU5;=-NV`W`!XN6$_4zdh<_rS=cd9=VZ>*b{!*YxEkYc<#W zw(RY<+^gJR&1=7; z*QFeCAhp)EV$P~QW9zQ<|L*L2`hER2#>Zzj%Jj)9>zV~NrEe7{w)Z|yymZw)da~W2 zuKliz4h;`J`7~=ZEz~J`()<0=#s5?PUa=BbqI5V^{lc5#=jXp`36w0q_u%y<%jeV7 zSy)*AY$bLV3AnM06hF3)H#^LOpuT)lqhe_r= z4G3_IWbJygG5Po$bE(5qm~XnS=s&^y>0G3qk#_%+?`rmZ4zJ(taJ~6^ao&O=!`MY9 zn%#cvcE9I+++W83{{Mg9W6e(8ysMfz_c(ut?*3SX4-*_-O@7(g?7!sS-@nT^F13e< zSjX*MkehkvYDIuO)0V2|LYa;J-C8HkscJCy`g$LZSWpmm#YLmZ`SRgqB1wPc!;BxU z>pvB?^a;=M=T650T&Fg1g;@RD9x{D$|D+ z(cconCN2E8TeIvp>Q9?3E;8Rv_nT4rR^GmSQ%)!Hd&P>_Ot=5@djD6cA74xZj0Hlb zRpx{g_wRfCTUx%$fk7bTy{@gY8-ru7J%4gl`MVculq+K%Ew9wRFXWZX#u0f`RO!-- z!xJ~2viQWl{z!iUufF#hO^v4BMI2fAzaJK!G>@Z35I=V<~*8(1~1Lti6JUi~i zMv8o``))6AMM6|yj;=;i#AwyFD>q0lDR+g3|XMtAH1_cp^ zh=(`yj-)9a5C}GsY3O?6@p@b10ueJFmhMf5{>_~^^J`eSy5Ag+`@ipfztkzLe)U>$ z=H?p@+xg}EZg0=`ZlBMkoAzq?`uzEy(|<^Hzw{}ZYI)1WDdXWmtF-vXmW>BBMLbl@ zEi}VE99eQJ=K5u(I!8efjVoVwJmG2Iy7g|uwq4Sq+LbD(Wt)Fr^zEf&QH#d>En7Q`H0%!~?4IJo(4;#__lZtlMAi#|qcVQ& zkC=;YUOnD0bcxvao zxUGGQozLs=Npm>4Ht4RIY(4*G*q0zNt)CYZBUi|AC}^0)ZfM);zCP!lB*#3yt_N-n z3Tqzv2+on6?P+|;EKb0+;K`v32FKX*{pY(`@8~|boV`loiouN~0VlWR-_K*6wDrvK z3n`KeDFFq>T?$wB_ou4!-*h+^z_jrp`);vS@@sDT2)blTFnC0nGskVoFH8Lp`0csn z_Y-#&0fPa?Y)yNH5X%^{hjE0CgdaR5 zZpjp6`@83|m zeX52>`nn5tj9(tS_}9U-a%Zjc*9rZfowkKNZmr#s?)uVs4O4@~HU(9o#-oOfhhHDQ zetBv3^h@f?`<9=+p1k|u#G9PV2eKhpP3}=}o_oqyjyGk`qS!+?)fe2qqNRL&(I-VE$NGb5ioX@M zb8sw*y>sv4yTAR6ow;k7I&OVhw>mt;Wvl9fO>1SNTN@mwhJKgaG3~eLln=XBUq3K+ zT_evjvsvpJZ?8IV(LcE-L{4$@^1?$|JMOgfBnZ?c#c1j<`^8VTv_0j>wL?|ond)2r z-;?8PrrD+K!sl~z;Mphf zJLZH~q~-E8l6%lt0qi`YiN**{AvQC*R}`?9z+fp{HOm@!Z@UbJ|?b zCM)K}2pL>tI;Iel7gEm~^PsBvRwA!nW82Znn@UrXPJDSVMYHL#_)?F8$SaPF2PIE( zlzDCAYMuD+UtRE_8yA_wG(!xhs4=*mI9<4*Vbg;mgN-Q)0<3XAPa97$U2r6oRnVk0 zP)>5{U+b7@7o8(nUMWwpY*6nmSzBwXX62j4GN=eiU;-Meb%`YWvR zzV8yw{5^5aZMLF)N9Cf67ZdY~%OAdSsCxX?{Bq~#^-oam=+WStu+y2=)i063cYsFi7s%}_vmM4MLnf1%I z39nZ7T#-Dfoa{b9_nF%{@5bB=quMXWE|&bc{`~TZr5{ZS{slE^PFb}k+F;rN=@TKh zIVXr6-Mr@a^848l`4<;(F7S@u#&Ga#^>!|fJYVa1H|Fu}D++KZC}v~{wG3*Fn>V>E z)!A^R>%?n+OB-V^zGhp?^1&&1=j|J=^90PqqJ&e_US|b;KC;R!D&g7E!q7NoN8dbM zR)H(iKCUd++@d=3$BY^>k}7C=0(_b#RneQ z^#0DLp7rLx?tM?P*uPwi!M9|g_oV48-*vsq zymOZ<$coxu93=Z*{qXL6qGVPs+br>2*+d%Jh=GCn{4vzd)k&YJ1YSh(au zwpKzK@B91v?@w`DQ4;We!pqa{Y@%@rpS!1=vtiFk^-XNJVf}tjvX-oM?*@s*6PR2D z6gryRZZ?!^uH=nEpcsCC24%)-bhxa<~6Akx?s?`4Hn$jWr6(PfD`N9k5WC^XbX= zB{fqzs~h}v^P-FzxtW>{D>Jg3kKZ+;?(?ztm(lV(XZ*J&LaEG9mwQ>oFtDttvNt3Zf? z|Cd*5e<>{0KR#Q>Fx^u1@1lomN_5#*9{+Lq{mjE0a>b%=j|$3b2N?cbks+#Tux+ET zYXD2*H{T>pafc0Cop0aYnBA$_xnY~g{Opah6m61jEps$#y<++%#qNqkxHp5{^EF1h z-+fHqvC>8>c(RLZkI;^|=_0ZM%*Tb0K?LOr7MvqB!L*$y|X=T?Izx?U>zF?~Y>(PtF!kJkaRFLkKLiuwJ_+ye$mq=>Is|j{F3j^tIt%}VRD*h!PIRnJ=v@0^|tmc+`Dmu zrHF8l?m8Zp&CAv=5@`A<%t*aTE7I8>1gf%EwiZ%4#)Mj?9z8)qw{cgt; z73Dl;g$wa|jI4W^n^uUYo##H`P&#Atx5=OO^~)}8Uv%i^+ZW%j-(7XxNVTam?rVP% zGAul|v0#yAPp<6&c83YsBJLK>sxD;$t0Ze%zMrVwWOFmk zeu~m3Kcx(wVulumjwPN^?R>Ic_kSESUo(S=;q1#-xp}7<`-=W)tV&R0bH2t9C=#Z@ z&mef_sY)yOO{kC6gnkfFXNtTa8Mo!Le|Np=5g>yd7|MzA2 z%ST7M+0+>lBd#zwylP#a@I)+gwvC!6xBJag*SAi|^h-+@J0c|~^7_xKud83aX)S)a zeE$^N!;9sYKVI&?#B659%bPkA{#`k^CH?;5%*jtYthbl0Uj0cubvkQpgom``(Mf_c zm(HBVqm-7lY{`Nqr|_^hi_XQk6*DY4Gv)TSlXw1K&E$S^yk^SrrsEx-FBSjVYA;f{ z(qhVjM<(VE7R545_j2m@6}--yAh1)lA@+o1*1qiNd7}TMG ztF6V`QM+jVtS?EYSdOp!Su(*s`oe;{?341ZUSGd#*Oo}0B>!32437TSRF<63tM7g9 zb8*vzRg4O9S}JJ?Nla7DFy1<7bz#<5r$s007H<6ErSPZrm4wNa`R7;d$zXi@Kwb1>F=zsT8 zS>8V6Y|P%aM%cCB#hkJw60?05haaEvZx6$(CPslNst$4u{9FnREDSRkrN1+{t_YcF zG{Z5t^5EmC3=A2E_IMbkW6biHpeY`*$(LYS@|v*RniFas~m z3{GaYiT*8C98)LMY`Q7ob9{m6nceJLS9qQMx#j7?H&ZydRB{R(6jFaRM;s1NyO_kb zCg}c@$5X@O3`@msw_V|Hm{}Ca*Jt$OGlaBH;p99tH%Zt8dmijJ#80%ZY`m{ek@7d(Ee*S&|+lh~x-TLHY z`%c8H7U4Qz(-^!};!mM$sgTI_82x1vw0S29UpyFM|7X_P&=`%GCjz!co?vQ>y?d+C zJ-M+uMTK$Fn{S80Dvk*2^)MCtKK!aE>UzcWzgEn-*+vgFO8Ke~WS6J!c(kqOK^zEO11(Gbi&x zkjfs74@?pWa*!pt#{%=>m%;|}G-(s}0 zcJLEysC3m5xk{{7P5xkFQ~ zdd>v#DSOVE)BTi5XiavD!)#;M(QNr*(@xsjxK4J+SanB-Mo23V(LdVF|kc8 z(@yp({n%SnsljpY=e$c(PCrktJFQW@XSvhL1D1U0=WnZo?YR2==Ki|4NM`L_hfcYF z-EAGf+^sY#((XfDGVk{{Hz#dVR<0;;uX>d2zeM-<1i?2#sV>4DDUoNSuARQy?Xcn6 z!Sf+qo4>_oE;?fzxVk}JVT0@B=+!CNQKq{)EuZP9smTYk+3q~*lA;jYv*yFM{FF@x z;};z-;m-_A{cLNusP5#A)lVC?D6|wt7xWxD__$AUlE(L?k8Mvo82EpBYNpy_&K15j zO`*d^=#*0OB93{NuN7R^%Vh7eyn20)$>uE=gwh>#9th-#hq~6E$hh%LNk?moPifSl z1IvH?xMMm~;Nm-#3<3YR`GHrxj`?s0rr8JWWU%nr&ybKXo$1G~-@nf;Yf<9($~WNz zOugkZBDHik0L@+aGm4`SE1E^GCaxwNA4(+P~fL>9M@m#^*B{ zKkak>zT|Fo+37Xsw_kd`|HIEO8@9|S?=ZTlu}!lh*Y7Xy19s65yL`_1obg?*DVw}` zvYB76?IG8b3VL0aY*be%x~(ycHCEM4%aJ_CDdBgnvuee^od>>6{3VnkZNcgMf}<#U z@(z(tSLdf~{1Mc1U1uNXO#L4LAq=~xzCE%cfa7TQKNp2RhgMb}skqqsl;Nx2hQ>tR z?H!+vZ|mOB{n7dJj9+eSoB=(rqk5OL?($-=R+lv>cQ*XdFG{{%_JF^Z=ApYh{|sr8L;!=0ab6drd@ z{IcfgUcW=%e>~3GyV~ie{;RyNPu|ID#C+eF#=x@vgpoDd()06o>4g3<0+Z0Tb;7I8yLQ?dE~3J^jun??JX<^~;URj{aQ#!%KPWQseubx&6{s+Y0gf}SYMBF%}^Qs~G)6qT!_NS3&#njf`@teP_ zI#q#VwbTc8Re`su4vKGz9E{)d3;cOkzCT;x#`Wvz4RbZuS^oc1H-A}-^WnvluFmmG zKfl6;Y3U8)KUekZ6SrBWR_~d>Tl;qF`(@($e=Krgl=GUs^{wo0Sz|?p18FM49djPE zJYh*^d6&jmCCR~c!*65n+!c+t#>8g1!MkJc;j~ugbr+0oSV_xN?Xgbp z*UXw|eX7N=;M~od^M9R?JG%4IH!j~v_+i2r&^L7zOn!*jO*MB#(sj7xDII5jmRl>J% zW>px&!K_Kr`;v-`SBp0+vfsj($Znianr?si@C@GWlLB22{=R)w`sa1m8Scu;MUOIP zDrxX&7%cbQtV0NK{wF|?eG}ad?+8hEdPwzPdbUU+hIEk|4te&@b`I<6~ zM%O(yt9H$~^k~W7_Ss7m_ix>8o_k;90UrZ)t8LW!MxruJ+&c)i^J?arwdt zhqk5NPd()oyI{koTiNR)^@Md_tvNX7e(#^prIvrAPM5y@HNo*0=f-o4r?z~~um3B3 zIwVeNhl=kz=9T|1?)%dJ|HJo}Pp8NES+lTMn<<)$FJNPmm6t#9(dq7EXFkWin~|C- zC-c41irQGeFm%7EwOJGEo#tvNBl5MNDC|=UQ_JGupomEubHBN6+nDwBs%xVsN5hFD zt&3bb?4EoNE3WuwxTM*9bkRj}SO zyv4nImrhsk6z}q*$@}FWTeM%DX=G@A{q8T*3BM2gQhcqLx13E*M`4F=8OzQ6qMr?o zr4mfDc&i20Gey4+%}RZ+UVOusJ=grsKG_&{lcC8+Ie>8@Z;rFUt_6H$FV6H#J$*bp zw=8BYThrF*o(KGkOuK*mQqPmvpDNkd#`<9K6%m62@o_9glJBl>zTI@SW7gWR%sqVf z_H2G-B~~gXFILNF*VwTzJ86CI`6b%VRpXb{N&;L>L zenV}Y_%r7@4Ys}QM}N%~^_U~zTHxVO5am$dA$3eRNT;!=qh{gC7N(ZVOnqOH-!V=) z!@1ea`|$A|3+9wphKuJ5{X3}^vS8NpUnky9J%5G2ZzD^?p);(Rl_!2W{^_WT+asLV zz5L0^4NsW4y%ru&sN9t7DI9(KrJVJgYj)Fk65ZRkymU2XH94%N=C}Httbegq+j?Ws zOUtq{f|sTnsb7Dx_-DlQz+;OfGXA+wJk)$VP(J3$-L+W@E=}9c6;fYz+w?;Mqhlb8 z;Hh{<7G5v2F#CBWHdW?g^8)0~Nb|p&u(j+}l3ZZg)jK1#&JwITuzGz;ZLm zFDOX+(0yJ7i}h>sZ#eaScPyCW%J3@mfJ5LqhuIsfz8+U%@ZR-F&-B_&ThTogoU;yx zbp8qZ`LrV3_DTQIxmJ#uX%zw02TqASnEKgy5l3Ifalx6*6E$aKZj5J4Kf$rd;Zj&{ z_l*O=wW1mF0uvh*9`Wm5KARc5SVTbTc94Ix|E;UP3vO*LoqkZFs5pQ%a8p8k+=1XU z;bQ&`hre)7(K@6g&5aka$p8dnGgZy;~hp)|8xA0Db&W$?^jv{UgvXahU5K)j?USO%4cl!Fz zpKj+PyN_csJu>{^h^>-uo^ygAc4B{Nrc_u5!3of~&V%57eOjKYe7$dPruJWl{oA_jQvR~c6)0fP%VpB}~)oCKFGwK#r_|6L8(V5#N z{7K`AN3ld+PNbq-<~zm~?bx%E8?5av+%k01eWkIWKh`_L-lXgHZN`RAuZ2qAcu9iIMm{@1Jp zasIEbURYlB&w<(T{gnV^0TYQe3%yQHzT&p{scXXFhusZkEm1MjELjB~a__5sxUMH~ zBCIHYHF5S9FSiYE-kAunyz^XiLMKtp%*UtYe< zgW2n6tysXdhOH@CdDBg`-SyY?Pcm#+v+4Y~j=#%tAFHu$SzxxYAWh-MmX@}aV#XTk zlh*dMMsjP3I3~X7Ywg>z*qKXCS2nZyeBYMz)9bdBzs}oS##q*15iu>`e1bGn$O1XX z$mS+ig(sE@{jE|CtfCW)b&?&FKIJt?d{X0mbV%r_9GAiY?#YG$48MQ>_ElAp`+41} zFYG(_t7a36!_(L*{@&jIclP-Ws~4sn>RZ;cp_#E^#@dB4s~N8@XRLo(#5j+!HY4Eh zA~q4`fX#)O4hB<#4txadSlWDo@k|4g%zL2)3%OWUo{qT}_4>`F*5b^Hi~zT_siy-( zPF_w5l^3>q(W+*RvvD7wws%C9;)8F4pZ(P|R8T zk6M202af7INf%T&b6BJ<;Jwe*%X>IW`)zmxuKLwDY&~(O=V?jwmidO8ngUo@1)^Dh z%@Q%+JmsR(y9sVaQ=AT@W{W!nI?OIHkw5&cHA%uWW=e7BPR6^X;p-dsm+;=%?qD#* zHK}`Nv#R7lBi9XK3NzGCL`k)tyiy#lJ28tV`sXIrm?J)!x`F#1T|D`kfg$Tr=GBXe z3o{xPtZkmIHg`6oqyO}!1=6}wA?se6EWX*R8Giqv7xOoNp98<1de2a|d+jy#O3U3& z_5*7fnwEY)`R|=DtH6_6Ms=&?pD?E{e|G6Y>RVoI$%8jDGjsd8Rw%sbfBD)b$6 zVkw7Hpi0d$w|ja!PG04Faj5X$+x+_1o9f{m8N=h)pDx!KT6KfaVpSQ`rRp zU$VEi|FK)kZ1VZvjIKsi9sw4KV7FKO-`(wmt{EfUtq+eM^p;7t!RDWg`{W-Rp zVjr%4`8@x>(Oe-9``TwYyHp+=Eoi>AOa4%P(*f0OQ?Wbgx zKHo4~vut&p#^x^Jk0sA0X&y7)H1D{(RI%E6t_MLJ0gG(zxF4|$EIW7Y?LyD4>TNfi zmZYvsyvD$9a6|2=FoVJZ0ZFGPoR;NT&!?F&9v8EHePLVqGJ`BRGf|0G3omP(dLk4M z;1y-T6<+>T>Ie7r1GQ`{sbWjjze(Lo`E0m!Z(E?)#GVI}Qdvx|sVGZ0Y%qCY7I1Sb z-)Wo3T!ojnxgK50e)NFH^}^4WyBvk3t~iJ|TdDM4iaWtsX3{!|BTf2KlJl_|#@mKB zkA{9+J!S3>ulpQFniU>PJ`fd_Sjzb6Y)FH`XYGOs0UPpUq6+166g;A*#IDQV9>~_T ziuZbt*xHkZj?Z6KzBjg6q5CYY)K;(9Xz}AWlG<7FY&D|%3OBagS=Xxbs(2ye;(Z%l zv0P(ek=}aitI78crXA|JuWrndtIdeNrLOSfMVV~>x0#!+U*4;EV6lVnngor8$HI?a zzSy{!ttn%#+}|H7QrQ`s1GpLcT3F8 z-1Ai6c(B+e=W$!pvG4o;*D^c4k~A}UlMu0S3bVkC>(|2><60sw%B{Y&>Q0{YUN#P< zwu^Dcc9^ayigt_o%wlT0gJ#Jy9(9_~usWN#^|9Z{opT5M;TO4~OgGY3xb)C%l z=)Z;Xao^Ven^1JqRd!nKCsW1B$I{6Y&Yyk!^vBoF&7sWS1qH4!t<>LqPVUU{Eg9<{ zp3Qun9KGlIhsW{yTiUo&1tZc=7hk-ZZdLi?HL(=y>0S^Hyq*_5~?J74+CsF9uQ z7SKC`C)Xxw0l%=(+g;CneyDC%DOx!rcgmF2E(|jl?#p6}h`SWNVL5AUVRcbZADa@B zqEA;6^UO_4JF6o%_<^Y}J+4SJx-+zSZK(8}1n(O@;-pMQbcsb&(H>Fl9A>>j5+ zE|@n_{fbY6g3gWqKl=Y0u=eeE(!0%IO~knk2@8dS#A5s=zc%`yHN8FEa{twTHrmS_ zZ!$D7ypsR_EC$cY*sa$RCkhN^Zq`12JPfC1x&(D|c+6+yTpcK?{y|?bCQ1mFadW`~R~)47)e@=8MgL9x${0 zxcg;wala+W$NQINFACfD@!Raol#sOaBTnz^FUA%zr(t&1bXP zF8-G)wrRzLVD4WTlgx}lK1sf9NXl#0=wMrNrh3xCzyEJmUw&`1{?nW4=w?;#PdUef zbG-fLR5o2QYH?^#X%)M*PVZj%-t)m>^PlHG{QqM5I=<|$&fHr9I9PTlb+=llAiqqnQR-k00Sb1!<=yS?je=l#BOxo~c^ldJi%V-t6BvP_Ab z8|`p#*}I3&CmrMawVvVanVBbaU$vIKDL%|^>^a4AzT5$^+Iy_EFOuBnedJ!@%+B!b zd$#RDyJ>$O3SYm?8@O)P(uw;WbFDgiHD__9*CyWRPH|XdzQ*Crs>Yh{r9QsjO;1;b zd=qEsS-gMhJ0pe7GQ7vWSjgWi6qWM{a5=(nzCiTE2-Saoc~M8YF`P|Og?c!tJGr? zE5{}$0sE&_hhA`Q=>N1<8dnrwPUJ%!hlj%h@TG@}-GN)L%ni(B&N?(|x!u03k z(zwuP3{Oqh>m0pRrcjX<)BYi=`NYi2Oik|RmuW8REY&{IDa_QgOE2fyoz@8!1`pyM zdCX*JdbHQUHnnV`(`Ct~y+TWKF0f6kz5Q)jua#Na{odb~&V6Nak}g{!U7mS-J=@BI z_e`ZUjB>AtvxSru8MPk2rR#8Q$~ASS6o%+GRjI$Gmp0h!Fy`gjkg$P`#i)a+Z-R)C zsEwJKm_mR++d-GobwhOGe4C|NAtI{evQuo~Y zJ}0M4v;O5vcOE>{Olo#mmL7N{`)NgG`L43vlj4p!#y#M?6kMji*>A$*l0Aj27uYS> zDhl5lZlB}8eJS`lcY{Kj{gT*a2Y3HXiu1T>Zzbf(@TdOI@%kgjrZ%(lv-L+lKY7cu zLE*udgY5D=x4Z&&1>6bWwAhEivHPOC>_R?S`%0y~Uv7E7G}r$dw#RBt-LEs3Gi#D; zeoeLi`DFeQ>-W2q@0R^uo2hI*hhvWdr+r=DS@qz;gs+)zJ?xhAYR>VWVZLO8rmMI5 z7e&zn9j1L*?5oo<5-z!#q|Rbo^vi8umBufP|1s;(~T0M(f*79*tyy?aXW{+$i zEPiyPb*XNpTW3I|t5s1u|Id$qk4tuZeI+4vP3)Vo>Y2Wjm(3pBTLoD^Z&-FTGTY+7 zvMFpD-*}&zcC1#JyX34#&x}lA#~PMrpZFdfvb*MSiud=MYXai3R$IJJ?vDAo{EX>W zUF($XtY>w-C1+)Lt9-S`YnanIVb(k#vzAN7^?ZDG1 z&hEaMuYYBPgN6go2WF0qMy_Y5lij)9WLy+oe{P4C8JK}`I4kFOkc945*^|vz7dhT#Fw~?=Z3|i-n>s% z@*K}xFIxtQ1xG(EnSHKb&PPi=|G;*Q%Lk+8FMhp*=^LlZg`XR&CVZc3^QhAAd`{zbD_NHYfxi{?Jl#bK{xFwhzs( z-!UA!@W^!9k&RPaHuzKocU%?yA=~a9LPcNjV63Y6f4uF?EZB zzj@b}Gv_DyJ$fL^sdxOPjD3~P-fy#~mtK3czNF{u!Y@~h{a@A`+&rmetsnpYpW>I7 z%l`=Zb!55S!j}(a8Clf7HWsG*YT;Xcjh)jWK-zEFmX?P{eiXhnyLMKsO0Cr8?3QKI z&MRK+Q(jfVv3ni=TtVL&9oM^Is{L`^Z`0bgIoIYJc?h#yZe7R!BA{yji5|8cT6eDS z3ppg}ubRxWpDCmG&oRU2TUln59oK#T;rf*gxAGgT84oeey?r80sBfX9q$C%E#erK+ zwzad2Xi|RhoDcy$qJwM3p!(I!yT2qM7{n;!d_3!VH;K zv2S*ow)h#9H*Ip%y1_6dtmOK}g|!7D(O>6Ve_%Mr;JEhv?iHH%Kkrg|_r;L6X!7Nk z7p&b&-+w4%bd){3@bFU2`*FM~N5ri+hDyDWSr)Q5Yr{0p`t0AOvUje{&AdC|+Opi; zhHqoG8^4X%uH5@pvioae_VqPWOC+vLf635tWPxbvw8yVsN6I>|nJ;Nz*~n@=7ds*FubysK>F=J3XNFzyOmD*Imb!K1x< zWfmU)_JQ%i(Pg5`+HM*+)img)8 zbhq=3YuDEtZf>u2rQO*ZqomG9Mc_hs2R`g!<{-*V)&4Ai^A>%d|1Z1s+!mEXVfZ8_DO>CYf> z`ACCogGBb{2{npSlZ83o&3lz9z;uO?gHd9dfYDzLjTGT_Mx{KP8;nXD-Q!oh3;sVN z&sB(%*W-ajfRt=h#N^|*tjo0jKaKyF%FW@#9ON#y+UTEOV*+PI$MJ_J%xx07e%=57 z_kOe5vNTWrsvTMVrQHpQW}ABY`r@XYU)rGXG&%GVpRWe9$GwS<4)MQWd@i=R^z}1m?xB)p}i?sb=?LVa$W$6P?{Jt)KsUYTxfl%VnMM*QS^T@5;W; zcRW}7d;PC}UzW@NH)cGTt0>r$%5F7z0`v0ooFenCmKf||V_|w#F+=K@+{*`3?826% zFTcF8__(U(mCCkN+RM-Nc`sT~z|=gMsoh6;zIa5>&1B#C3@d(p6}+~3+X;4#%`2WX zGJjCk|8)4f;5Usbn{%cq!Pk)BRyqj_=0uu zf6Xu7tX0%x|C5>Nf2VxSdGp4-2OaNR*?;=}0tS`f*S1HNN(WrXtZs05^RuF-znr6U z?seYOCzH!=KhLu9tMI|6jTz9i-rE zx#D2))R_5?BrYhN%T>CgvdGRwAwahE7vry{IZo5qSQ`>tOBNdmJW#DZC*)MN($rz0 z>et7oB?4A#=(-|)%DLu^mhgm<<1crtPv2Wxz+)FEq_z6NqKcc!4B|Q08H&Ajx2m7_ zSz3PIX3o9Z-w__{k?_Ar5|!_(6IkFyJ$iR^ReQDA8lKuw>noC5+e0z6` zd2g8%x!-o0TO z42d4kc)C6uPRLDQ)?g7ZwD`ziH)E0uQ%6Zx`Mir4dHNVscUaEJd@$EyqTa@5ybe_k zLi%~19Bv&IE#I+O?!&@%xvaa-z4!2ZVDrkezSenvOLBTWgT%ete;wOJ9hx_IcrzYh z(7X1e@Tpw75mUiQejzXKdko1>Hio1 z{~|)cecKpYnEuo}l~b6Sne}DTw2lqk@)?Hny^I4L=D%Dx&*t}=^QCjnzMkbJKRx8b z1eFBlsQo)NZU3AQXJz_tQu}1Fyl3>*KEuAuz}+u$?YvgL+sG#nq5MH&cg<2|U3=rD zdynQ6%@WeM@@%5>Ohv z41OyzBD^6{?AM-2NUe>%zK;G|TvtoVC zX~W%FWVB%M#piDGth;zj zJ}hjEl~tGZknvvNr+Vn5dD+ZUHWE99yY-eR#51nTzG`Q2D8oyUt)$Rk*`$y#Lp6^g zgSsGxfbV?!wKE?qY<9mK*?5Tat=6@7G8^Nv8=YJheoC6KB+sO z$~e|vZJW5UxBAjP-^DNQS--zJ(MY;v&KW*m9`oSCXC9iTstR>zK3W_W`INC&YsV^9 z7SMv<bZm&L*XK(?{g(eXTGzBKTQ*I4mNiF4#+yQJ zW8O`H*(^LJXE-^sW;J|mc;(Q}!t!(1>#K`r_Pb?r86>IoS}M#qDAOBV|BLI~O7pq# z!k_k7ot@Dl;`>fQ>V>$Wn|jyJ)xohEfL*2SzW`k4g`)08Wh7C+CHyVjmFai!d=-d9H!n6-R)sWwxQ z@zCBV)owhk>(y3y(pEWCKTrQr-dOm&|1r zQmg_T3m8fmYYZlEtOo?veQBS2_hYxpggrCW84l*x z|Gurr+hUiIXfrEA>dkc=czhIaZc;u*a)H2cP7g_bk<*ffKUX#qefoTrYnfh;= z=eJ&&vNG%5%z005NHJ*gAHV6q{^el(Wub{>Ka%%N{UWesZu*q-kNfTA%H`}=DktBw zS>fx(lxuv8bAQ~W_#dBkp0^ia5bbg)GfJlJpQpRZZGxnVp1CNA@`e1A>azw6Wj`OIaHvQF7dpMP)m zuNxVk*4JD<$+hBQIKzi9=2s?9PqztOvvx#f z^Ds_iuwVBs`MS|0r;ATV(y-f4G$V_F;sHiPXl0@M@gv*yC)rmiI4F7rAGXp``+eH1ck81wvdP+YmMOPHwognFd{Sk4 zD0+J22Zb)>>B=%s*0Xy`{kd#hIjfju`Q?e_eoLJ5U;p4?Ja}2XX_t^HX+ih6;W?ui&v(jcu17*$jrX_eJ_xyRe z;e&Tn+=SJgD=(h=>=q?D(cJzCbHm|hJPiEpmdd@%H41;7q}VqwJTTmQnz_O$i7nvs zxhNGE1}6s*hL$Z1)gFwT+y)E^N`^ABR}bD`Vr#Jaqu7{y>uT`f3(O2mZ#J+QI<%@3 zo+RYon)_Mm)PtlsL(NG3iG zC-E7|EXR*INC#i{F!yXfZnDsNufnp0?O)b<$frsfPT#WGPcZI)^s?o#ehh|(j9lLq z^UM@#i=XB_HPp(2-c|7+R5De@mKogM)kT0eex%>y)+-6jo!BGuK7E^ z`Lz!=Te*K&SF-w=!MfPpdUgdJ{jy(I6y4f1#nbSrl=X|J`QMtRsjPT!rO#ljJfZza z|L@+3LQE3N^-rxSSLrzJCwKMA#}KQ^Un#$M!|%S-djeV)#GuGq`1aSt9lvMTDqd7K z^Uk;-u{>&_X$4!8@>KY4b9z4&xQfj6Y za;uV=lRY$8oaqVY3q#eOE&9tkA1Ct^ocLN^`KqFK*`&RSOXq*)W}hOg%bPlx$BFq7 zujiT<3p_78H^1wB#dpPykVb{0rLikP13f#6clX^tmlX8+wC}&7_eX?e*Hv+s?|E_9 z>T@&m62_(&#p9AqG74u)45zPGcI>*Qv)|BKF;mbXG4BLBTUx?FafP6RLL86!znb`N z7ie)*-nh%Tjc*cXwak)Pb;kQ+p6@UDp|?4qwZg^S{^&_bWOx$1{{o&0lZzT~1dtVr^;D?zU~q z_gZ;>SX^Fjl6z^^!HaLJOaIO(d%5aeMn*twz{#Bf%4xnQGXpk!YB+k}+!XcMraLw^ zm1Z>XvsF9rDHP=B#H%0wvaV5qL14m>b5YB*Ih#u+Y)#hq;ZSAM!nj9qDboo-d540M z5)+k92C2&o7aGM>iW_(vScSH;%hwp>ojJhcVEX=K`{$(H8q7Br^L*LxnuTMMzDh2G zKC|PJB~JtkPP|KKcrbncpQmC1EpneYKkSlH;P}fum3Iqs8{_hZb@U)f9bpY?>wv8PbD$W zw?$sMC%r9?Th6xN|MIPEANwLUTiDEbzd>!^1TWA1LIN#)-b@W26n<&%Wmb53{L#F; zWsO(Y$4=-onK1W=d!MXO$KH+g46w5R>}U7Qvza!p`fd0wZp-Vwd~23D=I(K<5uEWz zVtTi2*Yy54TXFq_Fze9Yr+VG?hsG^JWYtvZrQ|}nS0VAW-qfi5_S1l z;qH?QE{V)@&61eyvm{u(xldtUPAYTRj3nNQfXMoF;(Q?r6}_syzt61Qa=7EljoIJC z8O2^{WK2kHHxvqT@MX=4s_0nxkfEu;!FAyelW33ESCtt~+~5;PnK*NeNALRBbr#Hg z=aha1KbPcRXVm;6&9Yq0NH|5%WK(P3B!`zqN3Z9E&Sajl__R*W5vi$3H#Yv9P}HGc zJyrLU{56(&mv1&6FJ18EVYy$sOF@kLse&VCdKw<=Sav|kul04X<7L9%@U_MKNuwz%`i(l zHECtyl28WCdlT0w9%OP*EL7Gx(5{)T((UoggZ~4^gT&Z**QKXj(tFM-%X)t;L%kfw z!tR16XH(hr-^kB8Y5mi|iBq9fuWut`17q3Eh1OP9v;IBH|EG5DwXtoBtKjsXr>$R3 z+4AUF`HQXbmpvpz@;)%^a}u7N8DY&S!8*f9`N2fZ;&TyCu8BHm1w|ZK@HyS~c-7ne zPlWA)-0uInw*AuU^?PUS`#m?Gb#2X$p0|>|w?qBiLbu8PpKR~_JAY@W_3eDF%xxW~ zSU5TY#l2Oxt(ca+RB4yb#k-Lo8@=wk?H16vQrUc~c1`mN{+0jcSXQga+7)U1ebB0Y z`C+nqXrKPEv#Jei=2n-#TxC7?t@)bsuO@8KbX$6~#CW;NnG4sZ_^tEzT9~P>wS*z} zrX2sD)iPVp@lV}6^{ig>o9KVi#&$E5IjUEv@8y_tc#`Y9&<-8v^9hrUmUt=azPTL4 zzivbH;<-mCLiPlYxlT&wqYmpN&PmoOJl4D=u-0pJj?&X# zpA(-SVCUdimA7gm-+I|gw>qw7-tCpXv~2d)eJ`e+efjMC-AQKeZq8`i&a=8V>qN?v zxo%o&E4dt&JG*{<{W9pxQ57eSC(o8nl>TJ1`dKSqPxJi66HiCavAD3MV&9Poe?Bt& z5_nqNd*?*XM!A4q$(2Do30;$?M0}i-T7KzkzexY#po`9$am@Dn7JQxdv&pu;>q*l3 zH@8pZIX$;{l^-q>us!NWcskGNuP*BACg%QHv&^@2>7C46Da$gK%l+xBT>UTin0Rt7 zSCO4FZ^^r78duEQ9~Ioxu&#@4ZGOD8m6!ni=$_K=~4A}`AZg~SxEsk?YjBymkSUiVN|VS;8# zUw@+1lrIy77Imx-X;}5Zd~w?14(=df#Ge-Q%q8@S)fI9*13!TSLil9yySx0i~beNpJ$yGGTCa)-pi|drfh?lK%LA*%Qj)*^ev4~ z6Mh{Gw)c9!=eOUloBH#F8!lavTDx`k@5SGjuHE%8QzW!^b~6^G_s{%E{h zFY{;HvT5hDkAK|qMe<$rbdjQGlfp!@qGs`yZSg1w&N(yV>?E^w8;aY`*h|UW;qr{% zk#_H>CZF%tv$@u{C%a#NR$1HmD^uxF@ulsv52UNi_Tao(dd6*19Sa*%$1k@lylTIG z2+#gOS-LAsmZ$^-e~HWaj!+AAaj?oZBOiI&rsw%zU=ST zJ11RQ_?%BmSWfwGDRFDZ_9CBq&--tShwkHfeOKdEcIe!KhQCa=Lf3D7lH(L|Ui`F- zg=WgDCbLM-R|eK=c@x=7zrF2T`Q?*;yzhFuk7-t4-?jAFTQ7;O3z;!xdD_Yq(`z#3 z%s*=!#Tnyx*I}i{%k?uucRlX2zO*X8=CSnjegD3$Z-3IrcS?4iwf3PYtuv%|2?ZUM zGZMHnwedk3WddIW@KSJ@qxwj`Be>O$4hN)-@A{rO75EA6Xf<{ji5`?sWhoWOw0Cv zn!29Fq0PKx*OSKf4;r8D^cwk#GdCUap1H|xigY-`sVmYMs<9PKDVO90r^qJAHF()^ z`p4}Kz2I6QQfLu>BRD^1`pVr6SKQ_Q?_+ov{c`#Fe<9C5y?i!z;=?Z|+3jYQy}LGZ zx_RF9Do0MiFAI-4UXh8jUCOI|TyKS~*P;_Y+a~Y&`ee^J{W%xUc-hT!o4rWIlI6rD zJI3beX`jASdt6zxeY))5+%G$~q>6n`NiA@nb$5mLSu2-A#~&$tZ1~LaP|+qK%Hq6` zM^wjLhlDwcHGVU6U1E>0*2q+P&2_WjlKSTfDqS~@-fUZ=9rFA@)S_dF>{!Lv)L^Nrp0rn6-ZI#jRiGv~y>cE4$G&Ne53Hv%JHA@dm@wsA5woLK z@_MazQj7=dayQ2F3+%~EzEyL2TFK|;Te91ugIax^Ux`fFb0kMxRq)OGaMrVn^Pjt} z`*3%~jjD@Wi%#wJNIlEzu>aTdH9KZ79oTFoIQhhO@$jQ7J-w7xuzvGlT-`4DO17)b zqY6HbGVEB$M=mL)A@o{+VF8SA|rb&u0r z|I}@te~GU?&e~(v2gZQY%On|C9onT$PRRdcm3V(SYR~?EulMu)bKrisE^KC6v&y}b z!X}6Go9&miGB$q@d(daU>^d*YOsO{WmeRjFrDl1Er&`Idzqet~Q`!Ha_3r5xKB1G< z8YB*!`(pWAdeP=N4gDQL71rncN-r(#(QyBK^5>D>D)!ih6gv%umG>`|n5O=`bH0As zwY-Sw*YfX7ko$GX`Q@_N`CirEdzbn~U)#J$twDDCT%SzYhr84Jj_|5`u=>xx_=#86 zx7cw~pYg1+eG1Yvb=>CuV@-Nh8xbPauvf-IT7jd8)=Eh_9%o`?3`9r z-i8)x1)|yKSy>J;t(iUd+SUFq#m2k7zWOrT>ZOuO)B5G%^DHL#?G<+j zSRC=@L)7Lxi*r%8Hh8B`zPn`Q!)Q~}7zW2{exB!6u1xGLvYoW5r}9k{sjlkX2oZGs4(BDrd&O(8W`=5BT3N<`uYdeMXdAnT+U!mt7J{RgU(eVSYc7 zWHg;7Garqf|9cVFOZiOq6U!{!+Nb13MaH#!;|Qx?H;?(z>V+ISX$NM6&QvV2FAr;H z_J8qeO(x^P!ycE8sVd6&3m;$ZJVW+hsC~d^YqP1z*#Uv>`U}i2n9tajb7PVloBO2~ z(>9izzi~J7^DW;=e0`pWY?f@bKd~s%XrbF8uN_@mBZH1Kw{RPrSa5P{k;kEV6^}Y2 zy4f_GS2dTkKlWruWRP3tP-&wuTaL|~ElchZ%O6IL$n$I&ANXR<$gS~Y-p})(LFbUb zJU@<3MIn_2h2TpJoDQ0oxf=pi;v4w>JZwMM&F;XKtNNnB?eoPihnW8?+@S3HM}S>A zVFuf?9-9j08LR@6-0v(*E-5iF>sF9u=~+0(ZBNM$=Uqp*d6%^>xX^F==V6qkKRffT z2ilXo{v6;w7v>^$!dKmA=k$*P;wI&b7o4n7()rmW_NH<{XS-?lob??2KN=jYJR>)x zef)MizkidIwD5yVg^m}V8a3|At7Nsk!h4xn_Q=6z=~7Nj)u$}=3*PSE|2^Z%%jfk! zKX388d~o*m9KZVCSND5vzhCLT>*uwwBEw<==IY&-Z{UuS>4|{LrP2_C2Uf^(zLa{=0XQ0 zdxIadm!?c^c;M~7cUs)<`R12jmTzU-lbbc;W2&oaQ^*?|QyqmB`qOxKODmkX@}b#> z*IQ{vrN^VHt25X*;@(_LxMeCJ!oDl$;+S)uur27z&WGs-+GTlF;y0{|Fx_$doOzAt&w1GyEhl;}eoScYn*4n8 z#(#R&><`M`i7no?BE~cCOp8r7el5^66x2$6iF!3kw zdx|AAnlMzZk!LycpiOe67_<4i8xO^;9TYQ52`rKeaGy8?G@ zi~3z2g=fr;47%Suwp+N&+LZWKZA-%Owb~b$@*|WxOeSn2xkM!$4c5hrKV$h*7{Zpgf<&8290#&Dsmfj1P zzhd_VcS*ZnFTO86xA()L^_O_9^E{&SZ_N64|NqzjOReAUQ@&fY``V2B3(M5M_U0_J zUcQ-s<~Q5oZy_>Cy-)I;(uIni8@7k}b4f6<+?--`P|AtXiQ&DK7vr}vJ;#tprf%-^uNSW~92B2lrMmaqlY`$mI96?F>A$q$TwT=KuRPLa`B^GW zQZKedrZg{WYv0E6a*k%GHQ!U)x9xM? z%JU{qZ+uu-5F>fKO<+lVR^7&AZEx0t*RoPx>F9kq|FrR3>wX(npQ=|$SCn0ngR3`B znb5?edWos##PKbAv;%Ij$OKx#YTA&7vHznF^+e2K27}leW|or zj&J#!ou;{wi?xrbn7)ZOUBI>C$AP9OtB2<({QOog1die7)|m)ABbz zZY;1fZ1t~wbokjx`Ik06Gvh1YPAz$S&-T&PZC~pDzrVkH_xqjZchwl|H~A&E|I^!` znBw-;`QsOl=gPmE4%}Jt&d!coK;**g3s*i&IiQ%$>7RM(#~QwE$7=rcOta)*C|Y3} z{zy@iMQ7e;UiB{N4V)SxKUXy{`EK;sbLQaGvpaR4{8JFmez(;-Zpycv-_vX7|Kixg zw82AqGuy8Sag6|p>vuR=m|kRD{ve)kBE+aYlHaRp##y1Do(=CpoVa&x_E|kYGkx!7 zF+r;xKfRj8WrIIEte@v(F;S0`VRhc~IVs;?D7~DalyNS+ZsF#jf{&|%ThCiCt+>o^ zeWSe>W2f1J7*mA?g$Qm96Vu7l55!!!@}XsU+x$A+y=Sg`V4CgfpsTGd7~)vy|73&M z*J%y~uh$kk6!%Ja^uzwM}=^Jn6K@u2NqmCmd%M zNRd@=5YSYRcA3Eu7JMc*^xygKPv3h+@m}W9C_A3&u;RPN_ROH2rk#-wbzhsAhjBUZ z>`b1ZIVZJr=Jsj-vv#QQ1=vmT77^^ZcKDaQR?|Gm+C6iw-%NGCZ@aAVb&A!p=T{Vc z%`SSU0mmLRZ|U|`@|Z1G@u2a>jm9Ns6;{b~ zbew3%CTaQ|;I$G`V^CzaJkb1OLQf@^gupT86$yVA5i@Bevr0*90QwaOL66`8JdNWb7yYEBJ8Mr0Q}+!=?TI?f<(we0W!KdhPZjdP(>5 z&lno6zHgUx=YWZbtWBdQ@ z$kd24-S+Hd+}6!$wuTG_*Mv{;&-P+76>fJi}olWF73aBzmy zy(wm|e@HYu_{YB4rJ%R3f1}HU$H{5GcSS2pgid(9V^@IEO4bE;cE-xhX}fV_kv3-@ zdtmWIlK^wQ6HULH!Z$ySR~6{azgn?Y&%|NE58b%s)u&#z>IB3UGb{1ro_@_#d4BGZ zIo5T_?BR~p{@bHBb?jKxXK_L6l!Q+xUrE8QJ3*Vf?Kve)L`_$(d?@^K2AlSQ2b!KN z$!jN-iNy;jl+?fE+y5uwVL;}#U&c9#*OtrWUNSBI-g9^5%EZR0d$%v0`+D1QL0Q$! zr3J!UbuaB-(O>jvv7F%oUTZ__BZWT8j4<)ijq$tRbeR-1mAu#IuS%R_v-7OGeq|%aU$Np1E}vbfn_TeZSvz^K+hJw{!0P%vQ^`^2pszC7sfyf|hbQ&TeUW@e3}o zZkv2#tNx|$zoNG0a^Ug&TlK}aDj%==vUUC6+Fh^TSzkW;`}^@N>H#eu3^lyor*pD; zxP9~BwiIgS|5&`~c+ZmjBqs-dg$b+Q_xa15bO?C=c=BVW?&qa)FDk4IE4>tgc27|6 zciqALtKEwAlA3H@zhne+3Q=AniaMK@;H27RmO zt<5xQnER_l)N`Jcn1ING?C~V2%+ReS>`kYy z6o)chB2TW*@G2=89ch%cFkp zlAu`doe2m2u9&RIc;+h?gQsQS9ZK+5=d_!{}B*?G50Co?>3+fx7h zZ02{hw`y^l_3rK{oL(l7-L4S-#5Xj31A7Z&5rc%s!5QzEJ07w3p zIQ_rThF_YoygnWB8#q@e*e+?*c~}2x<#MJJ1|G=|jPVWJ4s!237S9keEnv2ARCnOt zZ^OXvAY>)ve8yv?&dj7&SLzshF0ce>HgYB~N&R~o|4+3+;lP#j#Es8*JvAQ)?=vvv z{;^Ap)uAo^$?^~e{Y%d-q%o}IpLmSlLFC?>+uQZcx)}Tnt@$2pezoMx8}Yjg6AD!0 z89p%Rz2cG=U^qDc&l7dU&^Ehu+nd*|uYH@XD425Hz-HU4X?*RQ{pN{vHUDzC+p1>v zU=+fB!$pt z911b;Un48>!ugZAW`Kp_=Pk?n`?>$f+WeaK&h}caLHpL=x>r6jWoK8g{Jone7MW9W zDpyD2s=u*Sz&pc5+Wd?*#j|$)PgtVh{&RZHC$~IHcEgI*WyfZ4yE#~$V0L&TKS3{m zeM7fq;?~)6xeAHj4TDc_{1)IaaRc+Lpm*03ujQyoc5LS2Y?p6P_#3Y_@r&ivhKJ%( zK8t&TdNQA|a#@FVDIRl8TK%d^Mxa}7Rm?<=qD7qPoS!BhxagLydN$4Y73dsx!*~l%`#7 za&I^u&c!@KPHNu27bW_u81%CyU*2&}WRAr19}=>wKW$^4nIqjdg`EFHSb5YiI68c?|M%Fw?c5g~hJu_Non=joO$-iwR~Zu~ecP(R z?0EUX4u*YG_=B%}Xy5#c;rtWv3+*No&KffWeYtq?Vk&df1&5ovYBcR%u{U&oZSc6u z&@^YO$J|E02KgE`j-YZ4Yi~==_$IIC8>Q!N+NkxososN`v7z7Fsk6`J!-2;8?IIJu z?%IB*D7)eN`hWKEq6vFl_ekgd$~=DKg@WzV-AkpC+ahZUimib~ zU#vA2ozxaPnPyxTXco{a-s^8DBhhzW!mTV8)Wm#SvjdGmHt|A+=c5Ca7 zLjEETAy%o+iPvj#R`zD`EWfj0ssFzzA$yc-RSduPU&!=2ZKrZO{^j(Fg8up1m22`= zaf&Bj-|*vHo8Z)X2FI&?nz>?$XWyK$oEx>kv}v;X^2^#$%0C_n@Ap=}U(2u36ylRe3x?%0s~nH?ExO!$&g4~dmZn2M!v8ldOE@PL z&AqtrlKQ=?2QM+T3a6Jm_|kcqDLbo&Y0{jJF13%86}46$+LV$s)z0J5L}}SK3-;~U zp0W7EhX)0>_9a$J-L;x##+QHPX4CfNrOmG|M=`ouCA`wToTKy2UFvvK{kc`lDGYWz zlOjI!hg`T^!!XrG8;<6sG0f?lERpgY0xn7?nLi{Iv&{}OP=4yXi2Vjr ziQu%-%pa^16#gpO@H;SAE#S|TKhR_IqeJqMq_i~mNu?mg_3A7FxAYYz*%+)~X5r7c z^+*2SL-{8ACEOPtIlek-qEpCR)-l`SOuNP#y*iK0vK&drnIE+F?KtM^An;E?Rb~DK zhj|Os@82_&N)U~DVA*96P}e`5uTDez(6pzly$$6I;*+BN_kUt^jAWX|c!J^J{@=Uz zbKi52F0`IYzV*H`Io7o=i;15iw?;H=2sXTKi1Bedorf< z`uc5}o{A3y<&J&K=;}VJws-HQ>9GuFJ?t(s7@VBql$^e5;XdQ@*Ej0FVm9{jnER;4 zUDT-T!=E*IVvb4`gkJ-ef@H&UsbS1zd_;Yk?Tz5&YRQ{Gmd-QGT3Iv zH&w1SAwEhw!D2(E!P!^q!usy+Fj?xg^wg?V*9rxVOU+l$jg8fm-IXzA+VB1hQ_IlM zJQWL_D@%(uzjKr}6&6n_v{P7AVAjoWGb3oCor%X1%jPX@hXQ0)>uZR+#HFd8xv?@h zAtmb8niw`^Bdu*s& zwpF1#D*UYPOTI@dg{`({#-xAneUY^-S)Ey-fWvh8K4ylO4aO2re9NNNZ}GYuwED`= zOFN6^_^fGvE$=h?T8>}xB$m8u7mdna<{ad`bbWo~e6x&X<_97N+OM=|1~9O3|7Vmu z!n{LKPQ@yx=RsoD*#iff4HleSC9}l#!Q(VztB0NPtUHVZT$DI|B+n9jaM;>``=#ve zX)~EzH>EIeB&0rIpYegg#U{Wxn8$=yg5?3@j~Q}qOdc@}E}z=_tS_I~;i#M#sm#H9 z|L?nUXZ5;@1cei9f)z)0A5{6m=)n`BG+FkK!}h~7!uL$(|IxhUt@Zt%ejivnHTSqb z;`DG=+L3>MpN2GpM8iyrGu*GARkA;65&zVv|VNhP4X4h>*|l#Iu2R8d;gsCNoTUv2x?-svg5li}l}M z6)n~|d2!V}lhVNBr#J-m6+a93^|o>PB|*l6&*QK5nndYa6y_-{3;LWe`*+Tzmo8tq zHClx-8G9}iAD_4O>%8dDZ_5Hzt;8>#l5;8FVjcOy{&_&M-{YQZ;?r18G z(9Pn9z|V7)?p;?_zfAmbaeq`EX|&L(bl0LY?05ljpdgQx~Oju5ID1TX=v~wMzj3sDnYFivwAlgbBsV(w>AfE_V23dDBp2;`Y@%ES@(?0;e3g zxo(qnp`~28(~X~*{Gs>P&ty*0<;`}pZhq-&n(u{WXNV#IuQfmmzvvx(cHW>mkM zvh4m0wLZ-Y!mF-Z&DUvIU@vX*V#S#s-J2fA<;oT>lncG8R(|3zb9NH@$6p6|XGzIj zm28&2{C08qvff)Bo8q?j=g3HPuD5lNf6(tM=)ibW zICXG^%#zseACn83-+gFd=3r8oa8KbR!zc+M|x;Qgt%Ur%0TyT>Dsn49{@{@bTSyJ=!bUa_2;atC4M~*ia{X6q|!>TU@NB{P#`%ePq7wt-t>y?}ltve|uwJa6`-O=qt`$ z;cvdpeeIhW`*Xd!{CnT*?3YXC_A>>~H50fpNoB5)gu{muOB!Ar48L^o^6^XD>;I|E zon<9yKBZuWwS0@NqLaar6E!B`F=!B+_HE*8MtAkrsCU}W zME1M+UuAzA_v)hS&DYz!q;}Lg-`Z1~e5>^HI+I1!ZS2?hJti&F_mjP2xt8b5Ggn?& zW4(q+J09{KW31dRTW4`zVx0MM`=6^Cn;jGxa(nl` znsY$ND)X%AWmTK-=ig=7pRvVHO%9&WV7hf{z|K0w&J)L1D|F4bHCkZWG-;iIX^oe| z2d0Dr*V!()GIMP1VhsCQ=Ei*}c_w3TkT>(M$_YH{9!N^nL zuCAM*n9HWi?93oDJAk3dM^yRY;khO}Mv>g^b6VtOWqGX@boVMXa35k+=)C+>Y5iTT z&jL|@C%AjF>{a9c$I!9x=If6PCoeF|PLWg)bhVkn$@Ob@=o5BU{{{SUQXER2$9hDr z|2a0d$m!FmLT3*)+ok=|{i0ti>Tc^U-TwReU4^N8cJUq5KGk2k?1En{+Y4uDtD0uF zQ_^vgCA00O9}W7_vOD6+^35L^CK(H_W@ULY7|bKh9Ar=BWLZ zUf{5cA?DA-$6FrT_2l*hqUXY8MieZCUtx0amIvg{UfvB#-i6@ zwTaU!J?2j2;W|I(y4pnVsBK3+eGXRlTd6}4zzpvx@HCY-fK7_bE@N#Vt6g=|kwUU&;Yu;=8OSjH; zzqHFY>dW5r?5NFgm-uB%EEn&5*BzyQ^x8j*EkS432D>^x(a~g`!|lW@nj7Yr{`1_< z8H;)~8S5Ve#%Au4;bfMWV_vK9n~@<)d=;z7ZjRu+`|2$OWEY=`HMLz8_D&P*_u{)Z%+Sh;(LadlXpR2vi17Aosnt&E7S@WKR++;`B9~6$?nvnO?I}A4mVe~ z&E$LbYK3fcDaYpv1vyGLEw)&`NPLjI!DUl(ihw~YQ^th?Mk@v&x)Lf1x zEd3?-Q^Sh&k>1@yo9j6E!;~a*L1}6vE15CRX_U@Q)NKpJCL-Yq`*^|;WN_$=^ z^-9KPkn^F{hs5vU6lVz-IpWM(vu%??cpWxT+pl za@ie2rm86TUQs-BJ?#wt3Q-`SGd}D=vQSIVV{2{K)OX*C!4- z?@IbO=hc=Lk&SK=2bcv^LX6MN&}W=?q&nk6^OK3je9!s)ePy#>Ma}U^c=cq;;af?m zB^l>RcKZj_JM4WZDytiJNaEX<)&`elO%H3Q@uX=gK31J{gz;v({8@%|lj4^&g|1~_ zXNgf+d@6N?)ncK}Pfia^7fY^^*k+<_X*th+!_2Lge^;g4dn~>ve~*xW&TWCxl%EX? z_9;|F@IvQ7MGE3TR&;D0RlCNY+IJ?d<9$Z%I z%A6Y|m&?21#+IEiN^DIgR&qBt1<%*&p84`6L$gW7--`}25MEE^a?82;_q z$i&&@*nNG1rT@%2tDlw^1SY;@x8HGl{r!{kug^8?aAps#_BhB8fA7k{C}Xz520n*g z#@Xx(#AfHP{8%uzz=o~q#gX$0_t$l_x9?$M>AXG3_EUnuNfG7Dg)h!jFj#zOYV0X( zJ@T;Tarwe8w=RFT-eZt(?A!ttS-B4r%vJImq?aW!RxRPRV9N*$V~{?@9d$zdRBF?` zwMCJF)Am^Eo#NRSl>fk%;f_%7izfYswHr6;)HW}F(r?9+AM@?*rRMrWi(=RxPJDcr zr~b!+hVUu!3j}68U^h9aeyY3bsCBB}&FMDpr-d)+cM&+cjq6~!tyP`#?)LsUc0!jA zw)e?<23t*;<*QO@+;T|7snH|Y^@xOX%|!pysfCB1Nlba#cPQT5^w{Yad55NB)-=a_oKI@Sv{uD0=g2H9M5PF}mC_k!PD!(S-Tdn?Bq*=-=~K_Q&eDd-G)$@U7r- zY0g@{VGFy4n{0^f60yyC0-6f!-pqUlCl>Q^Ppt0iHL#6ZeM)g_AbYC3UvELQQD*6y zEaj{Rho!!RefPFHwEJ1~0^Xw!GFQ$yDBGND*}$Y%k^Z41+Q7mn)^WcT+o44=;d?~v zRbMbZ5#VoN`rly2R&b`oh%J&${K(k{4;rNl8si@^iU^7G|8!KhE6Hf~Tkb1yud+i} zb_2tNL;Pv&tPzvsxT^j<5Rdxsx^F_snfXemWhECLJoWKMx3rXodInQRdF+&RQJl@{)-R8J!e0DH7)$}ql+GgqTYX=r8e&Z%2v0&3LVJKHXr9tz0W3De^z#!5{7Q3)7PfA3fYuHGTDg zn7Lf}r~ggU-QWFF%w7I(z+1KX&m>XQLUb^SzPR*}3qdxo17by+A zvZFpjzxej$dFy03CQWGJS({%a)uF|{yYrDq@tIAF3j>7(Cw`A(xmgxhxnh6J-EA|p zUVWbBhGw#SO~`6Vis{~b1G-o4b+vgBWH zqepI!<8-#Oha1`#C01`ZGWSE+p2aUj-W<<6k~l9ReL|c4Z*{$L4Y>r{jOnu6brr|$ zA71R7-Cizt+&^j=cljG%_HS=rTE@M({rG_Wy9+H!a(@%2Q3SX~BQl(s(%%459BtBeSb8h=mp|2ThI`;}z&7FDm>fXj9p9+1K z9eQi{s^Vfjg!IL%f3Gw-+GSJt2xCK+G9J3c+YP#XR}opf+ejtw^-Eezb&8mA)7U~@BG}UZ)Msam&WjA-+fr2f4Okax9gqv=DAhN zynUBC=SS}M`n6vK{!hK6bNT&|oVcka(@e^Q+W$ICf4s48_RFn#|Ci?dfAJ&xd-nIT z-$s3{XFRsA$>`nrcU7%Pu8V3)dgMyk#Wx~v>`3qa6#kF%(w5_wo^CSeJ}T&WZmG3? z-_xqbeXSXLoc^r-ayG**eQuos^V6^mW}Body-)9yn%2)eJ)+)Iwrly%8B6@Hy9tVv zhR-igWLx(=!`#629Q&rJx67+%Z?et(JF8J)>e4qyW*#=XJ7?qcldVgZH6}ipaO4o{ zYVDO7D-;VOZ-~F#di?mJ@HY$cKX!SgPuA?#*p*`<_D9DjbZhPY;)I2aOSfoSyUf1J z@cfh8dJo>x_Zf3ulZPukauY6v6M++J6TzG0%$;8KLQd{Q!?V5*g=f7mHpR0Aqy7tl09P4|GO*R_859jQ^ zG12V(i*L>{HzH$sYdu!TY=2x-=ga)QZjRZPTl@b`-IcjZ>h9AQe#|ZU4u}?S{Km1+xkl%C-N#9025mt*U1len zdDf+GNjaH)&v)W&-m07bcgiM}pLLjUGS041MYJRn%xk-J~)06WKYxevIjt*F{!u_V@q*L2&?hvp|Okc z-NFawd*!Wf-(FuDv`sqg&D*eBx8GQN%#M=bt2K13I39f|vwHby>;BJg4f?jzQ4I`_x(xFxsP5yr+hr`_og|w?p7S1|1BX#6;ESNw61;`@H8QUZ{E@+ZKYKv zPc}6QU;CH&rjOlz+jiNy=|L@uatwkG{|NAHH##>-?039Q-J`;E7n!9hCkm}{toN23 z-)C}rf9dXz_vG6D>MRv@H&2}VEGThTZ@H$Gb>VWKfGL-QzLW~Z@1Fn7rt}o|qn(rD zcRyU8y-T<8eB;lhtlUg#jBKkPF`2kFFa7w)YI}$xlg?-VEd^IsPYt=q>pIWMU$tSu zUVWFi%=VdlYcAVe`53m>ns3Jbr3+3mx1VO7yL@I&ZhpIpM|^aj@Vn}b(P9c7O5BZ6&wn6x}vw->mFZzuGc*TjRAoKG*D~T|50_ z+PB!+J@+jp{Ptkxe3j+AQ0Cd(->R=;rn83WZJ5~jednDOvRgy?m(48dPT6oZ%A9wP zP0p(PuQS%3+d0vChmqSJE1fB`{iL3jWNyiGe%oB}^7z9y*Wdrxm{tDSde`4b^&V^f zH#uc7FP7f_bXS)5qt%?tT7MJWEahI`u#`!AqqW8X;cAw7c#ojCYo?PHzQJ?Z) zxexPpzo~}>*-aMC{ysx?`(>rL--pj`5%%|-{djBj@-JU9&Fy@3%HqvVw3bY9?3FJ5 z%5Lx?ab?cs>HT^?YW{1#=&R9lSXEg$GkD)|y){SYIi-pi>C3cBpWd}~<&qDvy{8W| z=816r3yPO+WJ*1tsk0(O|Lm3QDdEg4nf^btPoFMpIef2_`ST`*gUfsc|J%5-{Rr;b zvUAOn_^#@P=aqXuaevOVs?H5`70T^nIC!b=iT8uFA{id5^%I)*p1s`tv3_1{?azdQ z19vO0Tw1j6g2AoR({{NWp4ltA)<`@)J!Wo(XwZgdtzTQ%nkpMIvtoOUW_;fLI@8bj zb;*`UmQb@Wsg0t{ig{rdo*pl|`=W2P&-uA5A1fXlJ@?G$-zEKTs%yVJFYx33{jH#G zd!Ky!;XMI+Zdm&rvRvcnwtMbf&g(0S{`@fKeY-~~?v2;}3-7*omp4m)naa@gw#4H6 zha(OG#{U*fw3%9WV)@IXch(y5cO3qsRr&BojN6{+CKfik4qNk7MXG!KK6+-a)g;YX z-r3(*-%>rxc{;;wr|w1h9lFzUXZ=guS9IR+{8x9qoz=f?U%WDVQh33aYy->hzpvQ2t$1LYx=7aU%7Ym*l5{R{zil(pJAJck zLd)LUHqWxzngk9@9jv()<;AtZG`U+G-*O{JkSXU}uU3zTpEfsmG zjf>;wWj6R;&^fq(QA?tI^Rb&=U)DvmOq%O1DV3ZoEtIqO!#*!|-^&(~AH<}-++z3r z^Jz-+GpC2A4(|Qp9WkZ!44d{0$qk&ZKfH5TGdWCh+F8*ZgX?2V4-F8>y+JfDmU)=qK2gt?nUZID zbNe>VJ@&2q&)4`%oX3(p)Yi&A)MU=h{`y#Ao}1Ovl2!X^WFAc7o@VgDedUVhoxMIg zk3Qcv#oWyFv1@SA7WG@JCFLjhHG+EET`-eyN5!Qs|KPI1Jmwo?~UF=d_eS{thOYhM$JB7MK6*AU^ z>@8Y=1RvBMV)Q<*c>DnGU7;^R97Wjzn+?kHr*o{c5YTb$QxiKhcSGr$0M(B-m;DRl z3qgT1n2-6r;MQGgaO1G7LWj$S+FREP7fR26ct7pUbXO>kNadI`^zP)rbmLKW;df z(7D#jb7AsU*?$7tEa#NIIc?$fTa>ZM??B7U3#-CWED7N&ImcN1!lnUs7Jxx0=OeG2 z)autiQZG+0oKbq`ZTl4O->J+^E~l6qby8BEKbU2jeW+*d@@8)*t90kDk(L2Su%Nc^ zKtt|A&G-)@H@LQ+JbCg!!VO=4|LqO)92XnT*qL5^NRL|}rB~qr|J=$~3l}b|Fw4Iu zld$3Mx^rA?u_B@CWmX`;h#Aaco2EJlY<5(Tc8QR#cyy%G#LiCcnQ{6#9S#;=EzaF* z942%yHcb21+tagzSK4ezueABHySvMmm%hH%I-9e-fr~|4??YBJk^=)Q6Zp0;JKn4H z;rVstN{9!;{i@e%OFld}IDvD$P`B*%AS{NEUn78NNo>une#>BimACHxs zxBb3EH+mb3gb9OAr{O|0x2}+xah{RcF(;ReVH4knH#avcvZh4+I4U0RbKd@cjaA*B z3agqQ1=>P~76=@Z6xlX=dTQ2;7M-8B_tjS4+MMn$B`fO-Iw4&6y$6S`pbB$nC|WG( zoMZHU$56nQf9Aj@whImd56le>1r-9J%a(?fP%;@3*)8aDZ7+^3ImbU;$q@ErFh*74}n^kzscc!x@$d#sVxS62I+oxW>fv z$8Wyf+JvQfds>CUgOuak8ZE;%?n$lZQ- znq1wFhY{*0mI-z|U_ANgzD8*vUr0M@%6vVA+2b!m4qKDieCu+(mMkAmW8RuqS5|&` zGTDC_$n!7fmf!QN|8ZE}=?9yD$+bggj>VQ7=Z-#@dR<4*L?GqYbYA7^@9%uK->b^r z_4nItW)3Aq7o`k^4wngMX6$&qr6zluHoF!Q6nnzZz+$t_ORc#71#;Za`DSfZc3Mf$ z<<1R0miPO9zx#5*ng6I>lG&t?P?Yo-V0l53o#&U=eYRq5#)I;IU%0=wSNPGYU!z#Y z8?F!`mTZceV`FAA%SR~e$iBYr$dwJMO)~PqOb1(y%2LBZuA_x_H}l(y&T_das!cMY zhou~swau@1)cHM3=|tMZqFx1u51;4%uaVI^+m|Hl&-Thqa7REWyxaqqfax*@0xssD z?3&KG$xcAw#JY#yb9xmVCRn%a4C|9Ud`Iih6@%?PAqqDl6~p5}VS~Wjg$arZ9WECf zE*w9;XSu@#p@Y`%b|^1v(-w$Xp|Ls^)uM74jYb9cj~lZk6hN7L0>{4R4ijPzd$3rV z7btcnl;2#t4>e}B*v~Zb%Ya-aba1Y9`LQb-jDxW0 z4GXSw>`Om>JVc?Qlr_p3HJ|DnV{C}8yc1_FkaJ(>(>zAU4i}{pf`<2Wg5F8}Q&=n5 zax&&k&nMUOGt$%3FD`P};Qo-m`qO#W3t=||&nKN~&Dwi6KJvm2-Dmj=3zp73JoTfa z`nS3__ba!>m;9N*z9YH)okhXnbEjVZl)d{g(d@oK`67?*cJEDrsZmd>CG~f&m}7p~ zU1sSg>(Xnd%9cF*aq5r7+e>#7SI1cfSQdPhDX8!Co4w@j#dCN5WnA9kDR=wf_K+Xn zn{EHSx&LyEm2XJy4(d z>~HhB6WKG>pUcjh5`0)j_nHDrHk>kTl223cSQsE7(xSbQ`&8?eh^L$PAHCyU z{V2-Ia$nj0J-2%;{`fh6YTkW#;qSu5k82mUu^Sjm=)Bavym{~ACwB{P=4#H}aN*Ip z#_vHt=T_t{ON_9rpEB`oZoA)H*XN3|+Lt@`PCdN%_T4;i(YvFHZ%6GSeHNC?%UdkB zyWd*S=yX%hxAC@#)x$qG?po#E%bi&vGyUzG^{=!~GxjfB@@U_^vMHR8dylJ3_l=Cx z%MX58_2@hQF2A_bHkR){EMYn*suLUTRIZ|uy1+qkN6@FGRqyWXyk?!Jp|$$(E{4;G zN@5;XPLyvyeDh^unbeH8%YFFEvki*M~8S_Z=GX*|HHceU(FN7>Q9e1Jej+p#Zca0 zcHQeEm)GrDy5F{@7E}@Ln8UoqSMHZ|{hW(=nfW&FPG`)1m;bW*<9oXU8!v@h$dv85 zd`?!sFhcO!`(=#gw{ON@oj#xWUBBk)OEJr~%&2|&yvpD(`;U~P*8E?$GdUKgvX)rM zX*UbpJNsvI`gyhs3ER(Ixe_AM_VyItnl(@Q_^r!L^a8$UYyP?2|Mil6;jTp%zUA|N zDEC;qEPKE6d*$0(TQds^3@$GGE%*@Omb8cCr=2MO%b;GxA3q-SxSn^I+rH`C7&GS z-aPx^Da^_nKDnJErXEy&uRFnbORZMyFV9<^;_BIpb?4dDS{+cx{dHw!@LIF?+dO}p zepu|gxpLxDuP^2An0-BNZcjK~y?gH8u)qC>8GrOUE#FglY9o*NsafqsZk071)A=9r z?in~_vllmS3AsF1OJTxRHU_5yB3)lHOG;KXESJvPp=cFm z6>&htMk()4E-g|xhUzhiUFhS^-!r`Vz-6&|oR zY-2fgW1{SUtYQ5AISUDo-yQ}eLK1A7=!z4?c3J5A75NteDVCE&pY-C zx3$-GwAXd=+th!_ySZs8tAMXBis!#?U&p`a^7iRnMa%lPO}YNJ^yTxzDQ)6UZl3xo zaxX+7W8IntzxI@;eH~2&PitPU-To+h%I-gP-*?|{WqJGI;bBIum0Ny%bxyq5(^r&Q zF177>t)g*jZfg1K8^ZIo+qHRnTiBZH-@K4u%qzcFnSN`3ef_SV&t?moAB%lWL|`z>mUaOL6NBGwC=rcHHxwC#4DclEb7ox3+Oo@j8mbE1Fh zYo;&1H%4CtRR+`gnc13-+~8x$eEenYmQ;oZpU>ORkE{K9HRJx4^6kFAG;f*7ulW*~ zcYjOiE%V&lwH&qGXP2C;-Yxqrbgd5inetOJtPWW3lK+)=ry^jAWa>-9L#Mc6IuzTYW+3EKX20aWL2SMg7^ z(ApdtIb-SEx2FsI#Ow1I_?qvOEzbg3 zvg#Jx{W9fSc(R(_^V>gF@LAKR?JXL~P4uiNADy#UKaTgv@~1w(DYInH49#NgJDuE5Hy+B9581odZ&v)3 z_zI@^e6m&|#+9YlKNw9lI#cSph5GE@{5Wne=fHQ1vEj+f6BCtRn(zPV zTa(MYjEAMOo9(#c!{6WDde8s==ehGNGp&Ffxwp6duuAT_YIA76=%1YPi|_8bdb)3R z&8&VNsS+_CcIICU+nzjDxBuz+gwy(uK$``_5u5pc-=sS`ol0>ljCyKCwGU(h1@-R6wscg}a--6_A&|7oMU{ny|3|J(h2UjHw>=EX&KML`vrx|hp; zyjW`gDEaHW>UW;ycT2;+MBb3*cr@Ka?3H`=?|plE!Y;LadYFZ_^wOUu`43B(4vIdoYdF}|#j-hZ zkE3YM|DWgU<%0YBZNEh{s9n2axHL=9?4hQG+#&rXF&oxx;r_XC?%z-MI_ukumwU~d z@Pd&Ibi=pmfd_xT-E%Kv8AGjQU z-4=ey`(LI0+fx?14JVf$ci!X2Z`{o2AkfKpV4BUJ^Z)<&H$*PmCEI85fZK$bWhdLj zmql#64GKa2kd0VKm4-Hx%w-pKeoYuJtNs>OER-n&91i#FTZEvs{7a-zop^9 zWq*6wTv>DNLzmA>a@2iUEbsgMUUfceQ`&{!F8aTNPxWtFUc*?w#&`L7y9+wuNj**% z-(SlAEa+cfk!e6d_P@ScDqsGo5n5q;KMq{85L@N-@fn1;CRbiNJX20(V=mh&;PRfwcl9< zmfU~r+`q5OBp_A((T64Bx3}-ySY-8h#qS`0c4h|2<{t~#KYR{6FVRvm!D!(fhFYDs zjCVF4;WW;^I+4d}-_*sw_IB>v>-XuL^WU`&1+Ax!@TgU3$-NJo@p8h9vJ@?ePT{$N zQ>T_|8LC?YoM#x964CluY2a`QYHe94YVa z?zxzmBTHp^uB?!WRovywTO8R|w_cX)311z| z_wIt{VTTF4N<4gP|Ojq(>BW{v=q4CIpJq}VQt{BA6xM65|CZWmxIDfC+b^h%1 z;;l~u4u|r^XtQVRx7m`J7I!E7#=IYy``Ma&c>jN||NlMJVM0O6a(yO+3;RDVJib{% zpd{*==jCVFXTy2-Td?!6y!4;x$;@NK{PmpmdzKH6%XkhbBnNY{)V^ZPzB}{oqbKag z6#airR!Z&owP8wf_1u!(3w%QqBwY6z*_U{%5aKvcV=TAPwA=V*PXkLAS5J$;-G+k) z4u1@IxKUYdUxH^d`{w%>=ko2E+Q?~jNoW1!g5{pA z;Jy_TJ}9~_-e_pb)4(KfiGi_k&u+tsX8#!L`0f7`*TkUb7)p= zdN=>Y`aAp93b&svz7l%5sQAF1_UkoAm_G@w`16pzzT;!ZS%+yqjMfF|eK}pT;&Z^f zGd_yEOXe^(>4o<%zS7FyoV9-Pp3eskbFqYPXp#I97-A!l*D7glrF3AjxE`}nM7(?J zQlX%oyj=#tj+GmfZKmGqPWmaeNb$l<#lR!|+_OqJ{af3_yuV%$oVZwc{om+vi`PFG zpD1u9e>BOnrFj!;UxEh2`dxtWSH=nJelp-n5n#k?MWy5zXRca7M!Y?V17@te`!Yd z0qsA@QXXux{z;t5w6fj5o`v_r?2p9y#tjyG+`7``*kY`Kj9uIeb`d|2Na)&r5&K?nUceyiycSxCzQNFxM&s zAI`hJF1e-n-!$v|BY%$vT<9&bJ7sde+h*pxqZy0#ESS1!!TU5DmmdeV*fVtmJv#m4 zm5oA=fxw^c{Xe?J1inOgRDJpU!@c5TV!*lGpAW&>^fOD#-CVdApDodvI+H(P(I+L* zCkvYw88cl8G&s^2A6_!KL$+?^jRyVK9vdg5F(w7H7|S-uGH_)pFz7G-^^0+h!Q7M6 z^%u07tmSAgYEPK;lA$yC`@6drC)_A?jgXqpxZrD$(u<0Z-VtTI#-=_+|#|Zu|7od zUft%?G1d?77Eb^7w!bRDPMEzea7n*p)rHD+od3&=ZO3l! zu}Ms?T4TND@APke%+`Mvu1Vf@|I(XH2mAIoP5#+Zf4tNBRNjo!J1X5Rc@GK7*FEUG zEp2n8U;a;^`i~!Vk9*B8fwra3*vVjWq5qMe%$9ft`M(!u*uDGlA@$o~hY4l-Cm8V_ zNvt|uGqHYk+5V;Wf2P#QvfVYYs(Zr`y)QYvwLave_n*bL4m$|vty}!i)BecA64`aO zI^SAK@2LJ=cChgA_7J}38+HipKm75YpKw{~|Ga}7$(pIBExx>1+~4MM;jv2M1LnV` z4j(>S?R=yi|I>@X@zl*)#(!c#s1VXo)=O22s-`d8{J+8LI}$#3>q z%2s^3?Rj74i;c^JeshZyG!`{p2uyso@WF@vbC27a*eKr^NV!`W7LOkCEm-gOExZ_oUouxZdn1Njm;D02`m*(O>DL$TjG>G zlvU(JwlK_KXnK0ZpzOkdT{6!F?>=16TQ2vh>D?Yd{eO2l6VLDdnZNmSdi9~L%N_UK z)i@z;lXh1v^@(Qnql5f530jSrtZY2?A37LU$ei$lol5NyLnkK= z3lBwy2EjYR-wzcfB%VpqVGP@RLdfZn)Txt-;wuGALKw)uR=*=ARHwe9UwcirsX-%Ih9t9vxtZOiBRpYPt@ zR=xZ9=O0H-hrRtWDa-Z4<9_?N*CGlU`*}Z|$ksm-H|>5j1Czjwe3odzp6S0YFD%|x zA-Qg=|G9Th|IhRFw<^nj9;Woze%<$&s##n7d^s{pS)~(`^)UIV!K(B$6s+ zne%eSnRn)wj@Mb;Dwmbtby-t-vu41G2`cTn0c#tXZ!qL&bG&g{#~E}df5Ot--+jyH z-L$LRo#%ZoWtn@G`{}Y*cfQWs`Zn%&u}k^9>T|V!Zm7;acK_Ojxw|e*e{-(9|Mj<< zTDy0$pFL+i&&v9|`&|9DWqY@OpS=9{?d_%)vX^=PE3u8*_QZF2C4c3l@H?r~OWw__ zx%V?ey?w3W`TcgEt&V*#*~~w$x1?ZC?LEVJXP?}>XZ_MwswVluW=Fp7CGmeg8l15B z{#pNb%I+Tv3p4E--d6qW=&QfTAn+ypa9qURJ$5WCwOe1@7qppw{{K&tIdZ}6=O(t! zIq4$aZ1>XotH0m(FFexmQlEFmsomMWwX^u*A>qA0+z%I;y^A})vtG_RUFG-d#n=Cr z#_vgwDLwZ!mY@T~;Kesgac=gR?)t@ZPZU*_uI2fF^xj3y*a+`zGw2i!t zx&ddH?)_X>eQm?recR@i`!arDmtvA**v$3f?D79nz7w?@ZJPNb8N?EfETn++e`m$omPF)(4P0VcJ%R-V4g1_LFhA}YLKiTfDcl|_zSmnph zoi|=F-hMQFZ??^kBh{Zu*L|MFcB|q+?tRO$8CKQzjJMTX7W4lzhkF6j>o>_e&hIhl zvW+geP;qYJy^CyVSyx+Un%`UT4?W-->B>d~*Bke60jW)-Z z=;vPCWim<8Hplw;%r~e0J$Wv_Pssk_l4j3$k9-r$+A@|D`m) znclJ+-1g5;NY_VyPdASKbJI)bq_)w+{OAc@9@)uk!i2wAxC)+mNe&>nR zaue=z-@L+_YjtDM^Gc(KsZ;08d9(cHU~f? z&A;=_dA{D2?na;OtG1<_)2o=QZTH0Fqj%c%p3K!>kNmB_bh)-pIDE}U&gzHeZ#((+ zm2B_tzcF)@!d#zkw)f4Vw#_rV@KWy22Q_!oOLfmbC4RBZmS6j2+tcMWQ|FZA9=UD# zBg^J9!nu;+6O5{g*$mCz&0PHY-TPZ5xAt5w^-NppYsh@y zPqgQ~ob3)5_GWk+GbkH+VgHUym=%oYjiz%Bco;lx6>dE=B;H+Cp znNQgF4Z9;uUgS)gIrm2I+z;y3l{vB7kE+jmY4f(Nt|Zp{);jjb_O|ZwW~%b{H}Tf5 z<}6vr{`2ISXE}~+(fghR+uu&m-n81XF(Y2@-Lzj!9KX1ewoS{gSnL@8{nGVtZifr+ zSML9P_x-x(FKaR{tc-Y}u9|YzJfr(%X85RcAlq<|0i_YR7^ZNP3P&n8_$;4 zOwIZDJ?EE2`@9O>>o*Th*N85>w0|EX%dh*blP(^)zQ+E?llSol6x#O`_4d^`s1;4< zT=Pfy`HB2<8*S%Z|F-FT-R1h5Q}|yy<{V#kJfCI$foz^L8+z`EB)A>Rm)^~kX|*c* z_S$q&_s06|BF5*cc{mp7ZV+`n$lDPq$ii~|`Da&!4tM35b7udJ4ew#)uVgr&D-a?h zm2&X@|NX)OU(T_*KXYjhxz*cinYnSQ`X+?E4e6jcKzp%d%jKiU321G&YFVj9xpQOr6)Jb zp5!ypytizbByU-=v>CTXhkVIr)!Cx@IS1?-4Y$Z#m$^Bmc9Y=j8}kqE{B*mrm)|~k z&FxR~Kfg2m$?&%3kbR26^w&?m&tY3ucv7>W{oOp#Uxgd?^2x3Nyi0#C zbK~$Nzm%ddlRJlYK9q7ke~s{>S6%1?_)5Xl4Iz zd0y;Cj{C>n^@-N02X5Og+odt@L#lhUv4h6?pB;J?7w=Bf`Qs>8d176f_VyZ!)YD>5 z94D_UlB@qFrhHN%Y!35}zcpQRpQu!+)m406eZTI}X|-7O#nr1;rR6}@{N3Bk@gprVgf7-e?J?h1hViNWxGi! z%=-7iC3(yGKrO3x3$3lgPKfw*^8D}&Q4rp-WcvAYqW0Ifee>7*b5iWZA%Dfi(-$o| zaKYd3Sx#zoK^6Pp)ZnPnRx!-J1S~|F`C&M^2MXUe4c}d$Xr5W$9w2Tqgfn zR=+p&rr%^c@llv_qf*+1uKQ9}|K)_AnI$8~rm1s2Slj$k7rOaE=?eSbl% zU(^1^^}YXQ>a1?umNo73mpx0Af8LyNC$8(M!OoK%dbT&YYK@LL^Cm|BIWbq}=BdKp zZ?fcl%?^0~+rS-fb^LqE!TvQrJ_^^pQJi;#qR=th!mgXxA=LyulCV{6F;RLOGMocuIAv%ao`aMIrDt^ z!;{PZro4_|QeRxWtZ9LOhMO?Qq~@M=OXVYf^)C4DzW$loL6(J2rX65(WDOCrjz8#r zT%|o_?FuiS&K&MPU(WB;sOaj>o+MGfd19Qbc1~C4p{C_)kFD9EWs(xuz+0rPHml`P z>ZNubE{UH#C!G&5TB*)W>MWbj{PVn_WsGunx=+n!W%(Hu8WaAk-eA2o8;{r{^4!6 z=PB`Me(KcS zrhV+lLQlSJT4GPcV^13ww$Aqy|CVUI$#-|=i$726iX@+$%9C9${_g+eKPMgJHho?$ zs`eLNj!(1w z57!)G%h@cO;y8WH{~yQguhs55yDmkz{>5hb$Vt9AUyLUCR-G&SUGXg2P>KBszr*S4 zHF5^W{9_+XesQ|~ql^8w6>@&R9-Y{n_UA?0z8gmt$80T)IrB+&e}{2VhxQk#qhd2} zOw#Srjov!@%oEY*Z#PdAziCj5@8pg@^hCxXPt<=QvSX+|3&nf?FVoGmZ&nOpjS zV%Z0^{v9X7tENA{W9`1}b*0HSvq`!;WoExQv_0q4^rDA9Oy*3TmvH*TF`q~0Zi?wl zTI=#M=FRT=KiA!4;^OLi@Z84X!@~OOsnkgU+PLcD#?5VR zdfGv=9M7i(N1H4^v)=CvE<$Fgs zq&I2*->~-i%fo4=CLfdJZGXQxD)(M@wPDRkyEjUC9}=CvxhU`65XoFyb3!ri<)i*> zNAxRCLAF$!!T0vKPdD>t<#aoLIvM#tW9JX0)z6RY$Sye<17gaqZnrGd}b3*G&WA9XTwp1qdoLei$L6zEc3fq|E0PoaNQ6y|B@s>`OM3+{=6HT)#WFtIvme)VEy&T_wJtPA{pO3pG|k? zH9j!aZhFJdvPwQo`sYFJ!jh9MdcTT-_e?zb{>qI$*;xI1pV}XP$)11y#&73ad_iz zpTe*|)%yZ-PTFq_%DEW5rhD+ zwj+WuJodf%3dId;6SXyO#h1VPZ#;kQbJjg=3p)zurF_u5wlBBy_{j{8s#f==Ot-&o zA8z0O_bp06rTJl;V@$&NhIey*pO}+ln$$W=<_QziZ<9q9lJAx;e=;egZZ_iFzD<0n8_xWYo{5fxOFR9AST4rA9Dr4X3p6L0_^ZdR?OC2@Vb;OHUDd*c9;PwI zy*W+$e*1hYv5)?2e&E2pS-oxvuRkw(owg-svEcgWH!ku2c+q~RWc&GhH}Be(Ff8!d z#>=s3y~O1Y4JBs6$w_UtIh${939Z@{wr9cGpPy3yFPZe`!*RwW58+g0<^7u{S`?pg zpH+KSVgYl)4-o|w?${GLayMd&AMC&*| z*b}LnCmz>To)G)7S##H?z%v`gEidw^Y&hOC`{nN+x69&q9|~{Vyp(zG3&wzqIbpMy zqLa>VzPUG|=v=|R+OjKmeooZA$`Gy4^@c(5=E-ccMgHe%;CmYbYAe`nsG8)6Ph@7d*RHmu9|wff16N!!IucS=-zJ73Ys zYvwXv?_~eJ=NB^O^BxiVc~ztC+x}qYUmw-o%@#6$NMe<$HGGoY^TSTp@aS~5S&web z*t6R6mErsc2lXpHO%9FT=q~sD!R$5K8=u<$l)URXJO9P3{u`lxI<)^;%|D-AS0(t! zdaLi62i|=D`IcC%s_Xdq<(Rm?ab0fg;?>zD?&s?)-|ngqyq+{C{|bj`tj-nZWoy;m z{#dkmxue@AQ<>Q{N7>i~&KUV`NsVa?OHBGBba<;}k=w}~d+lVe7rztyz_oWtIFCx| ze!(eAez?z;5zTW=V{)vwT7QtMX0gJzKQ`O?<33$jUMn|sEcmpNs7 zB?Z2ed6qdGR+lT%+;Owju50Sb6^|B1YHT~FDU~CYYc=s}9^DzgoxdR0FrAN`w?XxeQ1#`^ufjFkM<472*{jT+a?V*Z`pty^m|FL^>_aQK0n zk&O9Qr^eoxFIU64;^N(`h@&&kFf_Y8V0E%taDBn$cpX1p4GmV1!s$r)7-onq!3!nXO_fkLKHMPy{ zNPXD(yX!lEZWNk3KZ+?^C_xr^AB{s?P{}p-i ze7$*3?8MarH~r>4431fN`$+Yz$uSJ`Z6=GqyjWNE&|bKH3j_O?j~n0bxmlZ{Cx69m z*Qe%~!@+A-#`mSyEO=U{&oOKNjSSZSn<@P_4eBzwJiq=3-~a3CtMfl+=NfI6lw@jp zbk@IQP1Wc3x()$7jE--A;>I@+^;?AU&zXnpdYt2Sop`VJLw4GPwkf9#uyjl+N7e*meBCW|qq} zB9aHziyrj;-?!j7OWVcIuMd8j|D?>$mZ^!WiET*$L(|`l911V$oE-yZoLHFXq4nG* z+If1*xy*U0cE2}h?i5k`9=71cES(AqH*tAa|HoGr?E85(f1RtF)8hGh^D-~EUStlq z5k7Ha)MCerxqPjB{0X z9~+-BM06x>;r4h#=XzG zk~eLXv~u8*{c&yis@<$_J}(zN{bLEc?1zgU4XTEUeJ}Z^oM>i~OA-|j+5JRGSm3=) zRLX^b>M$Edwv&!@eKirdlu)+B7(vF7tK>C7fKWELct|9q1! z^hH^_;jz`OA1TJs%GI|vF;~xw%lH|ZtX{usE&tvB%VQL*<=$u?TmJv#$@f{VMUQjE zlGn}rGW+`l-?{~y0$&!D$2FW>fcwz&B64$-22a09jlzhecO~WemBeiN$Ab~_(U$5o8@DI z_}4w_B}yJk+kBOK;P}Vv#{7JrZQANb9coVWn$7R_w)wHrvHtsN->lWMo_^M`-njQ< zdc}GF!ztR=k7~)~gw46Q-qA1kubOgY?%mV-zBSreF3bBg)hZ#eQP=kRjDPR%$Ze0d zl$~9Ywwjsa-No$u37!Whewh?_nNe$-c9TcJ7KQK^tXowk2QWI$w-PDnd>*%WQQG~T zee$=&9a1i~oLE?pk<&Ff?a2R& zJW^cJ3=iM#y3diC{LSG0(FFcYofE^{)diLaSAX!Iy!NG|TUn8vy!G+89KCs6sjPl; z7NpEZV0N1v`q)Y-FjHYZfYPCVJXRotRC+U9bo&kE*w537wHaC4k;uG$uLcwSQ5+Y^n; zDx4NeI8XNdm~OqzX}A9=hK3zZ-D}<%zEIj#(e|WfUnH1ZX z&b#63ZPaD{ zh4Gsm_w9M&3LW!bzngt{bBgMA@xAl^|9PIxv*I-G_XXa536X0$_2^ zKV9aW)UCPG+<)?0P4DuGMcpqYat%+&XMAqHcfh^ovCLkc!V~B0IJ@OPp1=O-j^Y1q z^};;YxPKGY#!bn&>R7T_arXpaUcx-O1}&El>Dfb}uI0RB29s;S(0^Th$c4N&80IvGMnq7gPnm}c)d zUL)>&F#UOSgTl=tjPq}bYj+v`-fa9kLqN2`j49$q``w$)&DUCfO!~`Hs2X;};`ieA zzC8lQVO9R#%%!~X49U-!t;(4>s(xPVFg1%ddT{XH6ZiOJm(x3?R>trp?BwTMl-}zvq5@W^mk^!gR2~O0u!;)4X?$3jgQaXJA>q{mtj^`~TN|<(|tF{YdNf$@Fh# zFOOY+B{AW&dD1=0f6n21x~lC0_RF4D+^1$xW;?SBL&3k^r zl4VRH0$YBqbYN`a>RjgDmh$<|bJnJ{0bibJ928M+<&*e$oTba`rs-ZTkw_7B-n~J|5sGr^Gx7=XNWjJYgVd2jQ5BG6d&1TzG zE5*iil+Qu#gMj{%tPk^#`R9F`?;y}{h&k5KZ+cClef8zuHEo|OMEO54K42C)!gAp8 z95(H^2IF0kol~kAwRpp7GOqC&EjU`X{CAqx`%~=KKcwvXMFNm<<_t@lLGA)^v4&f*PmScZ=v@2s{&hMjbA>Ji~jRcU2V?m zRFk{$r>6O?E=?)R*>swbCB94CyvQr$s4wGJw(>0H<&$)>6I!mL&5dYL7X*lYF#UYodZ<^1d}(Uv)%YA3pzKzOF#X0d)bD z-N*c=acyQhAKzs-^Y@a&+qtY3tTEhi+~f%3ZU(QM^Y2XMd7IWB4Ltn!$A|gP8qDgu ze7D@>(chL-zp3-&?xX!uQ4RsZOj8>8b}iyQvSYr!)`@RF?@nQ^==QFBAY&P|R+zow zH0N2fs<3q*KYeEHjnX|Z|NY~$>r?#Lt1j^CZhT;KFKMwvLiPFCIY+|21Sa2@v@YkQ ze~yE>%?rhECvV8BcRmk0^)hEeW1IX9fz3}h+n-a~Z=qp-;;`JCrn&@Y*~63la@y@; zPb5EZEZcHKQufE`x`u0}RgYTxHO+m@#F_Vs%$Yvbr1I6Q-_I6It_kVBk*=@Z)X(Tx zH?!)AzvW@QEb;mk&*KspGrmumKQEQvP`l3Wd%|V02PM7dZ)ndyqRgN%?*jXuy*IWb z>E|EOkc!j$;b8Y;ug4nonBnX6QmpD&c!o3!rb z?(j#P5v`7bfhR--Px3irgnSca%3u91GefRRw&7*_ajt1htZBEUh_g~-cs$|8YNsS zmL0d-ww5jP0@ti%W(V8;p3}^EacG7CQaHg@bJQ(tg9+Pw-?g(o z8UEg&XnVQ!Ma}}t4#8fZI}EaqTIV0_33L?6|Is12;Eu@TSu1O!zi+Uu_EqT6GY}Kl zvUGLzj{|>GPCtL+UsicxmCXLroEuki?z(38_r}4>=KE`Px)+C^ejc(XdkMpY*MCl` z9oRTS!g)BYp<~hu7<0 zo$PIYSa;U?KEq4X0{f!}ggtU5=*w>w-Ib)Ea3b%`lYLoj={M*1?A2gw`g16pk=3l& z|C?8T$;L|>=brqiJnrzpzy8-{uBsOv@`Y~GqZ<_BH%T5~ci70QpmFX=PjZ>ozoXp0 z-kg7*qpI&~8Nxf??&F@5|NrQjUv;&qZd7W2Sy{*W>xaYo52@}v-OPXPEysz@@+r&+ zjk^){f%}W?dXB2o!8xi`oF~rAYJ4)Sr)%d+UH?hhyJjsuBD|zma?6)%M;bY7MATc4 zyy|FL&tZ096B9>5?d$0KQNnS8fjdO1uB*?#r^jfz={^%n?XDRP6L`2L99#Tg;%)V5 z2l@|*=d$_E@Lq}1xobas)@e|QQxmvS)8ONK)#bK_-SJ2K7MGuV zU?@4#pKQ0>`0kIs^B;_5Kd+Av{VruMz%XZHqHn+7AD_67rBPvlM>HIi#cxcu%b3i4 z_tTV`qsxkmycU1W&wBLzx&8mj+&h0X#BUy~eQ~7Uujuyw;5**D_b;BbeaFhQS7qZ= zn>71>%h_dL%s6}D34cORAB)+q#p+d0%B#*enr*qFXm!Hcuwnatt5D~c5ACWZ_wU{2 z5OC+DufFoSo%wu!ZoZ6N&vD81-;Z8}56kXti2t{Pm19$L`p>4hdr}yltzGu(QG;IW z)2@^HkHY?R>F=}D-FVFZ(fS+rZ*j^06Wjc!pZ#{Fq5^yUNoJE53VBbDfp%buraWr2 zk38X0{_}0C2hYd+)idIHjxfxh=w5ev?`I~aqsv3nYMtste}CI=~z)4+rehNeNSCvUIZZh!QY-Mn>~KEc}>613U2GdOPYSLj&B zv}8t=_fvf{#t2bc2gQ3`bDued{by-cTDl_ZTGzt0i;kN~%}q*uePdsCPVzRX195G? zXRSZK=bvuW`MXhX7Jb}yJGyZ}(;CJZTs!<-!k!=DH{ej&5TE?&@V++(`K6Y)ExY*R z?qs*;!L{E$$;4%3@*HSADZedj{t?~@2|MB$McW$|{CFH+v(3Ta=8ZXf{-}xV<;h%f zRIS#;_Mb|7b$aopNt6D*xMZL3cl!Q6sjSz|UA(CxANf?8LG@juWMS+48^^V)Z+6Wu z>E`=a(G~yyJJ&}Zfv)5~bHe)>;y$H1|2z=)Z>5mgmP?+`ldcvQJ;-Cc6gT0*>!qFk zA5uEEpUHevo!!TjHr3GckZW3$(SO<+w~q$yJx^P73oi(hOzwe`8^ z!RUqszm)PBq72V1`*QaApOb!%B4TDcgc|DhA88Hj=~|vO?Z>3$pIq0ivM&DM{O1kx zv$!iy`f4i|e`9KTwMXWF`k| zbv;nTxr+a$dl;rac0ZdF8LP19PjSH47 zVaya+zH~-(>BSUnAEB!^*z%r>Xtz2QPI|F6B;px+5nH!qF-(#8v4>YcM80NiquFwALpK5i$}u(lh|;Wzdi4l) z7Qg}jeT*#!))!0Z&b)D>_D7dx%@1CI6z5-?)aU;2n!6*~Az^hxSo0H>T^Xz_FV8;< zYq`QvSrb*$zfC65+iZ67FJb+vkH(dZY}=Te{w8+Snm%P{`oH(s6p2Ui{}@;rOYENO z*JXy(KUw_aY5dpz{-2&U;iqkbbA{xWCGTUfIoc>{d)a%_uXEuQ9jgD>|6Osm&(3h= zpW9}~%rQw^z@4~?qPPTKU9GA*|{^G#>G}bMTGY{{SuRp)9d*Q*)6Q{R2 z7}~S3m@@cU?tF1Dy_QeR{E-Wf=8HFO-;(C-W0bOUIKI)sbgjjY`-LZE=Q|wXVMyK~ zZ>z68i;p37tMj@DS4HM%@#*s}>%2@1O7H*4?nz-FPGa+Y_exXWiRM z7RX0Ex-=zy*1R8^Ho3BW%&zF`DM?WOwrP@<-N&t>;SM2(|3*tcnr(aY+^KCA&-8;o zFD*eZ4VOXq(N*#Euz-_|m3PlEo})xR(L z@oh}DI38Xi5dY~`_Y!fY(#f`skwv@3eeDiSKmYyDai#vX9GBdA1O5HF-!{sAoxs~T z|81AT@6G+<+}c};SZeForkxfxOD!(>d#0iPsOkJ}OVfbb)YFznF59TbeKq>>b~X2_ zMY}TN=L*+9y0S{YE^f}7Zsj_+^H=yUKJ?$}I;ShV&TTa-)0Zn@!T*1M?62Q*Oz`%J zTC>@Q4R_97C#wFf+xqv(r272i?B8D$>vtB`NZp%#{hq@4dyNlb1Vd81#W++5Ytxs25D^nrt%R4sDhe4{6+#8K+zM5vGp)Fx`KW8bqf>TjGflOQ zUfc41Pr9h(@ruQc_0gM^(xaP~e7|!4V{yN(z?A}~rf>R;jvo_EPjfemDkeyJ7{AQ9 z@<(=gaP+>Z#!1Zm_J1DoXHWhdZC=N=LF?VTbaRCU{yh#Ak(W$P9Q^n3fjvW8y*zW% zQN!KQN1udi$283U@jcr8Ps6q^H-9zOl?1Huo#KNcSLdoh1n1^clN z$AaxT#5XGavoV&QCsC*u_3om_?~^U!(%QQkoy=G^b*1k4xTL>cXJ(zS#svRA>`8la zET?IgXzSl`*ZX+>{ZGfg4zp!%hSZ#&==bHsx0eon`YRds+`qa}mcg)5q3X|>|8XA} z99RE){?t6R$hXGDd|!_0{hy9Hdsgq4I@k8O-}Qx4{I+Ugff9dbosUb!RrSS+TF+k% zEz>^!;v8GfLA9`JKU`{9nXc-77j^zPBf9eV^%tAx{xyUQ zFJ^N5$IEfbzp~LT_Grs58G%0+`|G~QD|Fo7;=buzOhMi~VTrr*-rwAtv%Stkz3>qG zpK6AKdn;ahS;h$oghXg52%U)D`|Ju=cWwS8u5K0a8OMCKol&Y_bevzQCh%pp{sZBT z0^dXf5&rzD1M}O~8QQV2s4^?8;F$C~O5w$15A7zY4yVNxnk6ZhWG;N(#RUWJ|Q!;$9m7w$7TGB`VLeROocn&gG0+){BKFOD z_zknf3Fd!HOByWdrZlgMUa7c$8864F^ev_(yOy?B{$F8i?~%!GKM7Yo>bAeat*=<~B=x~*9+sn`(KUZQ9@n1nb>=ni zKJk=qC->)^+V8mo7y)=%eGofQ3M z*YF_DrnFf`pOYg?K-ET6l*e=V0_{zGrfNr>6U8^QEy)kLkt@pU>iPJC*_w)!b@-b0wxPcdxhqvtXLAFnuEIK@40*4krv z8Fo*Yj7)P}Z+9vDj;NiJfBVU@WM}83_HA5KA}?mfPYgLCqkW`e`>Lf8v+X8o-wW%w zAydJVuxR?(M}K3Yzb!D1W?}g$IDw&vf$_V^3qB7PmbE;rEZG+C&gNZin_E0r_9^d! zG*u4$`rOx(Q+k5~P3~&j-QbS@xG0gqDCgw8jO?g+{2WoTyIEL1i+^B>U~*HGh8G`@ZkHyuy!rf4O=8o88Hm+Lp6N_RrftbLMu(n`KJ(W=y`V zUib0H{$CSzDcLh`nx|?lkTGxi`CI>Hcs<-sg_htShd*c`5nS z{Iw^~Z)X>{)4e=zLh^ct0LMuUps56g32gC+>ns_SyRudnPZH7ytV!RH=c`mFf8c&19^_vHa-)H4CDg+1$yqR3% zFd?pl@j%V3EnRFJUBX4Xr}0kO&vqy-=TP6di-Gqtau^s4zGnRl-1F@Ea?S6l;a`rP z7vtEZUjN{yd8{*-OrS zE4C&z=s)XPAmt%m@`K_0Wg+foEKOnE7qd5TM*sPBeScj1l?!D$-_E=_t6y`-&Tjf< z?$`^(YcKwNd04#npOa1^G;l~VrQO5hI64w>}IPKoEceN@&d`C3=Hf=BKfPe z9bP9Zq^SOJ`Clomz~KPO(2Pwb+zOZXwymFV-DESr^v*g?4yKld1?d+~_B9wuGtLjQ zVh|`|VVT)npU2o#^I-n14NBE<4GG%OKPFu5I^xW%zcKOa#Z?P989EfT%^f239dizt zN!crC*sbMwq;KYX{qFRAn;Fye%~nfJ_6}yfcBIhZg8jiuT?v~Ox4JuQ5Vtd$z?omR zy^5J*(ZWLJ#<*E0T-qMZxbx>+o}FuyA`i!-qj|yoDQ<_qmK5v!V_^OBH|&c2R3?`P zxfdesPDt)!6JT)s`FERx!M_*X+71FQxH+nJeiYI?cckg}$tS69P9^h(FG4Sa5$k zV^i33hNfB34*l;$-%F{+-dNuByvm{A-)BQcM>{8V>+BnEo~{qQ$-%I3SL^n)^onOu z3Las+8S6Mcb*iqm{KnJ$_c4~H zxI;%a*zwuTxj8PeRtO0SLV)-J{okH{R@MW!qhbf8m{UwI67W8Shi>KvEX<1 ztO7Z%AA|&!I=eONG&-aFP0pt8I?tAtB|CYK6yqCJL z)*-<7Tj%BH4)d@4Xs~Da_{Su7?wcnIgSDG#rQSVfwd3uc+upF?{H)q(NBxDxg`eeY zyZry{=kVWQ;ZcHLF7s>OY*4uOsPxqBt_9~0g{iD<=roN^IJj!jRA~nTsl6N%Pm0{H z;YneTe)Bw7ZZ~67?Wx7bo$b!g%b3`2SMh20e2yR8sXI0Fd3SxsPxC6=5O4itbzda^r4#$UwEuN&kM$p1fJAJ-IFP5 z(r0d3%h6T5X~9XmH?jgbt`qcfT+OdxI85 z3BSWwew*;9sF#2Djnl8SzrVCSd2&2Ic&z&yL(^}jriQ8K7SdT)}1N8nf_P z#UG1%`5LCK4+0j4o?#S@esJM$!veSPOI``jRX5aL*SeN;xc1ytnUf1oWUdOcKC!Z3 z{&aukFl7JNN`=gx1dRmwTaW^cAX)ipqwjm1>SA;6e5k_#na#YJ@l#Ds-qRyolgAar?~- z|2;Op7TcF?+|_9}zeD%%U$)q1*Y;)q)Tx}ix^CyQoo{-U*Y4X^s=K=)kLjQtZ}i0! z{-0;#Y|R@J{;z+?$+CTuRo%*FdP(r6?>9NL&K_TW5f5|;%6Ni=XI(^ zsw`_;+>yyPYc|soNy~3y>KZ+{8%k`LGv6^Aq)hCPnv|Qr@_+ol2$#j7A&fc`O6Aj0Tq797q6bS@-QC!_fu41-7&qs2AN%qO%<1Ko?5U& zdG>VqqThw}4gq@&UUtdH-f*#FWjU%N%i!2>=4*DNLj6fqhY7rUIT)I*{V^y8QRWjY~(xYCk4VI{e|y zT89g#k5)2nm>$M*aSkNzZftsZBc*=Zy8kDV{~uS~e>+rq@0{J|GiK*67LC1L%NbB! z)B5B6)80q*_1`wnUwc3y{dmdm0v>_KIR{k>l$ZU8s+(pab-*xgeU6O7hx%)xg1jHP z|E*4(-^RMniNir-5~E|`+6|JTdcQv@PGINB3fLw!srEKQm&?}mKiGfBu>V>k^G!4I zlN)>f&-VJ(vm5VB@}IS8WykDK{XKW1nk$Y5^{Lf&$}iqW7-?* z+&LvLX&YelBHttKu#bi)sC*cy5-D84q0R z{``nI%zmuuXK|d*g!%nHC-#5b!Zk(iT<7KE4GDF}q~j0o49od@(Chz#E%$FT<|pOd z5_oY%c4al{khogMC~>q zX0_NG{1!PZER1R2jtleaEB@IKE6CFKRdjW?L)CwFm3WOKafJun!lam+ik$y0V7|L& zLFj9n$@wQjd!Fzge=)n}!D$A2OSi)!tBVA4H!8embgJRmq9*WWet+eQ%LdUEI}_R) z5-bnC3%)n?;PeOf(e@T*PiNFvH$31j+2mBfaPTja<54b!H48%iY;#?fGAIAYyQy=! z7T(;k1S1H$*wk*llO}#uHR^T z|7-TPl)w+`|C+4fWJoyBQa}0J^2ATfj5$8nN)FH8`>b%2)%msqJ)-^pWF5~=?tSqr zu6OxWhq@z^bJtX5%=vNciAX@%{eRX?aefS2bNclTFfp*PFiP1SXug|Wb#nJs)t^6w z3$A|oz`($uu{vrW--Yv^Umo;hxS9F0R^oT&m2Ye9GMA(=|JBVuepDm2OPBYWO844O zmW>^42meWF|6NnY_%Y|joVGr_15NXu*V?5X|01OP!GG{{1p#zTBTjscmm6CO7JTNMSBHaXu{PxZfiw`K^j_ zU&21i{eGT&qE{`tL%!_&eZds*y28JwEtbh|iu`BM@PPa4j-&#HgVUK=RBxFHroRY% zq8+kMbJx6J3)|J5Gi%=OIh11+=Cb!Jv+1lkhgPlJ_0IR6t*FHpk-*jf#_wk94QAcj z!mOI&xh_Su9TJWC%q)xstBnruC~(+h7JOL{zU!g?e$DvbISW4i_pz-EzsRpFkNFd+dg%JK^MNOr3?e2T zn{CUphf!m7zg_G1U=arwWB2gG>30cHLlc#C5*hNfM?(&Nb6a!LijB{d$5T!=`fS8U zYyJGswbv|lwOxNOvv=v&iGB!ecxo^D(fj(Y=f1b28x?j>@SS`mqekwUh)KZN_BC&g zhPC}IQC5-@g^%IUKi&g(0_5c4zsP3ZE>^BY@ex)yJ)l=w@Q^?rB zDS7cz(8J3H(I1R!pFCKy+wP0%5B~YSdp{}vUy;l%P}AsV*YIH9zbp%d6%(>W!q$iw zdM;a7x%=s6hjyhGJ08XbKi(*`G;qeee2=8fNja~pY)s62odmB0yq{*TcHs$w!h(g% z9{p=r&~~9~f!adP%q!JQO(_?3OzX9!{{3(;-n?m{<%Y?ReC>~(t!v(UWB%HkEwU!( z!q>;Gov&6q>59Up-e+$03Wr%N*1BYgFf1(2nWCS^+LXe_!Q>&OHla;zr>~X7?L&7h zcV&Dt&8d559{b0hQRMaqQ-cK;S=ml5*x7a2`_B;%t4H4c+cv*q`LS_+?pbG@O$(pD zXwcvNapn)EdoQw5`|Uqo*}>?dG$e)!Y1-q069A;`_5n{Px24b;kD0 zf8r)x*nIx^r>Xld>P$P~vYze#C(DMH=J$TO`#exS)|j;M$o>@8du!&MQr>Ctl9lD= z5>dy(R=p@j$MY;KPaFLYr_6Vla3_A-!Su^fl9&J^e)4cStq(^bQu|hY~)9-fMxH^@%88m;KT+I0(T{12( z^oK}^>*3ooTKey+UVpHfvFh;R)h^p>-}JkR@HQM=u6i{5(0s8Ai%)EDXO7oqp0)Cs zLs`|A@Ya&W?z_JKsf-L=eelxp${G>j@7hi^SDyDZbbh{=RG-iwD`L^QyUk%==H!%u zdA7XIKLng$Zb~|ASO0-=-w)3kUp{@i4A+2Wh4u(X@$oSKGJZD3zgXP2QZmE;W_4f8ljq5W z$HKO~dB*DbhtV?W$me;RS+6jpngvb_oPHay^#Bq?7x zUnc36hF+JsRY$tQWo|xct2ARP|2jrT)9GiAC@`ojzq0zJb>&LG%Em2D*{^ipu;heo zzF}gWD*xpN8~^0}NA6E)*PB$n!0 ze|RqQWCdpoGs{cOJX2POhT0z&xEil2+7 z{^Hd1AHR>c{C>Xp$($X^@%xU*%g=9n`8ZfN`q6y9A3M)qOPQ`_&E)g%VR~Vz_Oz$7 zGArEPbjSAIULK=g%dq}W!MwLGJjHiT%fGSCe~v@d^;L;Ar`a1+q)%n;d?suj7dP)k z*S3`#FV44n!&0)U`;W@@+^6z$pD5YhO|RH@tKoU(Np6PryXU<3E?NBgo$-l|{zkv~ zZT3GNG@I_*<6(7QAo-oT{>{e1lB1hvO#c2Zkl!YJ&Q1OcY%D+H>$>x+F6_RM@c50| zz8^}vPgXi)tmBx(Ut5+SUVAhvYX13;A?z2;UnFc2yl{N~A07W$KQ6WM@t&V7tou{R z|3gRmzQyY$QnSB2Rf(P$%afvB@=|O2O~<;~kAnX`&i<&P{=;X^r0zRaO;-c8ALl%l z*}uW|?w#(kU9To*%=l?CYg@|uonP*ro+g))V`0{d{B(gKM^YUfUx2qG`_O zoV}G^ajgCmymmB2Fp9nDnxQg@fng@olOHP^6(mj6d_9}YR5};&b}%Y(3I3Cs^d#8l zM9vMbBbIZ7H!wP$Wq$GTq?UrlL)&z(EY80EWgkNv0-Pp>PrUTPgv&RKk;UsqSX1T# zMpn*cFEYIvCM-%-S+2Hx$HIerT;_6JKXZyyH-BcE-NC-a)cnCz-w(VqK0C7B`TJwS z#dN{e3mcQV;}x=0|MC16oV}gF@z=IhNAE3PYWR6&rYP%#zyn7&{74dyu6lI%U5>8W zO~*4CS$__sb#1TaEt{tN>9BW~I7jq9f#pA$|8iyg`)lJcq3+9>?I}A&exKXjzUNKH z^0eHget%BaTQNp_xzuvmH<;Dr#goswk_{cqzt7BRU!Tsvv{R*Rtx)C_2dQ60vtv&t zNaZlaoG{eZYf$*ru>Q|u^(~X-?=sB)b=1Cw*IL)0vr_Y4mrQVG`^mss*<)tsus~+|>n{bi@e?P$Yx~>qpk2Q1M|}C| zZng={WpyWxCGql?-h6-W$=(^$y4O8))HC_a8hO!&otq&`=kJ}z_evI8?|ji9HhW<| zzrj)Wq(r{+vmTu|z4+cE)o9s`QLiInmKs-Y-u+8AzoB^R+_N8&w0B8-F~6v;E!Uvq z5b^%e=XZzQZ94r6xj81?{J&b-{`#uWc@u9Z3Hk1GTYcZ^lj-e`Gd25e-0NO)HOnmM zKSOb8i{GclzdpY!Ebm)>5@mjqu%Y{J-}TAXKl!Cq^(SsBE?rZTaG06n-I2_EA!UUd z(X*Noo_bAWV^NWImu8AE;wtLo>|ka2d(Vl9jdnOs*+jhI9$nOAClhkCl6$>)tOx3STO^QtnTJXyxX5*wQ zUEzOTG?^JJHJlh7c=3;jcK%GEy}zsDiZ7@z@l|L&t6|B}Sn%ec-ddAK2h-U0m6(fK zv5N541uodcEg$y7<~X}r{AWf7A%Q2{Ws2sKFRms8+uX2KSh3S8?8%AGbCfHOYFc+E zmR-BBX?Jx`%EqO;o9=i`n~_*-csB1`ck;JK>aDZ*eSHtTGW?yf=-ku!FN4pY5?)<8 zi^V{>j)^TrpBL~N)&oP25$4vK>Ff!bTy?lMj(OwJ2ISdD-e5~?o1MZa0ecyOM zYTmQwGv*!O_%Myvc5>d2lZ+eJi!ms@dA4I&@3t9Q+jCzoKG&iCTT1)(%%rY-lbml% zW_u(as+xZ|XfJyr^v$+gH@x@)PRDr`{-|kmNuW9{+C29-ju6>~|cOy2Z zGuf(xed8M&yPGFICrw-XWUB?A&g9v1Uo`Hk{eHZA?S}yWPrmcpes;^S?X`VvX?B>| ze}3*&{eOb-Io;2{a7Ry^$$v#?vfjDR({B{i+kLdLz0oCCb6EV`<;4$KnI2qTf8+kX z;u5FoXHCBx(>|`Bw_-b^V`0O--@b(^ayOrBX$afqc3Z?g%d_b5;kq=#H2c4k6=#0m zrTTu#)s33Re*9%1d$U;YO%nLAK}Da_`&`DtT2790q6gpIWn1_8oM%?6AM-K( zA78KaE^mrIw0r)(uK7*k0xWhfWhTr%DJT$fLe%l>*83b)+RMx(MZAwXe4gVF@VU6p z?#-eTmFMJDKL}U7Ib7Z)7NutIJHh##6ti8|s%J;~ZJpb=)T3q@*QH#4b4E&F=g%9T zpM2(IuhnN-J4LJLve=vNGR`@h&gwc$IQQu68c(eYT;{)TWZC_6(aF|$bEbb;TJV}v z@+LQz9^CilT)F+wu={MWYoys5*4Sljg*a!7b0Q;k?X` z7^#oq>z7$M*l#*vy=^M@qeQ+hFEgjQ9%i;Wp&)+Zp;Y8e_ctd@8+z`Vghl_Gocxq& zr|oh1uoosdl?->La5LV0qBi-t%?2zdsu1e%{+~l;3xs((W5i z)z8XSDDQuM;*8yk6N1lu8?>VOUOthjzto-cg^?qwchU6vPwqVrF2ATdUNW)0{Pe21 z=f5@t@9gKdlzNkMiCuo%q2Re160lA{VHA;G`Hor5!qE~felmD(8R?oCcPA*fw;GB1<=NnL01t7y4LEHoYyHTqSZ}PP?i4%LCS#DpMTzIkXmqu{0Vs>hI(# z^IRIik>beTk@=57Q9xK=N=MUvWQPw6{SSYHq^gRe z9utr93xurMvz04}RmW1hp{rxN*V#kTPn{h$v|T(U67aTnpIhsG#lj0=9wuMxc-dJR z*GOqjI474;u{urtcTTfk*;D0zipsaR0v;?2ZMwJSN6hEL<(n)yWmlYjR7f z$Kt{j28Pyar=}lDOWPiLGW}Qo4H4t*42~P!*nefmbd@$-nD!=TX~Aa2-H(_9Hnei8 zWI7}r`O3DdsO7Aw)V|**{p&W>*`=y)iB)%Q{`-?xwxscW7>lWrA*aBEgSKzF`tN+! zjQbNCB{;`dQs1U$ZTuW{=Kr%R7;}maovPSrp6s*dO3F*Cx6dMCHt5GaahpE>!q)z2 zyC&Z|*~+)OIxD@6>j41-#m*nGo9lceJ=As+^ZjFU+t6<|4}%9qVB~j8!j(a z;|n>-DJ*L>VZQt#Mg2FkUtIRyx2wIbf+4AfpCd}}OXj5W3~k377Nnh$54&`v@lLw) zmy?ruE-!!6uU6f8u%UCtL-WeBVo#P$uRfbJJ@?}I{8x>?KP+PZ|AF0r++&P8wG z%9DLz-!#KtoJjw3hAl^5{HC|g%AI?8(yG62mW)er?%wm~?VO09_LB?bEX1;tZd?BD z&9HQ<|FyOH+lITRp50Kfm+#of%<=AEu=xpv!aZ-Zes%S#u(DVN1y5Qa6BBTYE3I>h zBqKw^0{a^~SUI@nw7EEiJ1THnGBt&%G8l8d_*KIf@5##%WxB!ZQr7~PJtogS&)Rj! zFFe6XIjlr=57P>RiKjzmh&VjxKQ}4bXmevr*p<82KkRW@%9-i+=GFIhE_ny>*l%kK zvfoIt8gy)PVoeF1Vw&EnSvAY4ceY&3%Q$6+MHUl%i;pf>v+b6*wOzeKt0`ygfh;pq za}(_ofBK(g{uEiXa^cB;Zm4}N(1O7dU|M+md1*7AFIsMFH^BzXq zobwJA{#;>kEyN`2dV26To_R^~`#~?!KKYTGit-QzQ8`GSe zn+ty&5|8bTau!X`$((R>v+2cIOWIzt3hziT*Vlj3^-kvG1u@$#SNV4ebxdtuR#QID z=CkDajncDkcJ+R0`~Pyn`MamjJ(_QSdUl);1IO=q-RwJWy2(UH-eYn!;r%Wy-uE$t zpV1*&|5>BpS1Vha$2WgGt^f3q`S+#X^(Uiq7pun}Syg-fa%k_Q@9%=SKNQ}x{Uad2 zlJncX`-A8{HmeHBb2r8JKT+S#xngzlAEjd-AMY;tpfmI2dGSZ9=9K6jIC$>pl_Kl-}Y{1k{6zWd_y z-a9F~e+gUu*%nrNeZ5V$x%6#)xo38A)siW`ZbqrQ|I~n%cfMk?WZ9#n{6I9|=w^R` zd$;sh_cX0N!BFQA$g8iQp^&yf#qW8H{!6a1=vMbdnNAJDJ5MBgd0l^gAbjzMvRqc* z#z`fU0w#H$dfTyHw`$g`L*fEo_+Mo;tSi-*nq;l8!c)_TA=*J;|H}C(7X%t!Hq1_H znyz$XZv{ido0HRKwOmy`uu93P{{YAD1-)(0&g6fd?8p6dYJvK%hvj4x^&s)3D1o)J~T@>Oy_A(xPQuV-_*&=Uh`IU ze6E}RdOpv>{$=ORubW+bfpz{LKR)HVbGDy<{wQo8u4|H*`l+aw>kJne7J z#{${+N!>i(VvG4JnU#{}-Mu2X^XZ-$ljM`cW6w*!+$g8>zwlm)x_(bdf`3)TN)hFh z?eBN}K5@|_uH@$>u^AnDwI>z$e}vrYR(^ibS=`}3_+2OKNam(}Y8BVE{L=sTL^;mw z`|Wi3t(+$U+mEhTYv1;O-IOc-&*#)l-)t&lo$cj*cIPdB>gxB`-@EsEUl{VetP=Fwa~rpn?=KeINR?XF^rC`!56d*W=%+1_Th_Jgwn07tVx~% z-}h&KN_!EpSy;e0AnCs4b!~yk>mDsWslieAcr$BLSI*&Lsr5}Iaba#MJ6hi7zL!$y zn3r<=`0Q;?_xNYU&SrIEJmPKm{kQ5-et#p43DX-CYMGk8WV!|f`_})exECT5B^Y9I zV}@PVwBJ9SK5lL050x8KX1|Fn}c zr{ec^|FENBieg@W6fB!+76=0^v8~ln*h_ZBY2|bhFO=Q=ZytCAkl{Ili5bj}Rq~!X)=Bf-Afp-gfxF>|_3npL-=1*f->BSv z{DI^jrdRDdoCX@&hZg16QBO)p|I+& zA1kLCpSQLCE1-M(ji32H!SzoVAG}bi`w{auVE&umPEPVg7u@y z=IvWd9BQ#YT<(2rmq>PAy*0^SZ$@#2UDVv=lP^x&|ALi;De{eu{K;oW4_WTI)F`{j z^Srxw{+=JxY;QE(Z7eW!jjLj4ezSin@7_;MYa8ti58QhceWye5K!~o^y$d%_P4cO} zmG{)AzAk+?GsnA=(c!0*CWwk0b-kedW3O%W+zUK+l^4wJn#HuP;zz8+hNPFVj?+7s z4hvj)d)q6-`9KU;g@U_dz#dU$SC4})iaCC2m2?HIW}n36Fgc-XQrqei$MRFF{?FIs zubU(pn_nr_y4@~+<&%I7Je^vZ7wvU@y#fOhJ}j}0_W1H+VxaOQfmxPOv#cA|{K`_m+UVfoE&SIZOoQzp+Yd1_v_u>Fp( ze$fGct`CCRx7FIkCA+JC^KQISX=O4eop~b{&k5$A8rx22EK65b*)5T6vF_rcs|wO~ zpDx?&-Z0zEw`}VY(c5YI-|qluQ-05oOmyz;#!BCY*(ZMXMCy8+J)TJmz#4N(tiJu5pdzoc)I<7ReG`u6D!6=V60oCnUh9hdKZb1*slgn}WfiGc>E?q%^8vltdUk#lv~6uL*0 zg~6@B+srjaxMZ(l1WQL^^uh@i#y@tm>%01Y3~M>D)Ns;qOV^bw2jf3pvQXL6GO1uv zH&53!o@*&x)3Ylyt-ge%T)eJf!gt-L`A&(;{SXUPvw1lSA~lU(y1TK?vYXX(B;hoJ z+FYil7mL?gR5#~t?TRZYnP>N;*Y3BbhuVWCcG(-;84HAOehiO z|6r7slD~T+i18~^!ll{&-rrq+pz4~3-R}(B?*h}eGdNZ;HafReA`M0xEMB>kd%jaBlo*jRod-~ePaXL9q zxpz->H}$I8kXm>?J$PHn_Pg`uUq2DV#}@b5c!P7?afePBMPvEubA?8y9sfNGH`-{v zJNwyzw)87%`WG6deJA|o*|&Uk`d$5W24NGXu#<29efyX{A=GA*t;4#oYR74>*L`%h zy1?FBBqM9IVXNlyrv~?4Nd&lyn=NO*RkE>v->fFHsy}M`R_%7^wQ=&_>y`HX*=$Mf zb({5XUvTBAoM`&CyZWOa`yboa_ewU)^WXk7q5s6Q8FPPj&1c9vo-$egOSw$%o3n9q zH_x>TkUz25?u4gd@%AT8y0>pk3SM)w%1rj6`2HW8ckf@L#{TAaIq z@7&vysc&RycJhonbV0Q91uYdJeas9XHk&*^?|A}4P3cVnHNlcccVv89#y1(W&J z8hhRpyj`BSE0XnNwc`KVM!r41H`?ld%>H|0^4x~(>o42HZL?RsIV@JAe(gvi>wZy& zjSr)~&GWqT>N8eYV{}496zn&&-r(_?}?&#{DXtf9G3smN&DH##~8oOfOnhz@~1|-XMa1X zIQ{6l$A36K+*r;&?W478Z$4#3ZkH0IFt^LF_?~g;>uLmz} z=H{$k{O827qoP(vJ1VrUpGdnjv99RQzG}U%t&f&TINR6XI6j^4scLn%qUB1z3DbMN z1iD{19hdSX`KyCWW#hE%NynMEc3Yk^o0mI(U5c09mTyMO>Q6qo;Ztr{yoTf5(dh6~ z2P>QQE(uOiSz6q*+eKi4=ohXnN@@pLb~`<|QENO=D4DHa!9CmhM9`zhx{SHmX6tqy zKj1#eTdgxxxMa?n=}%_ZoK(zwndg`L6c7uGH4na}}2U(^vBEo0q;~cKmN0~e)H8Y;#SeOuLd01Q}OWlxyox#^v_quoqM=+=7ZNU8xM*9 zJZxN2;G?%VJ7ebEes-yIH{Zu?Qt?-qFvs*w60f|GbjE|@$Cg=~%4-Py+I;6|sNpo9 zlnwb4ChBdwEOyeWv?%`Y&qwwTo=ALHzfFn15RktAX{U`Iz@4jbvyDRilTCu`(xudG_>`uP8XZga#d}HGMlJ&noBpP48;{Nf8#DPcJMi;wv-nkw(`5>zQ z%0BkUijc5(xbO++?wHJR=FT= z!u_9r{P{M$tKHykr;u%yWd1F2Iy1++yWP@1EdrZNRp&W83t+VC_TpTtaASH4)6K93 z?i|LZWgB^?^|7AuIpp$5W?zaT`@Iwc>-TacK1B~SABr*_UzYtMev)$BwilC^Hl=HK zyo@(2;I|SI=~tWk_Vy!F;TwPFnKQ>_EDQeTYiD8;ALuqc?uFU%JKtX3_`K~&%Jz)M zOD!z7`SMw9QoXrJ`QDo_W3~2VR-IZ={qKL}tIM}3-z*YM*ip%lH-jZ<)nOY>0X9SD zM+~;pzUmAWJan-TL%g-tAdT4U}b@^~R0rG>%`n z8*|!iPPG2>&dZvt`|l%PUzu8BN+^@Z{F7y;X4ZrxC#)?x#kW~>%i**C)~<|jx3BT* zX1BP=vTl;zm$U5d3-@o`ala)G@xCrVabT&cSL z*rwIDJ~S^>Tb}&)1^@Eb*N$k<`rt4vM{WNB?p>exA9F=5@{evh$p6D-%cY4@|9>U8 zaL0XE^Qu`jZBk=)!KJrLc7Hv#t6$Hm;B45Wz3gH&Q!I|I-uhti_8XU8O6*QtAGJkQ zx`=^YZqI?m{9)ggZspUzxo4lH*Oy0({l`K}&Sn=MTzAN~uRzUzS72{sJfr$8)n}?r zTi>mG*k|^7c}}zW@o&E}j!dt)C8^G)Ks zyxAt(UDvXE(eZ9w=YypguU)J(CVVm~aa*&?Y+jSP1>dm?tTUPB7`DxQeD>$}m&H15 zQwuXME;+zhe$}*HxF>DqF{|URk8ck9z<2$L^nb313Lf@JRyGa%O6~9anF`Ly!C8iAM0js?I)e)_cwf%l)L(T zwn~%TbIpmy?L04M{M#cmjb)Ype7n2z&fV;@EOGW@s+ukM*LSyZf8B{zpO8(Lq?Y>^ zzYD&wE6ikNaQuVi>tCGg`}XF;zAp!?AG$J2hI&h#SY2l_x$$d;>hF}J>rR~7(efg7 zN{0IVn#TGg?P7P2+LbI8Jex6}-}S}1h{JX_IB)!ldi*4==h7}e@k!Hv9kg1`D)0AY zn#s;%>{4oVU(}0rtMxe#rk7k;_%$W9*6{S!F80sepMN%deWxy-ebutf{KFYm=g>2p z`z2)jGcKkFUt9Sj%kIt(C+@muGnXv61v?8M)7WZJs`DqNe+#@-^|wszSRB}UJf+v~ zr2MSV#}zY5CPk|LEUER(wdzp2uJ!BYKT|;;qxFfiC;O_OGYCI=Jnq=JiITsPrQR<| z{}z6yph&|+Bw*I&IP-nmesH&&?YmxikXwAuhw{5MAEsz-pW`B}R~)r^?x&dJXJfr9 z&Vz+R3G2MRAYdS9w{#cL~R zum6+%KI~doo3l%vSx!#9HrPDp`792*wkh#~Ju*7ZemhTG3}5zXciMxlZU4+Z9I)56 zU8gRa5m>xos@aS0$NDCQGR&%xpDq3F!}=YIf@k|&knc<0BZFz=h>@Fbp*exI>t6BXHv9ucF{Ut zzgsCGzXfhCF@L*d;)f>Qbk*G+?(fd-JUcsE%6h44`?a>yyD~0cvu}O&hHFiR*|$Zf zwS-NyUz*$X%#>bV(H|yVQTtgdWyy}|I#StwMpxXtIlYVhG7t8fecl|**-;(4o87-+ z?Mb_ji7|6GEIM6L&~sFH#@g9yKc2dhYBa;*K+u}-ru;s`@6Tm^9h9DRc5Re(W`}+9 zvwc02VkS)$+skG3*zn%7tsDKAq_^{(S(n`#A2svOLfyR!=JS9`ip)1IRdS~pB#&(T zWW-Z_^uJcYxmmQtw<)h5x_sy6_f=0T_vZIq+H>pqV*cONJ^h}C zYd^9+zVr3wJ40K)*!MqMzZTa#vTtAZVavX6i9+`Kr1q`s@67+E&XRp6`u*|cJ74eJ z`7h|#8zx3{x z&?z65+Q^iBQtynL{6rq*sx|qs{7vuM_vGQ00^O4-`v zAD>-0x7h#X`VY@$y}P#v5#<-L*(dFQnM627(A ze%GR_U*Ehxn|p3f`k6bWXLbnf+gj?cbYsWsgb7RQuI{z;ulE-_7Haf*%6dbCDFrtB ze_h$X{qFB8Gr#YS%8Xptvj5uOoo@Rt$>jch7n{`m%`?3wR`{Uzm1~kFqCa#j(|Rr! zEPrekCw+@&>9&u-x0{|BRvqA6{%u?3@q%ODV|HJX?n@vtB)mEo#Q!a4(h!_;U#d(= zLonony5JY*eS4+!1ivs=eZMwoj#T{9D?glX=cvfa95#NL`R<7A*VH|hTZ`Xm{uR9! zb9ryn_d~|VpH+O%R^KCjcfQHh^{)OVnak~-{cz6IS=RVDpx&wai+lK%UGx6#-FbHA z=bo9n`y|5;ncsdke-ejX`=>weTPEr}$hE1t?o#0O*67zuo2;1C*If)cYoxYZ7EDgh zUsJu+xZ+IR_xR=CMCv{kbIljNw()22xs?U|CyQIZ22>pX5OZjU%K6oa|C<7oUW62= zHPxlBb-CbXYOnm_>jwSq5+w`!&Bk9#`fO%fU$#XaRlb2bh_pQ%9A(r?$^UVL_r*Xvz%p}8im_Eu`SAMfmWk#lZK zC+FhI>6g}R0VU~L(;CgFDi$k^QeDZ_AK#tdSo&{ito!FB+5P`4-{1JVx3C~OIy=W| z`)lz?wR@e?CtHt&qDsBG|Nw3ch03?9)}ut z?yqc}i0xa~?#w;6v3mPM%W(OFLJM-QJfC(g`nsAJ&z2DB+ukf^IM3yLy}O$~_M!FG z*v$RD_7_>V{aYfr_tdSt=EwfoQdxD^^%u{rxzqN3;g(xJE^IZ&$yHak|GLS!_vze%n! z`yaaHqFCPbSEhnKO7qopm##~dO8Nf$hSmQ|>lRmD+Uov)PWhXE_bhg-U29s_^?CMp ziPT4PKlEL+e*R{yZR*{YkDGo^vbi7dxjuX@+p52P37rrA6vlThxPIt;#c}IxR`qsn zN)r1|I?etkW!-xG+8m?uxy91+UPND)+0A!NRkbN&)uZLTe{k3{aeSG;ZS#+_wv@3Upkt$t%A z@%nFZh9z5aYvr3?A~D*0*VjhBZ(aU-UHbmt&$kJm-?*>gi^Ps|OW$sMe%s?u%^CZ@ zm+f=^S6}@fKb7N`Kli`W9lgihlI7;9HcfK)pSJG5!KLkOzhl=QU-nU?BDbkHZ&&o! zE2V2qpPhUCfW^7`l-iYDH`$b>V$IpoE4JQkeyvv{eC){gMZX@dZcV?`vHyj=sio=u z@WqqsH%#*0^x~J|AKzQ*dyZv)FF5n_>-T57x0~A~Zo3z;ykXMz9G3IP4tgGY_tEqJ zB;T*^|NdF9J-FIVr_-dp|C8(grVIa5!}h;9y)Wl?r@H+8f*_9i0`*w^&Hd)4kyqYb zoM4kb`|_@5yX;cyUdN?b|7^Ry)vNwX#owPZrmyT3@6b-3({|%VS6ScrpJ#7NzrJ@m zM}6)?+tzJ+OV`eS%at9wJ-YS))X{PwTmA88mk%o1 ztGjr;{yLbukYM`x3*aR_beT)V6~5-x951S zuGZR}9DM7Ss@=6n<(X4tJmW%Ye>8(z;q67yN;A&< zIbpp&ZkD3ot$2CGHm}B@BLp+Ua$XqJzu@$$qT!<6GfjkeY*Zt z?rguI*t-uUwbD7ov+8f#eD|AMER@ctyR7(@hw~QdDL9P`@Sy!cx`>|+tpd> zXD=3TtO zFQ+_=|Nk|9JMXdoyS~&r>@7P~J$qB{)7ATbt)5?V_Il0PX(C=sxwp(DpNib|vHSky z*PVU&E{7M0ADkZ?v1)y1#60bkXKZxoclNJj~p7>R*+D z=eZnDqu@uEn%iDaI+(m8JnGq3%`NADR{zb^uKs?0sdnVX-3iT!cS<=IxtxDqK9?&@ zwc-EI`Tu`zo4@F|cH+r<)9Zgu&;P2u?~(Sl^IxoX`pecwkG7nBp0Ihz6VB~Bw>~p&dgdc> z&}{qfXXm#T@2S@2dF=JLcyFP>m1Eg=gAW`#ASk@MGbBOV$>?mRet$zs}xFj_3RA^|^Jq zh9~}5ZvT4A*4F3m>(y`0I~9bI$*q^VU?&`m?2ZsFCo$l-7G0 z<@&Rvud6M7x3K)&+{f=i*95EO2a6T&F+G0kMWKC7lwAbpJTbZKEfub(-fAF=s>6=5592mL#9cK6m8$-<@ffZvWkC>lSVCtY*XE zmvvh$?-tuW-)3p{eqGpx&|DU+=;El$GhP?CI?s1}72TPW@W~*TX-=iA?ZFb;>+8NB z&aCictU?W}t=>r?if znAd859`WX2)0Oto!|1rdWN=wXE;Y&i&4| zx7e!PlVW|m|7`A@b@_`A+Z4>sU$^g8)c4TN1@~9IDc9cWH~;rpFS9q?eEEAm9xLN| zadlbBg&8RuZdknJ%-`d?r}&=M>UE2^Zu@vG?e#lN4uCM!fzKy;^?mucKc@ z%dem0|6~7qv;FOT58srdT`+4}pz-gBv+`uVSG&07!35MeHG|S_Adi9;8=FwT}i@2_5Nq^(Yj>~Vj|BKn*|8&~}uI;a{vC6NjJd%GdYEAy# zs`alslfUiWf4unnyUT5h#d?k(b96g(#F6jn+h?Dao3?#_F>}M0SC zUH$j6{ol)PO)jiX{Pgy?=Ywusr|HF8}tX?V9}8wIt((4{~2LaP?7D%(nWl zXL@nKqmnrh4|ATaezxk_wnYDkW6w(sw!HHUxSew`dCjF=1sUFE-=DE=Es;zn12Air=jJw>(*C z$8qDE>gKt-R%}h{^Ov|;`}+CbUk^g0XXhH+V6uo~u74yvzv2`B{}24PSB7;inD1zK zJ#(7AO6As+c>o5i1$or{81Tk2k|6h0Wo`+RXh$f53Y z6@}+3igMSLUAp&GhCA;2mQynG|6a@ber*2wy1)M)>BdcNH#FL(*0jE}PBZ74$jr|f z#hapvEli%C|Gk!zZO7D1jbqPB-He~_+J7$cxodN2wT%S-u_b4JBu^=5bI#6LZ?e34 zZK>^b$$Y(8vEoyrcVGA0b6luX^3S2b-Rz&YZR}iMSSz zL;U&y#|zF_K69PCuln|?IeV*fx#i^frhcvVl5>AI2-?(%+9hXvo2)MX`^NEkf4;{5|2ld9-`o4| z?)&oK>IPv)lb@TK@9&*_#3Sy{my^=%*N+Gt)c?_>e?#b?XZ4nAYSY)LzyEyijd{5B zbNAme(a+2DE7rYU{~?Ndon_X>^mQ{|p9y{WDF5HH{B8L^eoxy!zw*=KOZ#+!lst}2 za#+42HT9HuuVl=xy5H^{*}>|5V^DKU1acqoZRBD8_%My|5>-y ztK!Sr+`NM47Ex1}8hDh0SEuKBmyz#>Qy3RA#>hD`JuB-~)R{VD5 zU(M!(b=lujlJbuJeX+)L+8VVxJI~$Wte$#skGS637Q^H3Z_lrIb-gK4{$7QVpZ&X) zA1&UOum5^YGiMfCma-><3G3XkCs*c`5!9lpRw4_x%KOF-Jbbe<>$DM z%j{n5AGUV&-0U9LM{pQ`s1GM*mwPa{Ld5a+wu>1vDM!5 zEz+3D7{2Mza{oCgm2+QSeI}i++7!pjZY^5;0K@73S^^<(B972&EKYE9yc z&i3d%Rak9!YIf*JDlQ=jcLPkeLMwmj$1x_E9etH+6_tmE$XzpL2B$5Z+#(?(*g z;WXbD>s6z&?zTVQ_>@5}>iel9cmIA+pMC86t-W8Lu_ouA-DtQe>+Y0?bL8!Ei|_i2 zA1ug!wWhE*dimP?Jwkn&#=CN3UeCL{pTGXc;oGkt?*DUo{~bH!7o{5u3u=$~D!mZ# zexxo~;-s-~q6C|zK)v6^XR{v$=|kjw%cE8Slg1k+v3kbZM*N+OqZM8S$-z>tm^h3GxzN93%l;}!O7&f zqG*>_t@$}ey4SC#^-lU zje5m-v(x*S>Pn`cc&z#FphtP_x7DQw=kIaTpKUwy8Y+otM$b_nkT*LFYSr*ui1RxCVM&GnU#kg+RaOQQ+R)G#q2E&rXPK7 z6lk5jUS>b%e7ep5*CMZ(<$oOb#v3ue^0V^EM+ruSi&Q^q3;wy5|M!}%;U3F51wVBU zeqb?er2n+7XRn?U;_bb-(Qwl#wg-6Z|M=Cj^7pb#P`2KuUf*{qjd^?ZRHp9N zozl85!?^j?ue7f|kjP{6;qdb)*W%g@SGj(4U7PcJ3TN^ucK;VH(z{|8hifaWvpJk= zD|bODAY}4Mum4NLWv?c<`Wy9xJq}HNXMX)wO3E73hedb)UfY&-h$DT&TEqHl88bFS zZ~xA4anJ5soyqy{mKaN2n!dHycXq-3WAk~lRu@D#$G_~8`#9(9YyXN58YkWDC13hW z#fDGvf4x;$&#HIjFDkrUxgxJV-w#SG*?lpd4$ylXwbeWgd5O4B3< z`w4Hn`HwwhcE40q?D6Z_>W6+Tzkf<>I1~Dy+x+^;3$>3Y&pUQz_R$K{S+SEtx6S6= zk+;rlr|->;oY!-t<1eQFi`wPhf3b`0wdjwY)o(T??GfVna4>L_=USnjw~sy?zjMuW z+0o@Y-<96~8rLbm)-r0#Vqfp|TC;AI_h{F+=QY}8Pfq?@(0+KoIiV` z^v6TLe-~%&*>Z8sT7SP)NxBgiAMP?NIk@!I>XQ-DcP}nzJzVuS!$)o1VQIVXO)KTk zMI}Gj88-F7hURN#$7`*2=QCDc5|jBb_13R-FV{%*{_x-bJwN--@knjoMXroVQ=PQD*pWhJ1Z--s6nR^UY59Z`%8Z-NR&({jMJ?uiaQ8EPGOj ze_b|vWd7y55np`l)b748ZkL(*tDxDxEja9D+O3V@8-56KSDj!wT_w7vLP)&l;r1Jk zt$wNH_8y%7@9=$_in&EKFP!D89&O#A-~Hp7!LI}1C$4O7`^y&>FIKqr+uFp>2U;#$ znH*fLI=S+G#ZuFCled~#ZC$rIM?CjU@-2OfF0(zC^-lQPDD2OXTKgh+jc44}f>+He z=g)a)9-rF(Y{j1yMh|E5yA{o}IJfpbwwfFLU@a*P>)D3fboPR9zYkN~HvF@v6dFy13eN0o% zCtI|Y2We$AB-&Q2n(zKWSKm{?wOFdS=uS`b!)h%y@2^%YeE)BqHs5d2^E-Q^Tufu! zS6!PeRZQ;fb>|`$oIZK5rMb9j?t@+Rs>dQfvZ&u;+3{Pf;-l}hi*9O9mYS}MpDnk> z@cz~&zO4>zaR*l((4O$X-Mj5y>{QENKLiTyurFS~=I-Zl{>#(*@e?I)-SKx%2~uF5 z-gm-#{{ykyYb&mWbDev3;HBK|1==;QZX3KjyZ42Q{hl`rb~YEnZCL(a5sUTOA{Tw# z=KErH-(M-NZZ{>Qd-&J>es(dt^pzn0mqz{CJr7Qr*6qEwz_=*%;aZpJhBh*foA1t? zeRpwt{e%UCkZ(yB&e(Tryu3wIZmmTOoX?W+?ABQ)t z^X)2A*k8s-_vaYwcAcDUGSOUe@$@^J8FhbM%~7montUc?%Yn73>blYz_a;PcoU=CN zeQ@1_g`$22v9Gm{ofMv%^{?&T3qyU|NvwBr8hsaNMxD*>732HxL#y_Hv)Qr7Gy5NM zp85Aze(!^c=W5a>{s}R75yivW-P8Nn(KGHOM{bI<-q*#FZ&D0v>zTjI`gc-J`To{f zdMDoe%CdO5XVJ8SMI3E^K_ii~6@Py%JEogZAi%fED24Cd|56bHOHamSrnl1D7o^)B zZ*9I*Y*f3IL484i#r-c@JF1oTS?)11Ja@9VFVlf(!-D>@|5Y4vf1BDEnABsu*f_=5 zpOhpN=QWDwnN*lQmWrKYc=)Vg^W;-8+9@H1Y6=`Hgjlv1e*5`$yBTj^!aN5Rjp)_+ zIxz+Qwmb9$)a`9NXXR*}ymYL|e(IjbjBh0Oytu=^eUhxTN7}P!?E|+OZZ*`-h@C&@ z2J5X!&D-ieU1(~xFKRsAe()yW%n7|-=`UD>-~LEo&zG@d(2F<}-Z_2U`>e&8S0|TN zCm&nu`7XsReRA11_qZ?F$_DLcKWgq-mBPuk+u8Wvi>{cLeEk)V{r6c+h?mUw{jyMf zU+>PoV?PRb)$cs%R@?McdR?usu>7x_%Qo8_^shZL{*~d%T>HfM#WMDND@B=evfl8? zKYOG->tbni;_FHK%+iWPod0B-?Q=Z#PV>PgR-<3<-v4`d*6l~ZC-du8e=c@sn@!!D ze*LFY)d6m~Ek91QKkDQONj)WNvp=`p@7tPJlS{XK(*OTSKYCM#eo2(`u?G`GZM}Ie zG_e_m`Tl?CCcXc2u<@Umc%Io`7WCf}DVr4cGICGL{QVQR&pLa_R&ufT{v{l14>C`_ z6H?{T_Ung3{K@$djdtG@rfrrynXrvJt>o~^9buFEXZY2pMCK%jS2)Q_q%6BM`Twy+ z_hcTi{#2dK`{SX1O~mbbjgPwTzUlsQ>Yl~BS@$>7-XCU0|Bl#Nxlix%+jr#Nk+vu7 z{Z92K&))hb`;m9<&Dqtmbt{aR1Oe_kGQCYjbz;37Qj%i=rIcl7FaH@EzO9WuR%N z{6Im{;D*dWcH3N?rn&d82zgj^{hre~*+}l(G0BT-eywEmyTRYLt6yzL2y5Nc$*Y+- zVm=(Yxc>L=)T-IN4_KF*vbH}Exe&8^xkR^ovYA5T^ca?;Eq_1T|NpF}Z{(zZbAsi( zHJxD}7S$hOlYjfLpWiWJ!B#_WH5L)0Bf^r~RvzKs^&;%UBK!HVpX3Et%s%z-Rh&3p zRq*nDbHjNP&Ph!*v+XQH7o9h~cY)V@?*mD>_nKKL5jc{t@RU(f1D)i`yB*-e$R> zF!PhLS%<&PuQ^7tm-1)p?K;pGRuI#isk7sSsoy!KoY^As3t#65oLzTuX8$qkT?ae! zN*2iLmNbWzl@{M9$^G%-J45R`p_mOKC7KVe-e1ic8Qd!dk!3uue;F0ZuRhY!3NuHe)g&|87m&K z`}}90E<1Vk5vH>RoB55N9j^#E>u>)j@znLL7VUbXerpSBPj>wH@%R4!ztM*d>tEnw z`?rX@Ui4$Q%p{gcyj3%V{0IKA5E$Kb|vBy%_@^|9*$& z?_FD`J}5i8A@ozi4KtN53&S0RQv4F6yn?kN@}x?cOwi+SI_p5*JD)b2O+k4Woz zxrYlc+w9@mX13gqUB&##_h+;7^L8b3f0W31&7$`q*Wv!px%YP-oHIMnC?fh-=m}ZB zKa-jr{Nw+gf5xXTX8{7<=9G23STA^qLUH_vu1T6)VTmn+3j?WgzagKPWCHatuZ&d}?8bl6PS zD6RijPJjNQ+qOXi^;Q_YdeDf zOp-m2SXXP9w>zR( zcBbyk%pH>iZ!T(&`Ty?yzr4vSEgZLH=x;Q4XXK8vQkLcqy8kuy{??yDv5Vw$qke=G z3BJEE=ZG^C`?^~0xD6NGpTD^omk|G<_nnYWm705D!`+XnpQe;V+dmC1%8rpg`{iX~ z+x!jb8~ONZCQPpU;q?8AW7RQhnRTKzaaoF=HT%Cblo{<*YZ6~z*?4N1LPe3;u{S9l z$rVvsIzuFu@pd1!t^HMEoYEJ#;i14a4<6RUzSA%Jrt-uHTzak`WF$R*e((bY*5t=# zV$z#fgy&{V+fbBpk|pjzN(}2XnN~$3ht|s}J!ZNEtU8?PcbYiw%(>E*+_xZrv+s50 zgMzJ`i0>Hyb8yRyJ8EIB$}@#SP}@2|a!{E>_$(t6CfXaF_aq=gPJ+ z7h|nbtJirKe9Vg7uqCu=?k{Ej4^JjYB;RDeNq&CPQsrK2l=wpDvo)-ybgDC%x|~I?caLdb6l~?L_vupJod=@?U#1ljr85pINML zGQ}Srdc1Vn8|7b{)VIV7A6)XOE4s0P(KzSil-|gogv*~z&K?jwcD#{$3TRq?pX8<` zP7lOFSPIW+Ex0XV86q8TV01%f=SL=i=dJC{9w|0&i*x+F<{Vz8u%qz63(*SJzqU2T zHx4X);_+@_`{IY*ADZOXHO*LZeA!{k#kHn62ECk2Cnx_2acs*ux#aA*XNhq}2f|NI zV^CSZCGvvhy3Gbl-knkX;Ro;3hC0q)pnT)e@nt!}n>%k@n3Ln7^+7UbQ!wi>`yb8r zH<;Eg;C6RZ|M6f_f5O+p_J0mb+w3xIODl<5{Al^5sy`E$qXnProi@?M)8-|=ER$K} zV!@nRs|@2b{;6LseszvANfUpdB41J}^kT`D?5eE`ceF3he12^*dqu{ag0tM)D!YFF z6pP;M=&|HOZ#}=7nTi?XyEw(-FB`O_XN3u!P(K-ZI_|~PKQ|}M$~%x^osqfONG-7E z-$~_t7o5Ilq$Iz2`|N|jp>oxrpS*R?+<5e6WQ5(|wN`L9+IDc!b^mn|k3VO4<*Ckl zUwOXTY|e*`@t!kOCfxrhzVY;|tRH4etm|*&*le_)y)WXy6W)Ha>_6WEI`Td_ZgvT< zNjm+cw_Rv$=X4p7=W01Np>%~8~DMU-W;zxH8XW-XFfaP21V@zD(w}wcL7n)6PdhMrZialzu#WsLN5ESU>5^q>N9` z@^gA+yO;ks>Hfz4&uOV5xBgjr9|ZkVY`(sgn{`7_=84j>uJt)*nmKMgJSIIy)MCxr zmgK(D_d!u6>xvBB)JonacJe&syB>acy+^hg&%tS%IWwBpO_pN2*EUI+Q;cW2uyI)1 zn|Ur1ge=`SxtX6aux=Ic|GCQH=!)w`=2jLK^DnFSDFtw*y_gbHc}i5|!IJ|83)p!o zVx`Y>E>_%g_TnN@`xjzgR2N3gKfZD0Le(9sFE=iqw0ME`%xx1F`fqjQob~Q-sG!P2 z;VmpuKUf2buIV>4^!ocPR?YsjSl;pMjXPh~h}#@cw{QG@d*9pJ+m0~B&vW3uaji;V zLuaLxm`Lub0+BBdU7OD~{@Xk6???InA9ID5NvlT|ESlaU`giZ4eIc`LYQCKOcA~9^ z<$yWga@hhK+c{Q~dwX5D?dKgbOx@Z3dXAw%b9=bWX6;|EPtK2daoz2fr|{2>`q?Mh z?!R%KpSL=LG5o^j$jjmTnA%LQ&Fc66RW5Yudfkimx{S^B+Y)VlH*aTR+qud1U!$Gb ziEm$CipFIx5|^pkJoA(8rgZUNKMec*eh5SzU*u&N8Ix= z`tx*mWhWWm&@5LKlAOtG>sc`Y*jvSR$Q1O`-t^y)UMF4 zAA=4S8$IlQaI435!h_fBbr0CLvBXZAP_yQ}V}#Eu7CwF<@u|7uiywrp;g{d}#6GG} z&31wNQfZUBGD2_P|GoFV)_SFpeMC+}>_OkWH`nsTr*TMmm#=*o{;0W2zvAWOzl)rG z^C}Yfb7rhNAZ-2Rr9u1w`I{5%f2jn?2^|U8_D0d&=J@p}H9afU;BRXVsSB$3{}9=? zs4IJtPucU$H90M3Cdo@~R@|x*{O0Fk`(KNNkdrC_IbJs^{ZX|jau1d zpDgu1{~=?s=-veFC;W0dUYyCd`BV9!IX=jn|3TOT|2*Tg#`2Y^mpYGqnV=7vt-m0n z{w#vYAbs;mPZrBLE{AR1rY$VaJNHntt#MbnT&k7s!kA>s{?eY<#3M|C&kg1;o{>MN z@P+t}-h&4fEw-uK?Z_=rjX2M@-r`K~1J3CQ%lPGvH|K{jYR~zwE$+gmuz)Ew4=$e! zKN;R4K^$W(!xi#+LtpmISzBzSAh@ye z)`JsmxoOTBYbVW5>9X0o$YnW8^w!A9maFjyC%z@^w@q#Eva%{H2=w>FTtYg_HLjG5L4s-LD>ndKG)o{V!*nn>*#4OMrY%%?9~G_8i?G2@(Ev z1>HLzDMxU{Z7Td_(7q;XvwiY|CB`Kex9(-z`^}R7?VpZX>E``Rd{I*#yl4ieMz`x) zwv*Lo@14i7FX?SzhMR6hfm!3}i8Y-H%NLupCa<0+!@WtS;qtQsGV>F;uRY^ZStrWp z_A=_AY+miTC86mLJ7f-~DM>yMF!Oa&e)uSa)#sq)oezt;Cl-c%;fxD?{k8Z}XRy4? z4~ysi|G)U>&)%RO!KkaA<9qDP!-HEpEfqhQc(*lm8-71~RQSgWQHhg+dNsS!jeXM| zam9pTT^_o{Ho4(rb(q=epptxD zbKIASx^Wj3!yb5g`_**5U$AxZu1OL$iw@SR?qAGY@>!POHtysm|0=cp&o-v-xai5B zp`c!C*chkss77RN#lhWQpZM@UVvJIiTNhfh=%9_6OMby*P0QEr&6Q8u)jj$4as zsN5u6anX;zV8X&BL9Wa;Dc;K-K9kN+v)+`n`VX`JhYf}`6A$}bnzVGu-)9dFKblja zHS_CFx2m8`?6oF`T*cq)a0yt`Y%DEu`K)%JlCarxm$m&<9_ZhFu6=F6eErY%`Kkv* z+OK?5u2Rp}wK^$zF2&I=wBpO*cKM=3{2xwq)*KP`EVh$-pRri@m%6gyR(6M~W64LO zK8tSgxp}tkv;IQW&z`fhMgQh>#oQ3Qy>p*bovT#x0-kGW$6rdUy57uBM3*Bl~^7tLn_IP}IPLGLtd;A0T-|F?B)VI3?GzjY4R)}tv+rufuWOw7qk52!Z zq{FQI^FFrf?cvz+;I_iU4T)kL9~#OlCRtZqSau+FvZDF&kOHnx!PA&xvkxwo=3MY# z_19C4bM72&U!cmNCeF`Pd+p>gp7g4P{3rVov^@*06i-}k?d{xm*3&L3`=UR8#@3hh zPn6|vPI8>hzIVoPzZV-D^aNA9C&?R}j9M!qu-k5H@AQn#dX=6WIXB+iXUj5HOv=X>VUUky)l`-dW!FLIq`!M*VUd4kqjSG0$D_L9;+r z`NJgf-OAU~+t1Fpn_8Xme1GnlAIz7fq>W=IYVW8yt*JBHfPL>vgS{X9jTnMe<&%Hq z2XuX8?^F#W*; zcKtWO*?PB5#6H!2F`eN6bNh|S_YXL-T|4lwmu04X?XN%FMUNO{9&9RqeQBlL+=k=d zFTOk2_2!1%eOCGRYsH!K`0P|ZDw`W=t-Ht^nJS#bUaibrYohfc)&9@Q`7VjOb98JQ zS=H~d-)CmCUOd0TsDEyQ7lJ8S5?`ZkQHx!`$XgG*6)RgGoDQ&29WIZ2wVs_PiUe zyArIQX>UG1?@VUg25`a+w{k14{$eUvb99!_5mgs6fpclelQ^Eq%sa$&LsH>*(vPME z4^CHDGP;W=SacYkOOaDvP;f9X;Yr4aLarT_+k3t37dLXp^{FO2nekxfaYa^rzZIe! zXM}%Pip-H=)$>!AeB9Gy|L=mL2DipT6MJRW-~(SHEoLuuxgfFUgLuQ%Yn**Q1b3(e z3OPzM%A~AVFgNGK88uCg-Fkv0@^6g`BHNcm)f$`>(vzN~~eg|J;^Qoowc!yVqOqg^W+x#K+mi6^?;Pk)W1(^DR~e zqpgV^GAE)Yy;1QI(5Yn5-ti>yY^~QPmeu>F$=&3d_2Sa8Q(-4q?>;#bcS2cO=b?gs z(E{(X$DvaV&1UKy2*2TF$3A^|!oOwyZZ8&ze>z$}d(PRANq>$#ylS(fhIy}<*-5S4 zj}HrJn7P-#TPW_cZNaS%FS%?y`&7J|X4+0*wT)i9iQi0h<%=&ZHV-D;`Eb`P&8mgD z=2OD+KgXN-ZKcZP-#%Fsaa!$wa=F3DS^PJ@iqhoeSLbhaify?rs*%Ham><> zR9;`>cKa}Y?F8E&PnKR_jDBwXsAsa2?vF<@aTh1}emME-!v^^p&oeJt`+i8u{7_6b zVqeeBQO3-EtM|C}+y%#__GCU>KA)@h@b{1X^)-`cvhenosEc(nUu*Cef8agKi{+-& z-W5N^_S|H&NolV8vypYzrw1q4CTZ8K+R9atq%QmS&G~$KEzR(=51PKl{Y8lU(xeZcf*_cEE9Y$s@)Y{oX9GpRa%M`Sv0xZN9CqE$eTg zD5L(mFH4e5Hmh&DWLID-SmP>{JcTDd>6izr@OohzSa=dC<$HMH#=yi!v{7!);YhA6|6y>IPfz6IZPN7T}k4?BNz9EO< zgPpa_%$o;T($*TfWyH-^t;rDZ$YHX(taRW(-~o{ttn7Z$u^FN>EcR#>PH^y8^}*|y z%-&$*BEcUgPpj!TOcI`v!I}5>rOU4jw#&zKemru$pzb}JckV(?c~)b_pi9qOF0`Lz z^|U&|e~UG;QDAR^r`n4nlQ%!`uw&Kva(lytcc#U)2QMyrQ&;7({%c9XW`QdQzj_@@ zKfvPMDLC_zyu_;I)yvsZ)Hbg2+3j%NQgv38@l!56Db@_DH(#aZZ+JNI>=yqW7tg%A zIWM6%Pg-c_h5T>)>$%u#Czx9{pJfBh>eXLf%&ug%c!T)2_WEy(X1^D^Z^&I#;&eUb zMEi^0_=}R#h3lF0Bg}mNEo$;U_C!0;`TZ2n?2|{^(v*e8L-u*gRVYaBi&d01+TiKM z@RM(rYTK`z*tHYfw;iwB{L)U@!|kQs+{MB?MGKg>>CS9Dtkxx7lX)^IG5y68{j54I z!2{hYyt+R^A28kbpLAowPhZa|Ez@*PZkd$3NL1#VU)cWd)%&-rn&xon|A~57oii`) z<#q|Lv||sn&NcAnWq({>CT~;5P{+UUr&Qey=KA!_Nt-3O_DQI`Eb$FHDZVai$DMAz zO-F8TcJ@ilFZe8NaZ}d1FKkO=|N8R%zwbtCGcKJkq_AU3L4&?v3V+r|5j(q6-`39T zRIr`OF=?p;yWFqa!fOQkFSWW%xc^n*ncUum+Otmdtoxz7n=N|N$@&{ou^W$S+8c=n z+r})IA73R=V0Gp@=pZ)f-Uq*fgl@zwzARevPBW!yjr{uCN4S4E_mu<`uHB?sl`{Lf ziveh+QAk3~Ih57KFX{8o9*qDlknlt!bL}GN*2y^Y*x2;P0$oYiLKM$E?lwjNw}mtoF_ zr|r5u9#VVYp<7H(Jp7^d~K51F6P5kpPpX%dH-^tPoWImqdPde~ zm3U9aD(x3*C-nMu^RVQ6YH;>$&sd(E9b)lNQJ7QY*25_)Iz=HTnoR$r)>yKU#a@^MHU(%v%+0wp7 z`_1I{o0-dW+IG8f|8MT@`{?vM#a;cUPSrK0`$rx|Ej9jiTwXe1d&#qd40&aeYhUOK z{#iNy*UH}bP6ewM?z!tEob8MSkN6k7^y+Df7u^5j;YMM{4-c+STIeNKa&X`AK3C(<8RLT#|&r@k)GN_%J zazS`UMhf>62Yn&aO&{OJ?YZ&d;W2h=k7p@L8kd~!U;7*)ZJ*+=cI|eB>P)5$F2P0z zza2=nXIj(Xx83iimsHM=V6m5)mUC|{Vx4o%eeu_KHx)M3OS4%0bgfdAKDx{7<80?c z*PpAZ-e5Afoy>0|%wFp=ds|?$?#nF)C-%EE>YZVApQ>?VgDP9jJ+>oxIUO}3GSahE z0*ns#-(;`5BxxJ%Zl0Tzp`QKi_`S*8a+Ayd>}u=RU2s#M`+%?Co1?ZS+x>VFk{@_o zxTO7i@%hS0$DZdNNjSn>nNt1krh(R<_Ol=4%iQg9b_qKs=gjNT`r>drL#NWszW!y3 zto+G3H7V7meV$j&uY#QgV8SGBt!ix~s{F_@Cdy`Gu7ygI+=>?+{fiiNb2R=QYLs95 z#OYGJlEuSywFM%7E}Gjb>u-B?&~J?fqn_ZB$vNEmPh6I5J~G)%`dWY4pT_fX)`BAa zbG)YSVegM!sxH6v;Oqz%bIA*#H5#GLR zr~hqzwmRi--OuuPv5Uv~_ctE@)8#U=e?y|(l25a98f~9jKhRETW1p(Kcz(_e#vhY1 ziWW&Gbb`uC&vnY*GCe`#^I)8VAEmYt9C+ zdahM*aF}={AgcATR}xF??CoJiY8{oUO7}0naqY~sWP=1xA@=72`@cr--^%Lg$@DnE zglE>o5Uv=rXh(TJb%Ul3Uq^$@d~fC?O3g1kr#E5G&#*@;|G(K#$i*{fQ`3DRM?cLS z9xSYSj_wVO!g3ZyIgTuHp$jfOI{0kSgx*t?TbuIxWb%qQ-8L1iRT1w?o~Lj}v)947 zT*yg!tLe+$9v06}L8>`s21ZBucWC{(cuMTg6rP_y()25u^sBV4P1w)Non${mjYI%y={XfTU`EAQFsF7IvGkagSN&l@}@o0C6 z*YTW7GBwjXJnddg`oF?1-TnTH6&KdFbpE+1H=kuT?CUHkj;Qle`hlH;$1&mZI;V3*tD^Y6w?!yQLuI~C&|1RZP=_P_SB`|2B? z?73gHZfmx&Y|k#)5dSGTUr2UOTDOqwMll)IzZDCm4Y!JxWPqfBMXVD2?V1XTH>A!NOkw}9e6!G@+=JPl+I=SRPl{dr zrnzQa=L1%aPj_4x`Hwlo*y zc=~Ym3NMy%nGn22-@;EyVxI53%hg<44!-twlXx`i!#S4?!j6nRpBKA+V2NjqJ~;W2 zlu_swFL0H>y7CCR!~ zC;XqX*FER||Kzr_(>F%{UEBN`yZyX>JWz=L^`zfSsqDbApVE@vOgCkBZt&gk;`p;m z+Ui@XB?2z4aa;e@@9~c{`VTKme8QHqWz%b}Uy}ljUdzSZ=y(#!6rgnD<>cSj8cy0> z$Tt>N4%ubvW;YoX_lMvm#uqcZHmklV6xGZS=F0OHXWq zy^WUKiy3Qv_;xOc_`XQUabEyafYJ=P3nB5ZcRh;oWzXqZ7qhwb+QjXKZ+mo;`U*qO ztjeFq<#u#$ipIK2b1Qzm5okYgA%eB{iM##uNgP!Z9_sIv+NUe{r1+0}O)|HT1iabUi5 z-s1#M4~svu+l3F#J7IH_E5>Y7PK)n><8pI29$lSW)wy8#VY6SH_p7dFF*52%^Y3H1 zG|8e!|HHZ8LJXf-k{s_;ZP;>klFRFm4J^`Y6LQYn`QfM?{Z8cS$u^Z^Cp&pdFZK8t z>^bBSrdq_b|Mv@}$*>!jCi4)sr@fapWG!Pzje_y}W9} zkJ-F;JNae2_FORCacat6vkwjS54;z!q~DME{MpQmYs=$k+a}CibU(sMja^#v?^KpahBhU~`7TdQa8FP0P*64ebBxV7K4Im9#gcvnC$6lN zjI^Fw%qwPHaNjLBbMEVuwf^_koje%Lyy@rN`+x6lkFWGf+Z<`|(ocy)-O}=F)vqrv z)vPx*%{kD*|8}`r(V!sIDUPndQ*iKqk{8?lO7At-{!h=RyBTC5_b|?b@J(` z!ebJ%ombzg%|3A;CcAm1{Q7H~LqGrM-N({C|MljB&lYX>jp|W29A2wb;iq(B-;HVK z%{L`(?3%l=_YtGqNAI*JNB@Z$Y2Ta5F{!uKeU9(9XP0#2%ai>7e@JD&?($)>;rtry zn=>}%yqU$JHrF_+(ZTlX)eXF!pPq}ncvkRB+3}GEld-GDlu1ol;gc*l<_H~(|GhQ7 z+FDSgMQcuHF~^&x{R^}OON2B&96l?U9%;U@GycG)oz`zRF;;x-Wc$ONz-s%UPqnFO zKTAU19O3_O9=jeW$y&aZaiQY}m-e$KDx_B|cyMdiB$iDs;aeX1$7k=`*~C9%-N89V zTjCB(I^z|>lCW#?4(r6F{zhJY3EVMu>aSMbdu?=5(Dvq)3+-mAcW+FXYr^>{Zl))j zYEeSd^DV9yKEI8a->%HR;evNPlXk6}{LRZ-&Hg@eX58HSZk=yobipC{4JUc_=N!`1 zh`Ka&R-8{;ZnLoeo~4}M_ZR&!p^sCR&FcSe#<)YZ@z{xT$C8{s zOX?Q6YX9|4I}mum`M*%8bdT?i)j7X5&h(5qDR|~u#^l`OgoW;o(sxRJE#$Aw*etpu z)U)9?m&AwZ9Ge_>Je>OGLw50r2UlDKVr)J*cCNi~_}PsKhGxC-tb0%1GmZI?xW8te zY!~ySsLloK44WP=f628*$nnPsLHiG)+y}xYO`TR3=b|JLd*1Nf|6acGiwC!P*Su`6 ze>|DT#^F);9|O1Yqr$IaCM(X^n!&Jr=e20%jV#BljM9RiMcr1bUD>G+FaG?IqU58- zb+#6N@0|a8N6g)J!zbr&OTyMD3hTy)#&}P-DLKFJf#W|RNB*EEE25aE)oyXQu)S@4 z=Y!7{)9f}aPk9$rXfM56t;zFwPnbc#c~2J3sDLdGy^pb!a<)EkS~x`{WcMVM6;n9= z{aXM3S6R@L&$&$=N7W7q=7yQ+oorlQG+%ad%>i54i&h2FvrBfUb56csF;h$M$($e4 zS)LqucFx5h#!TU${QO+AXJHRkpF10?AdoO;#Z4VnKk50sCw7DxWcWIUu5OUbWlh$N zocUPJBB9}J+|j5`m(B&k+iwdwX6GjO&B_rbo{($O%!wWC0ZE)vjdfNZ@Mt|bLuXcIC%iu}U8P z8L6kusy|E>a?^6{_n0#$! z|1%-Sx)3FevIB4JDxRw}RXAAJsWgUuQ{sC%`$KbVr@NWX%fxoorkpQl56@=$lzjhV zl#<5B??0c+C*Y(Q#sPYD~_*b=P`8qb6DDXqQt6S$I_HK>ddCd9qim* zk-GlFj`X$r41auixa4-%llzAkJ!xAXbF1?~Zs&p@E#JQHd2W0A-eZL$^NzS}60VsP zxamSb`?rV5`Y4z5vYE42Ce5wzMTpX`I zpQF+=iQhj<((Q-EqdP~`^7t|i&r)wPGhv+gurTV2mTHrkp0tErF4J75EtdW@*SO~~ zDb3{SYEroo)mWj{WTwO^^XFQVsrI}J_u0g9PhL!84i|k_sU-aViH2w4q+72OrB_}T z_+hx7tKD~!@TBQ3&P6I2H+6EQUaX5a&S$ZZ#aSrg?H12P3IhL*<^MUhEZyLPj$pva z@S<1F_spVyP5W@8<)C};uU2!*9p!$O+xpJ1rgZvtE(kv?B)zq?U?F$>n~A*>URv|Z z%RgX#^J$$?qVKPZ58`UpeZCXEiS^5*)hZWWmvNfaPSl;f>0Zo-6M;%UzI=$f#@U>I z$UEmpu;=Bj{7(<(N$vd=_tyKK%9%gYVmBB6_}uv7>ja16a&9NO)@~3ia*@C1=gV@j zptwTV@!OA&U13M3s|fh)%Z%IP#6D}cn!MRLwvPwboh;H9eB;=<$4YR@i4I$RV?mey zPe9woPU`J4^N(4;T=OY(qx+nt@-^A2ZSOWp8aCT@hI7sBaObl0+dFw7SDoSNC;D@a z9aZ@(VltKEm**63AC{Z*z0#gc-E;ELLH1eo|DM;^buSh=_$Mv7;E$*LM?bMg`}zwz zR@S;**cYs1@%QS#Tb&F3A1bmH{Ile)uyM4Hd2DuXtgz#x9qBv$l{8k^+p;_qa$L?W z#N`%q;Q_~##m_{vJF}HulrBjKns|WY$b)k(0(IwJswmXRghhVb8Fr>vMPK2Zu%rC8 z?TTyEo0z7%aL)hWX_L<^IIz^8@7?NO6+#JWc8vE-<*Ws}%Cl88CpmU5NV(;vRj4m$BCa1byXov9w})3= z-h8Mcz&|go_h8@wVCqKU=D9^2GU2J+wH2(Xe{B@b{tjyMb zz39Cz&h%n8Z`2^-n&${5-xnT13H#2w+#Y)e8cx_kux+C|Fz4SJn zq*0`GG2!x;+co=MJ9f!eZV=jVl&@3d*8yu&!6TE|jlOBGoHAjhna{R4{}&YBI`c$v zzu@mQr59H>82$@Zl;8GemGHqAp36S(sw;Z07{c`EVB7gm@gLi3J3OOmrhRGf-u7dv z&-3Q3DJwsD7oSN_e$fs{%=jVQy(OdS&`}whh!OvzrTbKMfYQM{cOoi&On+&@T zbu-m%+p5+yX=A%e)0dOi=FIW(xY?3z7VOmI_veD~O%Zb|!IZ~lQAQ{8Y-KJn{y1J| zx6I{2y76_F33UfTmYr3x&+Sy$pLks;(oE~8`~QtD6Yg(#8(yfi!?5JXWS{4ywPuax zo%3!Sn5QZuXLZ#2+rxd;LULtJ-=3)K+mO9az3+4SrYUQr)q^*Bm`;y7sI>Y~RK88m z!B9uzxsz|J?vqN(S8Ym(DC%+lvnlr9JC}f%XyJo7-7>GESKA9aT0L0)M0MRQ)Ag< zR9M|=w%shK@N`yJX4>HEwsj?^-Xx9BBClB@{!Coi(CyE7e1{7!@4Le*xelb{EDmLj z4t*eg=D_qDkBn_HbOe`}U+qljRM_+Ej8j^!*b~);hsVV=4os6c6wm1Gq-i)^gzLwL z3*tXAHa**3|9ks(JImSU>()$F2w{!dG}B~ZdR+VWeQ&pL7CH6z7OFM*wZFLZY}tYH z*G^2*`zGXQW|X_4bn>@%{_{3Hqehl0vKj`x-!l%zH;1$@x+Z;9Jg*1EtxYxdEO)r zHI3J6LyH1xf8@N%Rytw%e05^+)R`P!K`adCG&73AN*Y%drIf1GnTa3V@Z>_Rw7{(p z8%s}B={97B~OpiM6f*p-b+f-eu)_3B<0_X4yceQX zs~*h$`*mOST#jEo3-a|gyPk~cT+qTS^JP=!?9BCTC(llI{lW0-LvfZ;$24<3{*;6t zjrZTQ@q326VDn+UvyweI<9$fZJdR1JoeFZ3_PR`sySa^hMR=`JN4u9*(Opfu*A7( zB@T5DeqZ~bs@C+nGoj@1%)8S#HnHxTa{of(kArbXwm!=H_IOs#IZu|~JrBM{AHMEV zP`qIJ$LDuk0-A!9PAIB)%!y%`7!p#%(ie1pZ_{)`$HQ!&PVfJ7`u53Vr#)C$SJ)|M zJl_BM>IUC9g$)zeb}H0;P}B@komw$T-nub}2R z?ZKn7+v^^x7|&knkncBJf5s&HPKC;sj}N~T-1&Q9+S=YDGG#}~PF#0xRhi)P%`D$U zQ+w`t_w&DJ^F}T0@1M!x6>;CDrdeeDi`LCv;%4lf?I}l2x^*hV&zKz_;#+euf8NJP z>FijGt!9$CH(l00S*qW?A@kd_DQ&qe#=jq~{+G=7(~ITgUKfK|QID&>EnaSz+qod0 z_j7d7q#TQ%=gJnDS1(B4q$QYA{o?TXot+EV`-B|TO$r*0+n?}aEI&W(n#+akheD1Y zKSU_)*e5luVp3x2sdigWh7VsQ_A5*D-Sn$D%FNl@&Sc0Cf1Yo7><>ZpS^m!+asE1a zj(KIuU1z4BQ~zu%Haffi?&fJVC&lU?&8|>C*2(>7LLvX1XBs63?x_S%uTXk%HlQP$S$3Yh?(!jd_Fs>An{VEdoP8qan4aN6 z_D`?*y(XWNd}`O3zz zkhDt0DV~3mrhHg<+>P_T4~wX z$Y?f8OFnZ^)!`b~8b8wmse85xsW*zPea3O^^by$*JX)K>ASz^{oMZZ_M4kBlFdt_ zl69*mbCfBaNWUo^yMWv8^VF!?$5Ve?xb-J@o}J!-YcC^o1z8S9{dhU$|AvG6bRIoC zo|eT|v0SYwW9v4T0G8kM!}+cF(^lJzIHql$CJ3ipig- zrp5Yt9rcr(_;0>geS!ankmFm`y;5%4zk^Rs{3lwoNtOR%$-8ovx3+J3?`yp2%(>>I z{%)e<@@3zw4JVxGt9AP@izCindB?3w-aEGyT6}$YW?q-%O0(w)M@@JX2{8dX^qRK zK5x>pc`04{eARTMaAYE`ybb|*X>U4 z(Yevq(&D$f@0?k(MYVx~b-|kC!zBl=<^1~ceydEyNuB6V0*{wCD*gEK^0Mzcp-8jz zKB>45Yr`)j?73xIr(F2&0lWQ=GNlvyKM3ZT^^{p0?R>gA zs;i%bF&!|!If=#L(z#`KoVoA)WUs4|P+2^C_H19f3Z=sp{mY^%4h9{SH=3OACHcjN zPR9y2ap^<->sObwy-#8MKZ~PEyU~8* zN_M6V4>$JdPna2e%unj3+3f?XcW~*|uC`NB*thZ<$B!RezaAg1nd)<*?d;pX-8%*% z&F#4}W+vdnl1<6UOR$eS;=Cby6_0Cu`XUQZ* zIn{+`KHq`_mz-doZ&u$J5&s}9{n`xX?N7oFZ2ozJV=mjRIbM7xRtue9cQXCe7R%*Z zPHx^AeC^nai8`uHanB#l-g~3u)|-pzk2lR+!O#A(! zIk@}SkE`bMY$w>>d(iT~yzY7VHkS#p2Xg2B)~bG{U+^i?>_2E3#^?0e(Yv;_t?_2L zIcv$W_qEePRO}1#`8p@fV7~UJM?pR*Kc_(VTI0f}n^l|4GVGe?oAb-F@9cDZH%GXuwFH+a?^1Wqei0UQrc6a&=+JED`akYD44)%9#m#~@DK6U-%c*|bA-YxX z1xt*4Zo}c{ZbwZ`CS-oQIqT~62Wz^Fzo@NDDo%P?W12H>(NXCdJLMH~J0J8^f7obR zQoVz5^WK-PYE44ny9C2kn_dK5JXUtnM`^`-#d|;EI-lqC+DeuxPvKG;jo&>CN`?Kla2m@7b*{2ZUX6_D#z4Z0U`yR}=UUJ)4>J@D8T+4XQV% zTv+wt($wV|v(sPasw7xDzP-9(vc<_6E^i~0e#l(@yx+`3dT)3`R0V4~r`)|<7wz>A zxTk%X{$W8sPYzdHu$}E3AI>5(rIH&*&gyfxJ3AiUT5Y_-XdLnT~6hfYLlG8$zI+WizA$`Wh+&@aryATEY`&JFc>D*fcAk{`?Z&V;DiKV`S{U#ttQN|V0s^5J7@o!OCWrHb#{+gP6q zIUc;UY}E~&+_9D?8B~z$HG9&$f{(?g%8&$&m z`uDKu1yl*Scefl8Ui)=bFUvb2$CF)?6*+IN>|Ag_yR+H3VfqdWQ4=-E4T49r|9COw zl&oVdoxQhGRo?HS%FT7TUP62|+tN-gTG04kll%H}k%B2^vVSep7Eg4k{qtD$YlMhwUhsNo8%l4S`}xxaHh>g#y;Uhez`CDCmF)CmD8>Vi>aDioXuy` zFrobk|K7jr6Ti)$cQ*C>i|5)xvxOYh1D>eu^yOb~C75zvZix-UjVT|(53=8%zQfAX zKW~zz(bOyNPM)p$=O`|x^`ia!8J7t;wh>mjP0epRIG?!QH*a^*{prphbF%mRM#hf} z^Mo90J_LIv9+fg$F8uM#>x2p$nJS41D>kl7I6isWUyXM=!(PsMd+=bq7t2rnsvFL) zUrhgVBl>^#k5Vs|pBAz|dlan86b__+^D6QVtFZqLYQ?3L+6w-8vhvfGgDLiJr}94c zzOLV`vQYT;Ob)LkiM3$~8&`6qaW!(=Fzt5u^zutq#3JQ}!dqPnat>EjS!_MDKH-7M z`8LhQM<2{`K5bOYntRG)no6Tt`lq0rV@&MMtm$e^zs$;{`6SbCsD@n=5BPdfC~M&ts_!-XP3XHs&wP|=WlXWtW#}zcQeELTJEj5#(OeC z%+f2CI0`xGPx9QSWysvD`wx7P%*jyGsy+MNABY`Up2MjqAS7fwW2ND-1Y>`vM}-xV zEFA|uIx5W)*ch4g1h4R(FZBC!=-=-(!l%}(D%*ZH(lsaZdf$!1v##ILE=x&UIFt9r z1n)IB*S0g7onXr`cyjJr&%sik^j{}B>Mpvny*a~efQ9n61l ztogD>QS*AHZ=vc@bWl3f?_f5?kC94h`mA~0I*=W7|%?U?*WXf&1XLjCy#IX0XYv=NI<{d{l zYgT_`$S+$c|8^BS(}$z7^IuM?*kt|j_>2m}ms2=4nXk95&Uocgptj(qw9H(NuKY)L zHVQjtpPW!@dm^1h-&(NdMyJBv38HgvI{%p3RQ~Ix@WH>vO_%fIC%#VZT+lmj;;j^m zZAu&*T>VypU#eCMTlt?YUfg?b>Vv1}d6ItR?5dbGU$A6Rn($^u?lq#0#j`o8gtlZ( zVyv9PF==Xpj^G=UfC()8ywA8cHLZQ{PGsTv*HdMrrf-?KUZiF*yWWSKkfv$AZikc> z++fg~#^T^0*m67LjJmvMr-LTrgf$hWJ=^`}9BMt6>>9L?>)Rv-n_DKTUVf^%E(KcA z5@sSb3!C4Z2vB-)`^F?DX_lP}64&J_-@26Smt6d>>|W{n%a*@BoVcgTR+4#n+KWxn z2c_Q^tp1WJe8^ip_f1ff>$*4YMk({W)_+m9TkRaD>N5q5LklEZ0lR88=Nj63NG}C@Av% zfwOhokv;7bIiBsWn7m`b-t&QzrdAu7_RqQ5c7E2Q&ULD?H7<+P3e%FGHM;K$Hc#ka z{&J?yW<{s9AIr_vzcrJsJ~AlYOz|%GwMNf+!j!Y^hcw@>yU7@na-8qPxx?)iA(u}3 zz1ZBo?3$OEwcs3n-yiAx7grt?m!D|UZF<{f!o3^&J{74pot%B&=8emQ{hxxZl!K@4 zzpNks#<=Ns=YxNr4S$|LeNWDtC0DB_TyeogAck{U%gntGEBH;$-mGRrx+X0p|C9o4X$r70Jr zJQaQ(WEQ(INo#&9^ZjR8%Dl(_IC0G{Ui65io%bfgO|FU@0iBaQ(_)`oPteRc;N0%w zpybJZQ2GDiNg@~c_nq;T{~~oaiOK5a+#VI_C{LMPYfnCV5xU7y?oIUTIH9hxBG3A3 zcaFJCh~FSPfAN$nKYA2yPUV;+UOC<5va@G#XF}n@7_(OkPf2ZBT+h$+#o7E(!;J^0 zHC3~Mk9|3<_Ojt!sA0#uSn=z9KY6W%nr}$W`5{mpvTu?6`Zuk1HxKJPl9BOaSwESh zNqJk0x?qZbjla*=fVBPw{{1O#Y`6Y!<(4$w+h=;_-<{9CC)b&#{4)@CdpXIyo!I#$SPn1ftwZFdl!BVAZMt<-l2TnPrryKKmix-&fVVeJyY3asOHiB<5 z?zxq{ak+3z&%rw)=g>T^+%zW5DwY(+yHSoiTrQ;fOk35^p=UBvf5q)PxyK&-Tr-XL zW^kqd>*GHd*lQTQ7}}f-J}%{DT%)2|^Rc^rNA8;smcC7^g&iA(bc5ZlMG4E^&Ca#R zP_W*wS+Q}>oeEynl`mIbixPcz%_>u1jjFGiqRsD39pND9fWCyt%DxA=ODRRZ@U6Lp6NKYM0Wb9UHC%hyiW z|4Ol;ceDA2mvd?!IP1$4d{uDh`}1vsig-zGbDQ%gEy32q7B@pLL@2#bv2DphbjFB)w#bW zsx&2OM|Ls3SSbCaa)RUM<~p|txsNmbS?2fa=1kJ>P<|6CBe?t9{Qi@|aRbgA>?Qh;pIMKE4$8_H*a7O-u_Ng|jmk!;f4;Ecy?r`X0 zFSu=TGpJ0p(J`5GLH3TEGcR1ttFD5EEidxu)tLD@#$@YNo(WbrTRtu4lBu=3b(Ge% zCeM4uf^VV^`(>qB>Xfy7`~9;g;q}Yjxr?OjtVG|ZDS3!b{q4(ga)Hx*ArpRI)us;@ zUB9L2)lQba>HSaD=hc>lIZgMgJW}(YUEc3?UiHP_57zs->_2R9E_mU{#LZ{l;+`{E zLTdi5jeIpG-U&x!u6iz*apc^IiD$MXP1$*K)7P$chHZboT=rkTXDY{|=DogiGSbTZ zq;3{3zni2Zw>h)mq(kil7XhDd*E=7ib}p!O*u?jIqtWBe>^&1^&)DnBa@4;@P1|U} z?7uDr_JTHP(fZl<%>co5nc z$E4w4<+{mnnXtYPQX|I*0V2*Rc`C}%{68A*@ z78h@Rx%lAf#I-H~ms-S38Ul0o^0Mhk^GVHd^WbB-GHHeA%^$+LrM^;9vun@pUXvSJ zyk`A*(|Iqs<;@B}<*GVbGfGIc>am%OB+dFwloPYd#^z8ft3B)PmlWm&wFS6R*hiQS9LtrlsQ zos?IVk-PLmrRJd#KhKT>g4t`n7n}&=_b%dHXL(cX)*9yKzK@6IU6Gq|W4%Q>U;W1T z4U)B+J?_|Mc(7OtiZEYna<|YvYV+l@?bhJW?lU>QHDB@zxLCVp!t_IYF^^M0nb`Vd zcT7mxY4#(B|GF5wv{@83;rRhGt8>Rrsv0$QEzmz0C}DQ=rbFK2&IMqVt!J$Z9) z@Bi;>6K5}Dh$%RC@nnF)x5NT&(K9w@BDZtF^_em^+RE2;DyY8?UF)EcaWkOLlEpcDvtk;j z&&h7yAO?XMAM5A31TYBv$YChnoN|UqJYteV=mqx4HV4J;TzR1*Azs2-V{o-%Q{tAF z+pkqI-d<)9zw=;dQ=7g?=z(b-H!hqw*STOaYr&QeE3a!lxaFX_>jUStl+42)cdZa^ z`XR#bVA_{oyp}s2miD(#;;4z5yl-1$@+Gt5Y5zm7KL|g_F}?JI|BffQ%F{JG*3Et5 zA#tOBvdt$mKe=aGCG2VzCqrJ#{aNY!I%m_b(4q|sZx-ZC(2DisczL#VearHk-P;U5 zr_MI~>-}fW5{u5H=D9Ae>{g)_TQ5rg)pkBD|6#G<-im_vQ5*a0Z=9K{RaT@Kxae_Q z`sRb0@z*c%JzH!cm~wotl-O^%G9?c`IkkDU-)??YR<;efFu6DXRI%u@PwKHtq>F-7 zeI_~YQ(^O3R&&w$bl#bT>Dz7|H{BB@di-KT_>W1JKUP(U`B}V}yw1zwhQ;lq_188P z{`j%(NyO6hGb4QdFOIfqt5@2x!q;L+!W)2$C@{1uUCn_o?>uXX7=CkSoQC3 zlwz*EEb+(u~g4*%l{H zcFuWn;&As4DdmytdHl`vkYX94Gs|>GK~f?zcU(@{#G>Pu@psUZ1(D z{%vEhmFVP9e$8ViFH1A+IC|(>W2DjxbMv(y(;jTNQE9ZqxG3ad%K2Ki4ckK>e75Gd zPFeOK*2r5guGm`i%TD)ij&VPlrz> zgf{$S-j}pDd(W4w89p_UOCmbOe|&N;`K0>m>qdt7H5a=+ewm-AcB(V~+x*L>QYRNb zic2j{(wU!Z{AG82q>AR=L%NH_HB|Ujn^ZHV9JZ{IdQvd&o{C%3goZPWmX^+cf|#xtpSRg;wah{D!)*3>4Tl9SP0|}~YqQSodB9)4q1igR&5U;f^P^7V zL%rr}pBydil$s%=;y5q(QJ|9Q3%BVEA~~M|FXjoeaqCySemP@K@9cKH?@SIRk0M!x z|IHMb)YvO_E^hzAvuv*4o;arqIWFfnGh=kypfl5L|C2+{zsxZyjZ!|qS-};h^>JCR zS;&gzQ<+ceag^}lo7L)T7DP`pm@u(7E+{cL?Xr;amj&xp*v`HPKjd5YW0|_qt_Zsg_tP)f zxOiTA5OSg2d}G`EPTLP1%s+JGnpU%j9IPC*H!zTFrU|w(2{mCp4kv? zzwbnh&aUlqR(T4jEc+vVzotXB$u+LxL&Guq>eSWzHCFDkU&-YaW@!$C*1!t|J{d!aXpdz;(Ma9k4O~u>`@7*I4FJpaC@Pv z%tCg4Zy~eLNuK#P=U4tXt@q*m!gFy7X^l7I+~eOgzg^H8^YZ?`&sT!|*OnYUy6&LM z>dG$DlZJLZpY4BbyZ(Ul@3-iUEq@*w^Z!5DQS)%JGxt>~9okD>+j>!bSHinTN5 zm84!yIm-6kA_&uEQH=(>s)xbN>B7?Cl*vPN%*v|*T zIUh4N3-UagtRrC_wKmXl%Y)+|PYUaW8l1bqs_3}JcV^C7R`;X&e^|>IBa9ff_b%|| z$W6KMOy|Qij!CLEO~zHBo|_j;I>%CA(-eK7y*~O;V7*CE+$Lr7qAyk)dH%(da;5qA zUFfqjYT54+5dVq!`krE)AFA$EOYOgT&Ci*3_r+s*)vzatdOs)py`uf^#H75JGyGmo zkg>8{%x_h?e%JPgGtzmZ-Gj~e?Pk2}ICIrZe75x81*_Zj_O0W8o8`HNSKzLwMbqn9 zeLs}tm)n2YIc>wPX#(3aU#5p=Y~zzLSR~E=V$PPyid9GCj6!XFJ_>JI#{T)Bitd+h)PH(Ij7E< zvT*8|6*5Z>9NB0gw|w#h&bE1fEM?mh*GMKg%3F)9J7f2K%6UzV`N?8i4m`;Ckjcu; zx2Tlsn4qdj)54t(S&F6RzK&!`u$gMY$?)Tx04v89t^-Yzk8}s$s`!wT?AHHaMQiz^ z2R#WBmOt<-E0~~ury!FxFYhuwb~i*VAJ5ghy(UNR&26{S z^K;ha^zSvV|K(S8=~Dly9pMjK?jJkJcXNra-tXl8k{0pe4{dp7&g$0=-#*rqS0)l0 zRo3EmQr`MXJG<_`Ejhxu33)GD7TcLDZs$1}9220Lp5bDC>x?`5oEj&dNfTD299Lgl zEqdaUy39#_y$vT=&OcGQsUW;Q=qQtgX!eJSh(E3CRHQ1_Zc4VwO5Vm6FS_Hf`?&{R z6*nikcqTRE?^)y;#9&|hLB8OkfNVyhwq2a#za&NZW9B_Z=5^lq3HLc@wL}B@Ebi9t`%Xd|M1vZMp@lVf2ESQZrqp6(gr8E z|Gk<1?;?-hZUyO&BK9dM`@ViTpmrcwwfT*{+zHnDgvtDOo6nlpY-#m7z+xTWA@=8^ z=eMWHPU}uC+`*mqYrERt^M!`<=XOr?Gky{Ut zY&{#t@NB|Vk@Z`{R-WH#XTi$d*|I?6!QquRd@PCzirF|>pKDBfct=<->T51{4U_zj zChq6$@!Aq%F=sZ%DI8pVpy~JrPM)g;IUk!97fkWsPU(qNXb`q@baxQ4IOD!OyN0`~ zfcsF&E6-VHE?zmQa+8DaT9F!~o6@7J&FUGQ4Rs$*1PE-4TOfF3>#qZ5ealyKRaAuD zU`E@CUs;U>k+;n^2N-oEJ2`x|@N_D1jG_L$rm zH5<=PviYfT>wpV;ybJUFEsm=nIqws`Bl_dVTOCeC zn-cf%FCO6^Q_k-36Z`cbf6zTi(Pnit*eEBxPG z3qN92HSNu&&`%=O4-RJ=YQ%5hvnzBz+kSJcM97<|JZkwrjxc?wUS0gr=~0-Ec3h+5 zv}>D73r9u66C)z(?ve6u9feLi9h#0 zo!;~Nig&m@Uvjo~(?a)c9{ay+041m7Io-(xO_P+QrJfo@Of3wSdHn2x86#hM@`j7W z&zb^rmQ<|W>Q%e$YoN`K&nyY7dFqJMVY zd@%blHojhRN|A)o5=HlGy>rA|L>h>SE=3ZR!K+wL) zK1Rr~^UwEv-}j2Ao>qHtLhbG5m>1t%ba%9J-}SPxUbemT(9A!Y8IyHwAI;BWH7s*o z9`*S|obURG6ZJVtIi5??Hx>Gxf8zT5OW7J9>DzI;!zU}-w$9gGG&TORX!Z7mmy)F| zcQ4`2zQENtZQq4Cyc?BEwk;HAe(@*5adOkVbq^V%FSd*QQ()WaCSP@OM$E+&+npP< zO+NTu&#|y(n`|qu{cxGR&Eeze4?=diJjr@7vnCI@A%7 z=j4(l^WS`2qQBcgS@Oa1iU${(_f8a#(|V?vaDLLewEI4tH;yncI52p+IEGlpEH1t@ zE#^euo|AQ;!GdKHi?lS(B|Mquyh5|jNOB2Fld(aRTa<&q1fz3P@_lPRN5xxM#WvPk z39%=CiP~{M+{9w1!_u^btv#z>M=7=Gt3PjO>e6aBx_|50r!PJ{6z(s0)h(Ai_1e`# z*>M&u5=AK=RJkfl?QibrE6;wYl>X^hdXZSii3Xn!$$B+rCO^0gj)i=lBp*={s!+_k z?(4Id?F%IBY+`gcSLAcu%J?&3EwAW&ro9XDH@^y<7B1T)ZFNC*e?@!z{hd>jt(?pw zZ{Ik{u>Z^HX(2`C$8YVFtAFD**GzTgiFr38H*MJF^z3HW$IRQ$Bxdi}bnw|n(~_*0 zd~rr>D)`my4s*-@ zDR?aW?$N}bHyg$FUkrMr>v)-+{m#}08rM>1s|J+B#GA?dJ$XE;;GxRxB>sP!qm4M# zZ+&d(|Czume&eKOMM|dajSn0CdKr9F@|)~$bx1r$E9&glxad7^7{l%NteRvO6Fr;f z1%u6&NqaXwTjc1f{bN$X?+Mu-&IUhR?{o9D@wsWCpW4Lrt_#O+V(*SUtbENsnwx!A z6YoBw%n0jqFZiVvOGds6wb?9fbW`}CaiGM}0IsJ7S7ef;W>|79eU@=+N=!Ci#IV{QBsp(9*B zyM*5Dw39mH&Hn7O^7pTivw0)s`HDYAC7P!!n7iZopJz?XdNQ{PTEeA!qKYr9d1U+V zwXy!Z2b|yb=pB1yEWY>J%-glKQGZ1rKTDf^Y?;mDlQN->#+4H$XD{9OHSMQyCZAcQ zxxLhyY`vI|^Y`>_PwQ5hj|;mG$TzW;qSPI9b0=|8_})dS)GFE7P>pZuRQ`BYcV^S_2N5Bc7e`Ta7H zJA3PtnBA@`FHH5LvZJNnUAt1hW^VEBbzAE$b*d%b-WVY;86ORI|XYePq**A{z~2X z!(q|BYZ+fx1|R!+wsKwfa$&zclJgB_S-&*dx7B{b7uWK&|1@V8ykd6Gm3bGbcJ4!_ zI?w03=Hfcne;ruo;{W+IfBEaLhXs2+yvo`ifs$&Zeq7(D-`Rbosi2 z8F%Ltuc|+{^IhqmS@yC9c3<2NmwueJ{81>kd(CzBcP;6BHV=*NNnO8fRA>?=Ut3wr zxGZ}r-?NpiJAYZ`+4Dbi2?%;ox;S60NwM+kPKWvIZ=TES+4M0|T31T_Zo;eGJ>Oo` zE{!${P}|Eto9z#~z2uVV$vb*OXI&$@o$DLkcfH*vG& z=3RSkvi7?9N7>ix`%9n2hxQ$uk-aGYTWp!_!&c8&Yk33ti~(6uavbbs`#*=?E{YozjPLFJD;_4nRoG)xZH}r+Kg9zJ!<4%GW-4J zd2wfd@I0FAZ?|(E*RN?CCOgj8{UoV8zt)l2>M?hor_1+~kMBg8sNcV(+k3L?+}(49 z_NC9N?&UvUzWZ9M^tv3s`M*ERuFjgf^Wp7n*Uo-?xAknPt@oD~vx~o&ht$h+^c`y{`V)KzIdC#qOTJ5!f~(Fb*>)`wljL3 z^H6ej?eS-F((^y7*{*y3=h(A9$Fk2F&fD|V++Kcu?ZGvs%kok!j_>Bn`+i$YCiUEI zp6xqtfBeCae8}+oCZW9IsPZ-EEB>Cny!=JG{m#_g$4)FSeYZXP>s)8Y$4k!E)@*$J z*X4uEmXfBn%!JtMMyHzQXP+{0yV(=0TfjJ9aC_YSYX)C5zc%0B_1sGRx>P72+ zufD~3KBna8=HE>rUtT@laBb_hjZwu?#j-rtyEgu6TKa#A3|GK2jfZ^mOV4UHNN~Gn z_xyC&cK**#hRxgbuY5_&`W2$uG|72=%h``>t>Xn=Heaw~c=x%X&gPbO;{Gr1pUbE; z*oo)`x-dsQe!We-slr!%^`dF^pX**N{&;hlbM47Q zv!Ba+zg?6w*KX<7t+#g`%&Pldy!N%_yIs|}8=l`v$=0b9nLSHhruggDv_pk=|K!$x zcs573r{D@(GI#O4^VxOJ?=fF~!+$R4;fgamzh0kpxgz&}F4}j1%5%cHDEpHO&PoLUQX{YB!%dFK;3E zrFs9q$qo5@`Q`>DF2*xT?%LiuzjH!r(Y&HP@w3!>)@_}B(8RCo)=#Zzb(iu>ST(u*h-j^!&oBF2y*rec1T=$MJzT0EI zyfS*uGu7?SV$AB-&3_$beSGo3h~meG_elEp&Ni}J1}_qQ6F?%kbNvu^g^W80I3^Im_|Jb7X3#b_PS}a?ELSS z{hHHbjh<@%n!I%5%Hr?B^L`g=zL>XVXZXisZTTfi9fGMwGae*w`S@(hvVYI6pDVm> z>Gb&dm9!@rZ=`A~Let}GeEv;3sX6b=-mG&m(r<#ZrTULuoA)aJkJa154TAHYwDqs9 z$dviFt~ppb_pBj5Uv9QalHKF-jekUXuJ5(`{QP->O8Y)p9mYBHMN58N*IW?n=o(NY z^y2$bzV^d&kIUEB*z$hyO+1suz&C#+H4la{neSHxs{zuUF6QoPIXDF8B4i&C7OvWOUnP za;>8FVZ{ZpJEvc8>)RB^{oVZDC~BScf2%KZ4oUXCurNJeQLH~(c+SmfcP<_-%l(*t zXnuBVH1qaZddtskH`xCA{8PEVldn}AI=$AHB{^udfP>eX_5Vr_{kXhi+Jsvg$EW-) zntp)UTfzFYrD~;+b^NyvkN5sNo_?R}T2<-k#I?b(`jOdq3-b-t4c-aU56tvj;BvvvuG>Q6UuE;68?R3b#)Q9m{cqW} zqkmtNufO-orNHQR=~`cd#}}@<%~_Dw{pfLd{`p|0oC$BIPVxM*=h0jFjlZYY?-PA< ze5Go;kn73&Iyuw!a;4Q>ywA`5`=rGGtw&ZT-j^tQyI=4}?3#kB-(23vqzfm-Pt71d3Vcsj(N+&%2$;L~gdY*lg z_ctxhH}~~C8EPeubUu*2_o3~paZ{cC1x>~1Z<`ILW?sIz-|z>k{f6(GK+&VuSUkPq zhv{VLFM03J3VuFfewBIawSVt-{fv^IFBo2X#!c=5^XHwXA6k7myCZ*J_0*cYS|yK* zBJY~N)+P5c-bkt45m$6W*zwf%g{$l$@`F=2wx5((mu&ERj=M7Bxf}ime>9yq`f2IJ z|9_s_zpm%}$ouHc*5#oGy(T?>c(il=Wc$vA;Rl5d{rsPP)2Kb1t7hHTsXsnWmFwtv zn>zh~USllNa~;Ny-ZsJA`NjLMsjoZ5_-DK7^0=hc`j1bt%5ZqL9kK14&z{bI_8;@) zh*kB6tkWZ7TyNKxDtX*A3t(Fiw5R^?)AE}=hC;Jdls}jpV8~fv7p!WT!m|CSz&fKT zwSO*pHRy7M{Y~k)&sMVb{9*2D(F-iLX4-;N-c052V*4t3hQ;J+jakfslJ#FqG;X|n ztiE0IgKbpqyBnaCRk2gGAXG^st}8of^%MWEr+MtUZG{~_ZfVb`Jg_?c?<>=?uJ&Vj z&O5JmK1k&{w8QsG=7RjhpncWLb=Il2_BaYtFkAU^Vfa%b?1rBY0)stI+jPxz{?)c7Ihc_U=sZRQw;{&9Zp8 zOX0e^;Iw{2wcwo4jE}ljs*T?&^R4%UZhZgSH_ZOH>akxlW>loF|1Ngnd`{(pZ?4vy z3snN_xjIy}>P^t=#XPaxDNRx8O_MA;<$k|O=9Nq1iaB=mf#1!ub#_5Y7SG>Y z-^~I_`8zy?1f)ej`Uw8EiKrIU>HGDucK*(9`IfbOyWewlv==q}|9k)c-p}8*@2{<0 z{OG!vO3Tq3q7QigJIj4m+`sprT*CgH7vsfd?m9TbNZ4_?7SF-$dZG7^{dpb#f0tU5 zSrpTRpTWCSE(jl#zW?Kxb$<2j+hLC<@VrZ%e&Doju&&S(Waa_=0`k_r8z4&#~{RZhqu_fv%N)-1*L#_dCSDud;n`O}(jB?n3@% zLx$sr&f9*!Q{{AmgX3W4g8xSzXdduf@c-$S>!#$>H4KoNBeY zYiN==Z5n+rZ;Z?7CLflYwi~dEZ;@sh!#T??DRqon8xSABeOW_9x%&S7z*lavW~n`Kuk*p|dta8Ba+c`CD9s3D ztpzleoCf`V3$brqXPz_9<*WFsh6tPj8)`ElFD?qu<8 zn``|t<8IFO^$b0(>tFAjC!_V%ze;*FEBoDx%j|C(P4jznFs3%D_Hx`I-uNAd7n|OX z_``nq&ac`1Z4WZE6Ev<}+kZ6GXYSv3+Am7@#p2Z7pWV5NH}1=spOeL}pKaZ~F=M-( z)$=>Y4sNxR_i%2%h?aUw_aIaZQ>34@PTFhzlx39EH8?^Ek0A4 zy=Cpnc$8t@*GDa$ z`*`hTalYDvnX$vr$k_rxYMXRhf(tMU$%FmjBj*Um_jXcl_=0uoKqZ zDjdG+viVb^=XO_{SZk`WXoE(H~@AH)@ zy|`+iT<|u&qB1pSPQmY<1^QiQ&T~|mzG+?*%$TtIy4ss5>*Z~O55$_AS6$4UYkG@k z-A~Q-i4V`#mTY0;t#x#`FVo-WDLv-_`}xv}Me8kpH4DCpDpu1gIpSUX_3H8>@50!Ct8V#QvZeFu)^633TC_i`{-}k-#iYK%?-vvOY>saKy4EoN z)2*n+6+(P(kKC^?XjA9+N?zZo)&b5*3 zUKYHK(`?4cJ>Mi^HZ)86Ui_0YHT%1# zuJ8C7{Qt96#IuOmy?GBeG1rEE|KVZ&kFa}9*h^) ztzUCeJSzXp)>S#zUu2)zda3rc+T4>XH$H2!UO%~V?Z-#EUU!*(-dFdw<@vomDOW4D zl=j62|?liqia!77vEd+V;&Y`OEo#UTBFhfk8%G~NM{k*e^Bjr{oU7b+xN+R+aFci8>4jNS)$z0bP3DCzXhvbc<$)AU(2Ol5NfE- z&bnHEDa&E2u7mFLQyb!aKQ_%gZ{`yGC;MRd_G4W3>W;Is&poi)6)k@DStDcGkKOBz zy8F#hR+ldhF)826_29_-59*7TZ4HYyEU!B(cJ_w`M~QtRo4Vv8+n-;9bt*O-i}`#> za!+)nTlY58&F4*LMWyrYIx#h`cje2&Uyqn4E@YQ6S@|N>eBH-|wqcL#Z)ScCef9od zUG%3m>)#vXYWCzL=6{s(H@j>$nN#wm`SGahPsIDaCVf7B=fNWF+bY`0Cr_H*b-%ns zRPOt2yA?fK1CK4YyM8lS#kD$aYpVzZci?z4l-Rg`siU7DNyX??`~IR!Ho`y29^)wZs_ z_Gi`3Yc~&n=zs22aB$A`gCB41TK7@p-wP%6nw|dJo~^hUR&^=u{u7pULOR#4ZPedd zu_kw&<%fvHM;3?8=h{}S`|Dw;(2doJ><;@3UUe@nVtD*9RsQSd!rJVJ*S?BUH!SZ| zoJ(7Cd3oq!&iBQBe+wipUz(krTUgI(@b5_QpR8tX{avfxg%*F{FEh!UoM_-YnWuO1 z&0c>N!$TKxq*!k2cNjD6mwl4?Ajy;C@BXmszs?v=FR`FOJ zrswzmw>i{UyX=BQ`h~C{qbilT8J{Mb+Vykvd1YQ}6kNk3oEp9Q*Lk71)aJ*B*JW&& zwt2zP`UxLyyU$C@F%h*8>0;}zSyi#D;Ddy!Wr?k@a7~KFEv||e2?^^yGS>UODYsAF9nA9v*1--Vaxy2LpU+35b{hRLEdw=zM6m`o#=8-wi%2{!t$!(KL`Iq9d zU8U~?ty^ahfT)0*Hhjo^Jb`) z|9!DKN__9+zDn7>zt+vNzJ4})6L0$8mpA@~@jW{{`~HH->pu9Gr%aYR+3Is=xqET* z{5xASI?^{hTpGS>S+Kpt>!=IQ%bzUWnij41m{az}BKIvj+~#N3-ei^9WVnwjeA~1& zM_IFPFi9kdMYkQEVfW$6BQ}d43(EO7ygMrNZyImP`zJ}VkvrJ>ZBAP57i5mfzM1qz zeR9GCY00+hwVzteWv)dVzdxw-d{uREh-#(8djI-uO?sOg_iwlQ*;~EI$$s`Nu|4Xm zlY}h4K7PIK<;xkoF7ewE&KX+0oNIG&lH6C-(?2$v&32w#A2UI>jr;G#MZV$>P5EQY z*wd{J|G%>H=e5h{@1$=!S#UtS_SX%ih)L>oFXZ+;Yw%u{qwu$Tc1pMT=S`VqJ$_ST z4zTLmZtVXv#pZ{`j2hM&t5fqXrq!|XY%+W&_5Q;lMt$kRe*PT~_f{yfU-*?Vqx1)3 zJO54ZTK|SUGHjy356_;v*q*lK(M?lnFZ-9=bAO#+miuv&UHV+#MbB-=ve$-xls^CA z@noNv#io%T-G6+&*qs#nWru%xZ>H#9t(qt9{`-8o_kkLS<#j(#$FIu|`TH%&AnV}^ zDV^_KcAt`O@2mN3fB)yX@_*;U_kEiBRYmWaPf=`UA;X>I8B7LZ2J5r;ZvGx`&rvVt zm@c!x5Z?offYf0K>sHM0qh&Qm8 z;ahDaVUT=aHrF}@2LJ!+Vz#X1OzfAf3_etqd)j<-txP#^@ZiVY?gmDxabEqZJbzwSd&Qys*{zC;g1yx$o^Qwq@?NH*vF_u_ zN0Po-1&goSR!l9}IltybznJdvL)`mbn8&_8%rAH5;Qpw_?sFIY-mR*xTF(DHB}?Y5 zrNo@6y0Kp;&z)2g6YZ{^k-#p)+nb>m@Txm*t?9GF&i67_E?UWOKJKPorTCIF&c;$F zcz8^A`rZ1>SYnpn_j>=T1zWd1T(Px`P4)Y;)fb=7;$wBT^EUhA9zDs)?@7>Bwmz*L z7X|*OIIMp&sfR`5ddkzx`7$qW{n0(2(*MrWI_AS7#$2skN2Tn#-AZP&$IWK9fAILr z;dNh{y}w<1aPim^tN3>1dQ<*;e|Yt^Dw38|sOUY-zkGd7cYng6%gxx2J1s?DO_tYI7$atBG9WE^Ku*bNRJPwmTOdU+rO~d_AFc z_q8h3J@0PLa%s1@b@^6#&+2EN^($`3$=Lm#HgA&PjgKq)=UjYiUjDFvUw+21ZpR$H zw{I`MX|liQXy|8?7MyTFQhM?BH{7)^6sxl@dbq#c_{cEYm_IJJWHI~QUk94S_hz(T zSLCvt5Lo6L_9di9!v76#-H%D3|GLaJnVj>h`jGVb=KmhWgoS~u_P4hjU&QPp8TJ6eNWm{>DmPsYfRMDb3eS;_3uj_&)gIb^C!;n=6Zrh z7#NMhy3$%|*)G^VPH31>?E8R8pH;BI=>)6EA>Wfs%nN5Nzxw{i4H-Y5ADYKyN(}5A zIrnuxJ;|)cDSL;>aL+^S&d*;M)l^e2Oljh8JgRnZfuxF+1^4oag})zWbFPW%)cdvQTcp6{TiMJ{J2Z`Z_Y=Nlwf&Prs9=MGz1 z_+4_H-JXz>oceR-tvNAk4cDX}z4^s!x#fPbZYc4Z$7*7=jC=Xv9HzffB`W7R(^;+l z9ayQNysJUpHmXXcK6FFU`inl_&Tc+uJ11eI|AU20bD>ef>PE;T1SxMw4J|Jv%C zt*^a`JfEG-{Zn_lpuzq6?M3!;XPw^mK{H^J`!5lV$(;5|!bM8a#apj6iQc`HalCw+ zTm8)h>C;=zHdTIZZrA&;Z11C^7FD-eZq763dEu_T>tdUGRnzReBiwect)h>2|43Nd zE8c%E>Vvz@rhHx5gW0n8en`sR=DD?_W({loBf;AV>@WQNq6!7>uS+`IE`3k){GTUN&OHp@_V{9Z7^|Pn;r{$jF6Q-u=O>%neVUtdVpqbI zN#d0gBx4^p_KPo9k^OZh@L{Oh+z08KC;NRq)35gH`zgWP7jE%2v)R@5ZeZM|P&Qd{ zS5LV5yKC*&ZGSH?{@t{LUH-nJy1@xvp6n0Lrg$@berCSEa;v+^nIzxVITzn;E_rfR z{APNINcD+;KZ*H#Do3gcZkqi1aeV*3uj@-~cRx~oGt=ipu%rC$#Q0k!ho_x9&M7NX zk}>D+^7a>3#o~|hZF=DSheQ6wh2!ZTA4&0Q?Yo#@EAvIbKgy!lT|Mq7pYGn7&T`it z&OP(-nv})Mmi&pTRY(53*w+ z%TJx(%Ox*$<72Nc3+GHFNy+62E&G4peSa;x?~tXiN&3kQj#x#OLrEzj_Sy?2lkf1j ze)!Ov#P*@Dd{45kghpdilk3e70Xynbk8iAT?wn}UlVGT@fu*&4-{-lj7cc6aSfEg1 zJ!z|)|2xUX(mAs}{%qU4bxwf8;tre!ie!)8i+{F1WT`TbYoeaWYG4 znW5V%qXSRc%p9j5Ua{_E_r*nX_ZYovkx!EPB@%wu!#Td*PVW0KNRmX3EVmn$FTf- zlWMi2y=8y2|5Ry^>ZX;JjH>2oJd zW_WdP>w+x4$}Z+>3-v1sG~dN;HvE^nd7(Lf)tmLbYWEvw^F8=e$FIg06FZCdO`MZm4<*Jg; zv?~&`KWsLaHoYU4@i4SEJwIiq?oEfkFDK?a7GL|t*X++x+no#M|Ns2^&#}FwKT3G* zc8MBXbl@vd{B~jIv~{1QHyvV+{3QP+I=J)Mm-X}KY970wbnWxUxsNBH~jJZz8joB zUdrnhOyu9!yHVCt%eq{_rT^JP=HI8@9dP$I>sBjz68}?v)~4rg=J{>fx>DF=0YBfi znR8CG%H1&DD`~e`wtiMo4CmDyt_l#@tFU~D1WAwf2-sFW|a#0D_XL< zX?6si_2=N6w?RVra7sqY42HE!8Mvl12-!WKq!PgJP}rbRNNLWb0C}IM4D~+_%ZDv) zn1At*qC&$_$NQh>eP46zXoZD5d(r`(XoJ9mF7nMHEv%ci@B6y8{NC4f8?Z*^SQKj*}R zoP(b13F_IkAC^ylws3aMiG{oo-p`M5?Ws7xFZtl0ZAF&F183)R{dHCg{ry_mO%}`Y zn?)9XVORcjU{wn9-R0&bllC@fI4s)QRdzM4$?X%n`pq5XYZr*$eR4*QRn25)I)BQV z^Dig=%b9HZn178|)tk6%nfed+^F7no&i-(C_L(zF#lM}kXL0}M#Fy)`?qq+=B~@#d z)3rvN^M98(`>nhBW)csJ`}dsSBDD!}(;l3h|6=-|6P-N|71<3gtX>korBgSjU#^VBv`%4vgx2$4%@1h_T0~*$sZ0&>+HB(|0{)Ah|A)`;k26@c)8+} zcxEo_+~3XmVZ|hlA6`l)LTm&UKbp=LYIL#5z3$yl&YGxvlLw(6XPmjXTQ?y+{-p8l z1mO?r%$%(I6WMLANFV3Fb@HUtCapSOYmc-iEontr!cXPjIND4qSRifx?qYtN>a69u zJHmQ42Htl{J-z?`-}l$2^&Jf>xwx?M+5yeZhUX{M=f~t8Zl2v#_E{^s<_BZ{Kb22@ z^0mU#_8bu_?AO^8Yjt?~|49e8*?(EczqXJuzd-Y)(wv0J@BQn4T^4P>adh2H_B)>) z=ifQ7sr}`1^A`-w_ukYWb=aiP{&IIgbhDq?*?lM6?-ZS#XXEhD(dops7Z>MnNhI8o z{-Hek=h^(a&GRyrHRrU{E?zk6?nLp(^z9i;C=czU}UQy$#Kx za^JOPFTO23mt)&Y;XTV4+CDVP|4HCI$D_;`tdXcD!1SVOZ^SgD7$&qOj*8V+vCeBgNL#r5;7?_>n{ zryP}FHEwL4Y{AQN*w%u}NkrNV53^rRCPJZxAw?ql%9LhPFXTe0h z3m*F`I>NrBtbX9KIZQSEag%7(oyngQZ~i%XS6kgIG5PYN&RSM^pFhW(cYJtg_3s+z z^&gXEo?Usefd5{>i}#Ez^*^4!|1+ic)}5Er=bdcsxuO2!ntQ$Ojmg)NOD3dl>rDT& zD14Kk&dcycZu|Xi^m5MI%p$J0OQ`t58<7sb+=@SQ*K>cl==1Ku#(Msoq*j&#QQyv} zonc?xyXmafpO0PjUsnHc?A~YQHoNebnD`HAYc+SzDL)Q}=lH!l%CzH1W5EOC`y6&M zHy6LwvYNC|#k_hm=SIhx$y=HBl}3H?PEXho_VC>Pi(YEAyC>&-`8d6%wI}xT{DL*& zr{zC9@{Ip+g4Z|YSp18bb|?JSd}=%P{Nhd4*v5s6c>liO%`@m-_`bjX&*NPWty?yH z^yYdgG568N$|oGlk4T<7U;C~&J4ta}!}^xXTlcNxxA^ESR&w&)5vP-GA1~JIIMd26 zFaPs|`?VWiL07VFEiM!Md+VgIwb*9RF>dRAYyKC>J}H&6De-!{>a`oiCnml*BF_5$ z#pCnelI>!9qSbrs3odioy*#=%``1PO^Pt;hu5R;6d+1pI>5#H?x^zm@Kl#5e+*jLu zIJobmv*+}?ubG!u|5~f^{oTjT@^6XqpJ&BRoimAb*MY41*4cSKW_qbTlC0cfpE=pq z=GtUOE63|H>dM7izAo;zxuA9|<#^5HwI7fE;o;k$ov`A=g^Rs@ES!@k7P+;lSAH@% z+#sp^OepGY*vXdFMp~u^XUj=FDRKO5uP#aT^r5u1GS^(%9qMV|eR>?00Uh3@2@=6HPJ?&PZ5x@Hzx2 z34i`@e8mOkx;C-@lCi}H{pFbE)Lq@mG;eFliLVmoxrF3)_@D;MVObw7TMEeDfJgRI%#T632Ndx{4w#FQOQhGZ!p2 zzY$f-#8`P@zIvIoZSA7S4SGBK+n%uIfAW*Rm2qV8tz%C7>(&OIbyc2~o59q`>-Oku zn2J@w0>jA6gZ}q3xa8{AMIZ2#JIE%kb5!Ei*NdwE71;gX<$lZAdW1#xpi8mQs-??0 zrTI3jRTj5+H2H7J=4X-a`=2;Y7ZU&WGGv1OM8(}_^VW2#8=RE+`-uDRCTD&XCfol- z{PRt7=KMYEsQzG;-{Tuh_qP6#`}^@t)Wu`$_nyruJ@kov?w@OID$_PZ&t86`$^OeH z*^|qAC(XH;QsxnsaA0xRgIQbaa*IFbcdlE)FkiLx$&9^cx271EvbWn+O|tP+`LWf) zYu}&SY3tl17!DmzBkJ-90e>&DqoY-Dt$09Fv zq_p?|1HWC_KhTCTe(U+at}MS6(eOO-!m_-lp{sS!`xvBe(N?d<) zAgbVoSnSG#m)`2vc3%_MKj^FfY)9D3DgK)>*$w1wT@v4WnY-ePR@sK>d~ru&i~@Vr z#Xl{c9C;|VhVgP~_MO|Ct^TS78#c>*JooM(!}K*D{M79hsrh-Zd~LUu-K=XijsGy` z^en!L3+*GpZ|CuY0kW&SMIAze>m&^nA5iBLPxmG1j!iD zFB%`tBwcPjz3k-4kB;YMVpj9VdKsMPva#$a`_|kaCf#3JVlAluYUDLIX#m}oOg2Va$0IOMHczpyUDgwI{d_) zV8xwW0Zm&NR24Sx|KSiTP)pX0J+yd!441^mlDT4YQXWRRibr&9e4=|}0`p$m-)}Z& z7bzJgt^c8H&1(O|i9Kb>B>t$c((K{9^S`EWv+avf*WROATyQ{@zv$Bxf4lF~g6lRt ziY|#^jBn)TGw^2lxx3w5eea*MwN?wg?NlYII~K?vyvgRt_GWtRW#xSzOg=txWaN+A z*3}<*Aw@UtLT??vUQUDVhS}Y!g)dlw7ipb)z*zI)K}&RR_}?eX53Sz6@k6uz#)ryg z+3KtPl;7*|E4=&Iw=ePolRsR}-1P`xj(@BQ@iisRvi|qcs^k4ryT(v3V|1tA@8xM(>zm@(t z+xN4ym7iU~C4Q?9YcI_#J!vI*sdMMeEtUt_mnX%_&lhU0{#t2aQ_s{c#wt_IA}wBi zatV8WNeBCfiwBQL&dZrE-(mdcoGUc4R%5vc~mes;2WKBpDws zaL7LE*v;U!falT9=kua7XLKqYJ-B+Rgr~|u7xr7Zd_5e!TzjTyTqt}n&%t8H0o4z; zj$Al><3U=@94CdZDK31+EV%D*#a)QI@a%#rcTbn|0?(5PAJQ*B@|h#EUMnV}{dR=K ztpm9Ns%z|`CHH=Kz%OUh)~$1J!D^n#!56cSzbVNw?o~G^GTNlbKXu)U_CF5}HJiRr zOD+nG-Q1ty9{ovEP$k>Sm`&|pk-?V5(!CEjUCd0%)C+DudEl_!G^3EK)o$(C2HTDH z8_p(9e{yo)+T_Qp4mjQWvdWaN?9cQcoY(x;u`+*ns5LXHb?+a={*?DpJzwt4SsnFb zZLqfRI=iYA`IAnsx6E2QnRoZ8b05yjS(hfPPH~a{;_)wI-j+k|Zf25PpMT~6TRj=Y*mh)QNuca-sP<>6Z}3fZJ%UwBKp8`Zi9zs@@`63eMoXP zJhp$i-GRl?-(Jn)S-$6EulTnqe?9*Fl&PuEJGg1#^5jih*z~?+UYxY|pmSPO#aeFt ze-C){>y_O%9y!VTXVT#$jmU=BPWv4%dg^i>q^zitP*eVNW!jlYcCr13wRcOOOX--vC#ZiU2g;W-t7XSPqfzi{UI3ysrcKdACIrW}i>)bC;#hCdynXGQk3mX5ex9$d z^JO`yYqyBE;?q}$=5L@bk=lcqno z)V;MNDW*4nkJ$D%rIYmkSj38-e!*jVjlF-b$E3HOA2w)jWUtw#^KCQlw)VJ^uFVfN zXm*NJUs^Qx+yx!Er^nazc8gxSasC18{o9Pc_5M7n|M9U&Kl>vCd%d9er|6Oy!v9N} z!}ffv-xuhkE%re9ZX^4)nnQ6%^R}MMytUr+-DP{r1^fSgJEq#i;uF|%^dTpkF^gNp z-nxYne9jxrCUdm-Jrq%yvGpeh3(t(A1LpmT9C=ebe&+f-n|WBlQsswu_vUlqhk2Bi z8kYIFXC`EbKIU2VApC*B@&s1<#}~OYn)F;3$3Hl-{W@Du;H4uHtSVl|^k>Ww;(2Wm zVPNF7;X|%ol(B@(GY_*Un^iLWd?n(4&Kymy`Np+-vg4=b`EO2&>9N`sCCoS}ct-x; zhxXSiXPp(-e=vJ-lsEeeHhtMg&p#ZxtSq_cs8zvBW|=R=27Rt|55*)xc6|)d`rw(w zs#c~TP>`@i`@ts1Mg|$_CSG1WtHkmr{_8Sa_>a5F&+t=X$zVJuvE#$$e49nxv5Rke zGFU5fH%3orX0G|fET8-4=VJN4FIL4bKW`?#;i2a}?T`FF(xnp`Zhu>Nx$Wh_mOVcg zU-vVUt?P2%GMWFjoAvLoyVK{m+Q-gX|6ul?+?JXPY=_?;T*`0p<>JP|T_?63)D$d9 zI`p1<#jz`z+OKc&{%>NAsX8|Q2h;N_&07;bSX#O6Zz}s$>K~pH8k3lx;!szysJLdL zQ7i%&G}eGr&<`VqI}Cib;X8dN)d(*oC6%7WLnK$hs~=Nq^JP z;6nNQ+7hPzmv^MBJj3`H9=!BkTcG_Q{6P50MxK|Ace^f|8wnoaXk6LTnVi%mWWn8N zm~n7Qkb%~QNOg%|BSs;a_J=bjDgR~3kZWF0@cB!iN^=1(oBBf@W5JR~2Y+x(-Mq+u zA+nMB} zP72-q!SEf_DLOU1w@F5F!_KJelbwEBN-83Rbl%=oz1bu$_vy@oizn?4Ob@si{f*Ji za%r*WtOdv_j@6fSEOmt zr0>AZQ9E-*udsYd%l0Qt@f+;EZR}s`-|=Rq&x338_k=HsYqP&7m|?Wg|C3_6^!{o2 zul)Nf)U&U)-Mnmn>*JD1!n?ixUz?==bF%OZv)WIKn0J+}y|mW%MAcENgY#{@SYA%Q zYwPn8bsY;c!vwsUz%2>Cx;+g)7 zw&r;^nC`t0_*)$Us$q1|zim~8zxl5dVzD`bHovA`=;EFvxk*`l!y{1}tJL|E^wwLyl(YYH)b7Nz z3#qa<623fOZm*rc=Rv~pir|~2yW08rJ{(Eham2gMv#sR#zL$Qd`#&6J>z&N}>);pH zP)qik4~^?Lg{g{f^V0Ks{bqks?_ZVKr^FsSef%To_#Y;p4UZe|eN5Dg+!*}j{_gU8 zU%iJfo`}VK*7_0la%t_yV`@!?M;Q#JYz%C8aP+68>hi=ZObm%;^M$w%%sKjT^JQUa zfrYDDTpFIG{h4x#BZMoZBOypYhG((wiF~8L6pO_(0}WH!LJyot;CjL17LZ=@!lmEg zoIthKCbn9cZefpU55jYI{5rv`_a&;^y+FmBY2rRJ{^CASx5F<^G+&&&TEXSmoSxv~ zJ!YB)C)nQft@{08y}E+mS;mtkR*k$(A0M;pr)bTbw&kU>^U&HwX6ef3`7 z$O-i|i~TPMGQ=EiO{RLAOf#LxqBpvUJ3@%8fQVHu&01OrE{bK`mj@#@>h~$L$%c-ntDR%fDZH z9ei@nWqGTuf-5HV2ubYiitx zT&{YycKr$VcRS4gM5T&}63(FCI?2ca-HV7`c2zx?)*or{xyz8ne~U7 z|IR;mF#O{Br@>{jpQQEy;%=L4@Z}w)Cm*Pf~=H z0=R@Pa5NYe*EpU@(`4W5kCU49jQu~odLZMIWrt%%NsMb~3?NGQ+vF{Q^qsZGj0Wo1OL=e~l* zlLD%WKc;l7n54zWG5_a-h1ZWY=r3ngwKrQ_Vd%e+?JQ5+B4r1WBdmNj2je%!2~2u& zL3SPsXVDhR0t=hv)*oJS{e9!yl%PEQ%C9;6F=nd`OA@i&-KOSK_wk>B~ihAG2t!vkOJU0CxvoxPkD)Wz`v-i#@Mt=$26#mcM zufS`;5z~Ji-`@z#FIX(Te$tBN^Xsa7S&oW!>eZ#i7+#k$$hk1dzUvp{v%ztO=nr{=h^pbK2EiolM(b(;!W3@BNBC-;x_9Zs$Y-XbzHcz z(=_MiJnf5Tw{72)lzdXouHs^DoWaA+Z7FPWu^*;Nf6uZw7?{P#+x$+ony2^E-+hxE z6ebkbxh3%_r>0CvT>M6)sY%0KRfFlw&x7T*t*3rSSU%kzc%yLO-roF3Axy#~rDbJj^NU&434z*vMWNI>X}WN$A^-fM~cle{zLw!H{8;@dRS z#(dd%nNQ89k7X@>kTS`^=v}7H&WQ^zZxPb)FPigqgN@;&T1FYZY@44P91m`th;3dk z8k2sIIkHhd;qXPz?u~w&MRD05-Q=_myBphjuCg$mIZ-w0#2HPlh!W)vZnt?dxn2*V zvW1<^=T5f2_4V-7y*EUjYpa{F>D~2yaZo9~VsY`_h<_KNH>Jm?@XQYvoD}J)v+JYE zgjxLam&~4Xk|ocidegDP*V-;}9{1L~rnUC{KD#R6BPyxuUQUwVQa~d7BSr+qi{iv!?I6#-`TzF+h7}V)3!f;@Mic z2{pbl2N&OPdtVWHQs!PtSJ*c$xw#*BD{Qaq_@=N{HNNWfwudSCH8(SP?Vt3Ug&Box z&ei?#n_TyyiH%kMBMX1kO{QO}^R(_f zQog^?|6??#*vyI3wLUJ*Dy+c`N)t_cXK2CzL&%F%kR?qd4b|K|ta#l`at4z?YB7A*8iGjM|N zlr`Rr*ED~r7)-LOU=4CRp`gn3LU_Y+q51JY|CsMRaG2Zm&_RZe%NMCG-pIyd^H|)c zQMCUfTi>dN?)51-xwUhqE;jV)OFR6uL?-%zDPN!Ihl;&T>grkTs)id6-kzi4sM?fZ z?6HBRC0@t=$lE0iK9&YC2V*&7{&8GLd49WVRd!LcaLhS|b+i7c$(u3vanDcCvlLvw z!u5sQoH#4vKWA>v1jee9Epk1FZJTHM1{pc1F$HWn7HqWL&oO_iVNt^M zI-99EIoC3-&7XU5vr4lMOIq1d(I+SF{m=<^+x*|^`n7XkPu_^S&Z@sDae1hj$X+Ii zxvIkd9KM+ee>-XRW6PwR6V5Y#oM~kDI~nBp%ZKG)@PVDXbAAae25sBB%adbpbHW4L zr$?s$nBvm2?q(P7vn0<8w@$p+!^Hn9m*LM1x5%W0QzM?#ubrtI7s4s@*K0}rx6Ska z*3agZe6at~ES=mdW-t7kqg-e>3Hejm64@$ANEVe9~U{^tsu~!;hN(DYr*7^_Mia{b*2+`?B)O zvtHJpoo7qh>^Ck8cKrOIG3;bdJJYAb{M8Gb_pzw&5-D;jS8pmg%=eDV;Yr(Yg< zo8`=^yJTPWDf7d{%)J&m`>H+OU71;@lAECY<&fLOe@BG<*L-y7Nhv-m_xZqCvxixG z>pse#Szq^c_3MYNwv6=^VL$BTY<#w?-^^UoaWP3Y?m+0lkc-PykFWb^_IxeJvH90t zaZStKBC&c2|A!Aw@4g+Bu2h<_z)*N{)ZaN9TmlRx&j{>e*x<_|xlY)zYop_B6IO50 zoYsKnrA$}Ve53_rj0HtxST30D5t%SaV@6}Kf;8U!4i`q6r6 zcJtc)MU(qYC6~1X1Q=gimaJD%v8wg3Os&=q)-UrmN$$VAb>@ah)I6TvK~DJE&=^-KSTXCY6sJJ=1>W+RVH6V(pS( z262lIp5`g7>;<`bbHwBeCd~9@d$~9X~b`q=P#Qu~EX}TY;o98}wH;H4?M3pw* zRZm##_xf8doL(PqF1Uo*rsBiL3(3a9(KptxF!#N@tu6eR|6fSa zPjNgJ{4Iq|Px^Dh={VK&8iV<#-6qApc0RBEBQf9Ph=0+O`$-zR)@tMt z^ViJn|9tn)v0o`leH9UtawbSie-v=-S6%+#(Q=o7p7&Qj)H^GAtp9f0?zLN5$+_t& z=1*Mal}yY#(S7cYw~dux%H=;(@;~X<9lL&0LLy;fs@0D};`=tl#ZTjC;%Ae8`MIj( zT>U$9!86BR?5-8@%{YDTMp&o9>`xaO`+q!RuTT)*cb;9==BB^Rg%93^ZoYXRK1uKR z(eN+B@caxZ-mNdz9EktF$Lw9)QsJ7rFI+x|9F{l|HlruTKK-ci^I!Yl+H12D%tZ9L(T(DPZ6sz%0>t`(?MHfN5FM=SvPgtinPLj*N~9jYc0@CloNBXP^H! zy7u4Mf?eM#SFZ{#UG>f9+05*-(?8lBlgVDU_xr)kyg>%xq9xp7W)4Pb(T-o=2wbpa zY~K*bCjIt{ibBo5&-3rE%WWz+63lmk^S~xg3)L4>1#do82u{!N@3Rz{F|X;x8sBv; zM{7zh^2e6$N;}*vyf)?7F_nfn@k|;w75I&|#BE%-auSdKJf>yg^Iw)|e3=yxvb% z$wS7%j+_Q^XP4?1{G83Z*+n3yp!az9HMLIuI=*d}r-;Yb6nd}v$hd40&$iif?Z338 z)nuqHG|Su9t!^f&^QWZfaJG>?A~8;IR2+zJ^%8EtDOt}pGaCijpI`5q<1lgU&@_LDpGIC z(Y0@#?CT<5CCl>g>6-=VC)c(=7c%&8<;6@xM!$~@xs|4GTBQBH$;7_c-lqGRz2x@$ zlV|>&(C_^i{ry?_`SKgPUhVqpku6ubO569vELPngYmW%qPCPo-k45-Pih-MC(`2F9 zpZ*^1T%gW0yTreN#bEqne=QYH$B0Y%N1^2 zdD6Vjk9`WP3X4{$P7q@V-}gvd_SmAe)odD@{ZP^h6 ziG!OB4dp(3(3ZG0C8yAoE4GiJ};AI{sSW^xCIRV<1xJZdgH_nc>% z7t7}K4KJi?W=D4>s9!ib=fhgvIb0TRx@D_tkFP)K&tH}D^TC7(YWX`tf8;Ew5IL{1 zzh=IDle^v*CC%mGU(V0soiO|7pWZVU-Y|M?O8opLS@PKO-m|Z5_kB?E%lxSH@(stQ7?zo*>L-ZnwJ=1H>6@1wg{ zslFPRZmgPJLe*x$GRsaWncF1*)A8D*=H*o+j;q?xJ`Su z$@JH^2EVY150VAj)ZN6?54!A6I;$h6_G91wi#+r9E@+v?tMO2)l6m`+b${jTh2Fe8 z{OqHyN!00gM^$TYF4~tc)7ib6m3L}NoBAdJ@t>Ca_ZP>D%{$R+~ke~MzK34nsOXKsn!rZmhSFH?kLRjsy zC6s4LXxw}xoUi|84#%TryB9};t=hjvht1(yt7=}*tbL-8g>jd#ni6nOD~qTS?sH%v7oSS{mGNfF()~AmbzTf)}6mJkX4G2bN~{@U7q=jO}>obw&bze>!HD!JU~5_#!yecz_{SNA=e^*YY|`IO&r@^)tfPtN`G z(P{s?tv|flJ}xuiN%=GHvHWvZ=H;Mk{ zADWkL*glhElm5ONo!^^P1x@7leV4zN5i^D3lK$+a;U8z*UtyNXS!dInK6&%U$)fh} zi=&UG&3^hs`LDlZ-Wi#H62h}T9N~K~P2k6Q8NaZb?Lu`$lU{V_7I+J7sd(&tzFKKU ztant+x;(X}l*4?JRd=81dwI}w??v;w-ga-!=XBLx=H9ROY<9d-M*o+r8NQc~Z*&om z`{*>ufB&25=iZ(U_hqpbJkoEJ?DMfg+Tsu6^?Ub^o2e}LR%i1_b$`;OV9ob`M%2Z$pQZpC%4|BvEW z9Il>4XIqp~ZkfFha&%KGP=C?lv4Ul}PvfrT8Ext(IJA0hbt)v!P;Yt`rovp{-LuDQ zq6Ehso;i=WZ#?uVd=ZcpD?Qs}D<@ZtOqb&=j}L28xBTMj%LqTor?ctuuJ!)h>Ndwh zD>AgFrmYE2 zmNdw{9F$E{YA z(k51V$&mTPEq?as=JvjmD^)T+akeKsyec)*o8@m^XlH^=q;chZ1HE0_{#m{L;Bh@? zvr4b;CS}g1>^~FMoBcbXbeoAe?t8)H-c>JNJF>|YF|pfy|KKxEHO-Gj)i7tXmwkz7 z{7!#}c=gi%qBhtKWTgSTwg{i8X6nk>KfPoeP57 zQxfL+F0D9buQE?AFVrrB*|2@?0oJ;r&2oOO@t%_A7d zmMuK|f9ZDp7sl%Uesa%l=s$l$I^^R_{=@PyWw$yPw6MkS|NGYTD0vgx_jU6)Ch^uT z&o0x=6bw&O%CNb)q&?@%uT>H8N-q+3sr2S4nP%mjbm+VezP=4E)av zHpEv=%eXc9rAGD1Yj0G)P4r{=nO@B+rRM*US$(${`;7^gi}}4DHBUSLO1$~Q+AU_$ z%+q~uUViY{ecfi`FB{GGrSKcJ%dY%&=J{(r$1{)hvkca>8_Ss~@zq~qwmQ+Y=lz?` z1fNV{9X3N>N0}`y0S^Q@G|r~w*0~*6kglZhBA~^}`_!D;bq^nXX=*xq^H_kAg+EKQ zzhPV^*Cd{Rg5-+1GXgbk&FYs|z4vY1$7GwOiw<*6ZBY48#Kd;fHhr_B8n?}Y)n^?~ zzmS+;chxlN5Oa7Ze*{l_{Dw16*Q9jYbG~=&RQP4Hbn^W3(Kjl**bW3;T%u+zz1nxq zxfc_QC$whOvHm^vru*F1`?t29xB4u)DbfAOt?5xLGMx%LH?f8?a__zNdlG&g&)T^4&Dq`s-%@DZVqE>YI4jtCf_uD!8k?6SXsHR1qe2FY zc3VU#S;X^tuQ=!@Ua_EiCdZ^ilbPLmMnzHC!Jn(d^!+lAcoc2D=xRM{vg5By?RMXz zs*=MWExMs2=j9Od*pu;m&Ax{VFFosG`xLy_C`I^#`ugXJf+^o~oR>=P3sm~?s9Qge z-)hpc&6_u0|Esz)da~ao!P*P1oeNlI*&Sj0rYQE|_O+G2nygOiVK6n13tDdgNdO@TGrvC+YsMe>l1V2N&Uy)RX-Qs{^6(#^_c-pk%xs{Qj=_x6+*;u2ebWj}0QoHUnZfy)FNmGc*q9 zd)Jxm^K4ESR&Ms+b;FxwZo!Qg2Mpp3@29B9CWH13;^+oLYwd{3*IpL@$riTu5}@}D2eMSEe#ZCC3i*{#`Z?_K7_GFNEx z^Sy`kZV2!GG(l0&dK$+i?%Qu&ChYfOsWv_1{$bG~cgOR4#MX!Kcl-#ft#OVy(9bem z_sQx6)!+|zu3ws6ZL!NudFSiZrfp^$S^nmDdF$tdZaP=?bADxtoZOB(%jLJ6h`w<4 z{m<5RmBO1ZmsPI4*c2T9z4xyAI+a|$tiA-t} z4AU5|1iwpFwc$BY9V5m1zrR8rORC=K+NxDymTzJEcgxLL&Fr62Ma=9D#%xH~BGYg8(W@?@ zaG4*A{qLLS^Za|B%slhq^oNU_ayx_^51!~`lw4$6?cAIs8zr)#M>}}=$;)@1+>fDD%D^z-mKWtl-c8V z)AZ)=pS;one~%g49OQUjdh5d?dEboLtu{AUXQ$|!c}i~(4kena9yneuZxb0BggC)`y2m0;)e9yXZ*kyTR(@G1KiH^>#c|T{i-0xJd zQ!!HA@`oqxlLLD+>*U&|o3DNUCh^UjZSKA4%Kfc{-`M(HF1(IfZ_b))GoxL7%Ow8! z4)vW0ojlev3c~N)l#eJ;oYt}M$EJz5BEEL#r|@iN(zpMf<*SpNU3?wJ9C{PF$4O zcQ7ga$Htk98uu?aC?0mg{Ql8;qfZy^uTGS2u8eLs{e^Y9C!Fi_ZUGDSua>zfpZ?7VkGn?ma_|MGjlTG&?&Y3T`q}|Kr>L&kf zuKVAZ+qXI&o!q3pYuWSf^X)fyvdk^$(){82|4E}x*YsaE`F@M0|InPhK)$fa=O_2P zGtSe$Zp~oewteY0-*W07COx}3b|<2A1edF<`!V6qP42h-6^n$6l$;CH<&TTc%g%0wtC9kv8V7u-TAdoIHC5cb@!5m}3DLmh@ZbTf^OFdxN$|-*|K!;f% zgX7C4mw*LdT3%0a_#k4y%F5I3<3iA$d zng6=5bvnnSg@vD|YC2z^y7KZ(@xD11{>F&M=(cZf^kB(7)g;w^-<##+)IT{o8Ec-- zN#UL+6?;+8uDHka{EkKUw}!2}zxC%22m9En69PImPb?HO7SGI%IbU6%r=5}IThuL= z-TT?POr0}fITKGM=ZSSEjc)5mY}%bOc@I~Gnc}~|*6y6EUt$mF&U`q1lEgNZ3$FUN ze#k^`;@lA?AFAZ>{(&dU%{}KgUOE`-!}8MmP}yXc39=swKgA0>a+Y=~?7hHQy)<2V zW{UHnCn~;sO3ofXJM$ltd+Mw3`IQCV69SYf{!eH)<8r}jYTXgFeOi8pHRH~@Ojz4^ zy6pOS4zc3f8@B%GwQW{iSh$H*?e~G=R{n*I^*<*Ymie_kaToVvsa4bce{lZKRXeZQ z`*$XMI<5BRIB2d?rb=wSx7kY<_izn~>#Qn4RuBoJv?X00^RU_X*f5L8uqgK(;MBN2ho|qMv7Ch@5A&u#!(~hg&gmvk z7N@%WdT?}oue8re`8)i4>eha|HZM7MNNUB*TV{LKT5!wBRn?sfwl>XPzT$k%GvnLB zvXy@GE=E1#YFm)Cn02>{!OfH}*W@QZoRVF9V&&_XABxvKaZ>tmRKKp!I`IRG$9>f% z%dMsY)J|Prm zv)P_sIcL872X_9nj1L!#xaTYLt4l9;`Cu+ztI_$+NO;Ki2e`CEnX^ ztxjC-=*MzY%kI5m!@1AFRrAYc=s&T4vuDSVYbs4OS7$4kh{)e;-TJ0$uBF0^&IdK7 zIdZq>buJKg`=)zubM`il?Wfpp7Jz2<_Eb2W&VNwOYxeI|`TC~kQ#$od_^&zAUfX`Q zz1x4n!_PA~mKA?1nd)M&cTMMl8_H>yo1OlNT0GnLAWn3D$gTzAAKiPB`G4JDsot2s z>ze!WcNbS*+BxfO3UkTo1JeCbUsk^exw&?4z@BoW6Z^j0tpC}&!;*VWLicplraJ2{ z{~juO-q|C(zHPa~t(q^Y9tY)%XFU4T)X>}Tz|db~&g8?z7xtd#@MB#vB~zruE0ZNk zNyG4#H_PIQMyl>TXFC^!Yfh4w9mK|=7k8yof8N0^f5&Ktp!C+EmnR}0rLA!};imV%(4{R> zsiWS6W0$1u@ee!2XCJ-)|L^_$4F`?mK5pp~+j429%E3&&$J1{Zm3<1j=9f^RBifqcDAr%Pfo#(Ts%(m0l-e7U{LHnEb zy3g7gC$;LgaPI!@HGA!fcNf>+dUN5umF>fsXR}{2>v=AJpvJLTcaQdu+J}FPoBAJL z{qVU)Nu%?y{d|@DG9}5y!gaw)FI)nin!jn)y`UX?x%bAA^K(%3*@~2lf%vd(zeAJ07Ulw^8KJ6Rx{|3fv>RWRpt$IrP!Oe&5UR*V}+dchZ z#KZRwQ~0%HZ=4P(3y*UMFL=G#zFccX>i;CMT^FyJR^*(p-Er(i{wssu7d~<4OL((< zR82djdqX}>{q2V)Zo6AIF8w`hSGU|wd4|E3+y$JSAF51y3_BClnS?}{>Owjdo(3#< z(hwwhJ5I@iQR}g`pvZ$c96{G^9^_!PF46pGBs$&k)nbRP7V&yNdmGg($yk4-3}yKW z$!!M`Hm4f!xE2&Bo$%l)c@`GUtv>63w&0hNCllck`!IR7H=h%^$Wb}z9i0F za4J!?DPjA{Y!xGl})?i_m2}uP;xMkAAr2Nhjams89!1cZK%b zwzG26%mg|Y9MDk|^O(#X@$jg6mFgigBlYu9yA&RCNlh;NardzN-;C}$i(P!-8y+#< zEm#oU-9AaJ_+Z$9SryyPY5#FdFENjmkBIt|DxY&P`-_m{C+!;xxp^GVtmK!UU~=2! zC#&pa`P(5Mo7!Lax_>x){V;#+4~Fe$gA*RB=d3O*m?vA)r@!a_m#m7-j7CfNxB14I z+X}`AJ8nC0Jjbj=f8s-9t=|vKFQ*+<;$KtKKEFEl`9l9Qj~*ZO_;N}4M{K@$yZx`8 zM(uB_&8&8Kv&{8)mEW8yo#U&NU|hOLiBn|#5B)pUoeCAkf?qBuu3Pb8b9li|yJ|f_ zk#6nD{eOE8 z-*cw^J*E9Yb>GX&pVV!_A0!(;n8>~R>raP|m;TPR5bTlUv!A(`VJI=ns)Mvp9&&(;Vj%GIN7yj;fa5FLZ6vM%@E7a_2y-ua`OxhPG z{A0oLYPaJI4^`zYxZRkfZ3?)3dYT`42pQE`q#xR#X#4+gg;#}FlZDjd#0`=gUYh0Y zY0?*bb6Ux-`a!F3ZI57#)nt$Vcklnb`?^!1J@7-HT?ywg)h7907uvU-kFPw+9$!3p z`!*)F8m_&Zi(Wis_%K=gxruwL|Dwioelj#^F{3W-)9O9hH&@tgJi9f_X7!Ba3(mfb zxAg5)nE%B8*T)!6`KWg_N)o|aMI2USD|s|9HJ+Wd!IE29L5At|l4be4)mn4C-c?C4 z%~5Si2wt_oV86~I%^3%xk0+=ki#%q2qS|D(RLHUTVer}b?m7cim3c)f4O@BUA6)3l zc$!VCq4E96unC{7&P=wJrBsp4QjHoZA}CUHnxhRw;dY#~Jm*rh+0Idy5J~ zdi6eA^pyGqeSCO(Vw0>)!Nuv8T$LUf7x=EV+y8m^R-NaATH%TXckg8WI5tT;YVV~+ z=Su>5er)rV3MS1C50N=zd+XqYGe34p&z6+*u(~m$mqA~Yv(L97cH-WY3#RvMdp0<$ z&RKUb{6t!RUGYsrx!W$$n{{peaF(5vkGyhyPSl5<<&S@@ztpx}jHhH}iTm=JL)z-= zvtrfdi*L$DRzxTypIpGZ-(`Z|NsijA)_&~|j{+|~&yd#F48%Yj7Oiu1RpyS`W}>{xfW?qo~v%{?bB zG#mY&Hsz!Iz6|5jd_QIOPG0Ep?5KGBoi~Tnbn`x}G)vU2Tz$Fi;HBkDr3)wKA3Dxg z!_#VeD3?!aZ90F>gEtdII%5CKjr9_{u(XL=zwU~9y@b!C2iX54VHp?7j`%eTw( z|9xSTj!AyD;-;b1h2V#;S6!d0dhy;o4~nzg{G-*0pJKd?gxQaz z?9vlFYuZP=hwYt^((o!dB)t@DIZMp z)n{vo`h*i`93RZmL!HX9-^_ zz}0x(<-&8PoDbPbCpfOT6x2nkF!~?&Ir-4Hk*DvHiuhisvZO83Ik*hw-SA>zJtK6G ziT6$xn}nTi^2DQuj~{q1A9wmzPt9vF*-27vixzATmntygI(R~Ofz+Kq9+T1|_Tymc2c|i_ zfAs%<(tp3V;)Vu`om+m4sXYJPb|UEuKRbqsv<0=_}s?VKi0UKO9z}>{Ny5)^bhPy~KAGp2^Cj!w`<3Q9XYq^Q{S_(uZOJ^LgOAmlY69mh++U*ja>AMK zpAA);N}`lJp1qk|zcKpPgV%HOI+II|^PNpytonG;((m$dcR!b^Hz#yyKUnDKyZp`e z*MB&Ds?y7&PVUa;oO9#m%aXDuXAj*}6S7!JZ~1FBVmHKNeQ=gKkQP8Ms+K_#ZBo_dAuW zVrKRJt7N-NfWW1Gz3hXNN>&v7_$J-_eT#<1)DD*FN6PA|j|=_Vdf4U*IjXCyTCRUm zQ~k8TNrU7VVaLX}rj$HBMmFc~H?6Om@$HaUlQl1?m-lvXAMc5k+{)>1o?Q3r`*bx3ZIhR4-K_rW`R`(vnB!@y z^{t`Hn|`p*j+<2Z=~!|tt3qv;<(o5Y$^s9XbzdA`{xiyCTFbN&wa*EYT@BVo7v?sL z|2dd!5XEg)^}?G$IeOdA{{KJvZ+CK5-RwwO=h7o{LnYeM`o@a$HJ@A=dG8cFFtl2} z=0i5$@7G(-rD=X_xt+N-rMYhLhaP$>|Czlm&c^1$MRDtM%U>G)PVm2Jc01&th_dR2oP)0u z_VKO1aVTuFyFs-=p;wB3L;RdXaodoCjAr%k4=faR{OHY-xjB9Lv*_FDEcRbl`sZ%b z^PJ6j_Q~O`TVEt^e{=nre%i*5-%QNr>qj`>OX`dGDqjClJeukE8ug}=xyJJj%Wu5d ztWeqc{>jsY^LcOdzntxRY5R@CaW}Pu|vi01K z?Vn>( zMNQs*AxbCup8CA`;aBT6fuXqWx)$R%udV|YdzUa3vvgNxYq$$NlL%!HK4DYJmDA+g z`e9ArEf1;YY_%qltLZGVo9#}y6ns*5@UW1uu<3D8(%|5fdf~MC)B;uJ9_K}?zgqbe zOtm;FJyYfMtsf~%ezf?fsxa+rnGln^>zHxYYt~{rsj8l3m-p%OPM>pw zjZwV$_+%%xYYi*CmWBG;rMIgv#q=$hwfad-0mmGfse5j)-m;DL4tSs({@P-#!&$o= zwkC_3NfzH6)BK#QONA;f=rLYY3*N>owmig^rGaspZ|~w+n{Qop`|*%J>JsbEMRPCT z5@6x*oz%OzpY3j7h%ghFbKNpO+HvFH=ufjoSKQMM3zN%epmxe!jw$i zy_XsvyM>Y(HF_dE*dYPTflp-`K?y=WcZ6pZezt^J?EIyj`XrW*!bd=#;Il>Bnrl=c8;p z>mO0QP)GGj50;xVw%fm1EA05=qm=K1>KQEOS4Ulc4lzF=_54OX*?*B|(wyCu~V-m1+C0 zP1yRi#MS*x_qwBEzZQJ{7GGSoU?Km;zS#5a|Nn5jS@)PxZx74txf|oZz1eVt*{PlH z+5>jElE9b41V(}9!(v53* zCqIy2UK%l3fisS=Td^R*OH*)($<3`U%?FpHY{;up;%GZ%At6)4^GB;wp;^2|#kXh4 zc~`?9k{*v%i}e>gV)XOB64z|x(Ye5PTi3cLDYcyo4(JM|^hjz*woBK%wpgX0yThog zjc*K}1y&yP26Zvy7Y=OMb}& z+gk6E3#VtQ*p=vU99VxVK}D9yKKk?%Is&8iWJxD(OA|bq{?cLAK?CSd-r8sL_mP|U6 z|BHh~ZO!6%GsUojuHSPU_cVpSIW)iJfXt682@Ch?^Z)YE|NroP&cwT^&kGuv%_3Br zDkfe@%l|o}G-2`o_5XjZ-|icwBe48K)}5FyhYz1uWtil>vFmk5&z81!5c5_%c$28yb}Ls=Ej+OZW>BFl8Nosu4!Jo@=ep* znapiR{P(19f3U2$YTn0;TU@hC);ICXSwC*CdFCDe>yp_2ho|0sRQ|a6eb-_>xf}ZP zKAiaWV9kNX=|YZs?%Z^lAaJe8()~HhbLPK7V*d4hL0d$Y6iJ+XaPy&v6T@alYr!W! zn0gfsbKL5Ap!jA^sP~LH^A&m!PIlE zb7o6$!-Ows6H*xZy4(v6exH(k`Rh%q5`&=PN19e!C6ywWgqsT=9X)81TWHXxksvwy zOC$TX2kJ9!-#Izcu_{PYa8Au6QAsP+4L?0fVqTZWE-bb&tnid-ejX#F%XfUCWbH1a z`TIU59ClpY+u^*C(`MrAx?O&0ay%!_9CHZEaXP*8WBS@t=MD&MdFkLS_AKL|GIPm8 zd7e!H7yHCL3%@K{==4oXTDamw)P&~cE$qCimN`;u{I;{S{Al3j{h)EuPU_-M1J*q` zta~$5#kalu?>_nT73G?ejyOl7S+zY5hjcl^PX?|m^_~A=;oN&anD1)~PCqiCyLSPv zaPH|d?FQGz?zYp zjg_ARE!6arLP3L^F-jWuTAWYc%Q=&@e#eP>cPCGDG5O!lT>HQy=3*Z|=fWd%_$P`+ zKHA!3XW-ZQ;D2>&UP|izq~b>t%1-t2ZdCuh$ky5E#I_sEvlokhx-uz$+fl!_`@blh z%Y4~!|AOG%!^+bI9>2KNtRA0u_}77yXs?YrvfJu+q+kDVGyToZq}$^AKD3_YyK!Pm zQJbs3Yo)Z+hsYE8K;Q(Q8*)H^JhHV6K4*uR8na!-OIf57@rldTc%n>x{ z?7GWR1s^AD`tUSvuA>I)A$3gwpWmB0mazG4i4>RbxuD%SPv}FpehtTqC)0UOhVb&w zU|NyTqW(ip#_z+Il}+n@@`O3sCr|%Us8Qq9WWgwPV!F&@&bbd6!ar>8{9QJOcb>3! z*_q%EOT5lm=vDkUID3h=_q88^j~2Ta$goC8w_83*n9F;hlfjl#DBHP z?q7SgJ&h_}GSsP`zczhCRgrMT4JO$$zQVjO`{q85){Ru{-e;PTEL?JCGh6Hz&526Y zotu2wYl>clme@JZD{lY7G+J%7@^ezM@*Ni%(~#%%Gulit4IWSvUWm(`c_qh55&hH(9Pa@VtY zhtqSd-HY-oPBi(w+&16tzJGOgXgrDT9 z`EpVJzoNR~J<}aOm~KBid+)lP z-P8DH;Loyqe#`3nqaNE9+3cgNWoi1J-(MUNo?CH4!PrcV?dkHj{cl5`O;)tg z`ul;~?qw8D(8tx^7Igm;a{TbNGok5xc_=GC*Ntn7r^-(3t~lm?WAom5z8}OtM>(7Q zc$O$l*50zmc#0Nd}*7gTLJmp_~t5K5R_w3I`uN43u1L`b_)9 z{LTdny!IIjE_r=2n9V<5CcLRtefER|jUTCBE_Rpov5LDZJO5c((J8+tf`1vqyoH=w-Ch+M*zDkqrg9-6f>sWU;>04av%-iRz zF66l5WUoyAB#uRbITZ)X{jcYApLxRcO?c{DN%QkHpAHDmURu9rqoLJ8>Et&)cg&{C zyy&vs(cV6HX}!(HonE_^zTe#Zx5@eaH}T{*igQKVFD~m+eR5E2Q~H<9>4gowo!&=H zvTeRJzIU9U`?z)QMccRw@tL~PNy$Gp)ZevNX@1+Eptbd-fy6uMdZkVUMa4b=VHZci zW+w608wRNtgd}Twb~nfxH!-q`dfeV3>2Pws%fw3(Hto+cSkBFmu-w5k;W_wBAzIuZS89q|Am`m#nlIKhAN4q}{pKNc#U&1WM=MS=UetbZM17WI zi;4hm#g`}NG(OHXjACx{6}34iy{F=!@r`4lo6MFy`|>2USyf+JSUvdTnU@dNJXous z-cVJv`6ic$%*^1+ihG}*xVAu?pS7gmWuUbF#i*nPw>>M@ofOoW`sd)}A3xW+cCMZr z?a5Vj@|=yT`z5Y9DgNw!K_43GbZ3QbI61?2VIZ$wbx}Y6=MzkKGai3P;n~;HE)%mj zc7M~dH`AQG98N?gSXi?t7(6^Wd*{m&QClX8O7F~LOux1IYr;$MJwKXwgOoB3KbL>P zsxG(Iwcqq4%icdde&`mPPqMABE7mEyVUWxAq+i|O;JO|2igI{t zYz{r%(w6JV@>Mc>uEmM|pC-4bPgq)S=J5U5q@7{5%kt|Q})P^M}Fe%EIqkEK3&h#MBS!DE3fIe+7`L28?1jf_Esbd zzu}g#_+cX#bJ^b7CICpm0-wEWFP-;f)^ zc1Nl!Ld_h*z6Aea7QcI|#{RZa_mhb{H=VLyI*UG^%dzR;PwS?Oi?+HM&hMXa`JqDk zZGCIOmg_b~Zq`w^nN|OPGq9N;DywmG>F=%mcV2iXX>`64*MAeAG|O<0dis{i1rMF; zI&PcBUiAKO@y6EDcQ0Ko9Z7pDze?h4{mrmF(e3N+*(?$Nvx$A*k$pdPc4l8ZRJO*^ z_~-5AH=KTpS&3{2HS<>gxqrudDW0;%`HyIv&qHYj1INyWM$hX!4-Y=n zY(Bt}>vr5gf~k#js=%3k!LD%4c}^T>Yfo)=6j-I;zHmm`pJzf$>Owctlr(myy_ph~ zcw>?>sJBv5O7<>J_ z9KaI1sma;<*%M#0T%BhI3PrB`HI|Yyo~V7eIYlKr%SL+sF6ZT3d=)Z23pNCDteX_~ z;bW+ghg^nI_=ga;^^aUxC;M`oYvQ@vtbAe7RGnfMKYfV{oAaX!Bcx+?HLezVn@~JU z&SuU64u^__=8H16B|ddeJj|Y)+xFnxvkR_S&sk?`Rv z(>p5@_VpesSZ{II*Y8KOx6DCxd6o2%1KoNB57e`lJNvPyHtpRdoP8tu6ZibDU(U<_ z>^M6!_lJc4#+KU8g;lMGqc(hS+;&vYqRaKg^86}y?H^jz%}W`_iW{r;oOcUK(ku2HT%TE8o$ z|AU9fgN?U74-3Ywkz!AocK$;w~q?T zKIG;zty-%b{O6lP=36lGh_}}!!+}v)*uUrzN#L-{taAtY`AC{U=!l$ziGWyH! zJ+!=6Z5u0_-GSumHO?}RrN7vHO}Dk5ldo{Z=*#LK&DKAjoR&Y)rE}unOdpoqQ!T0o z44BR(1uxQQ(m7Bt>*bm$i}lkl8*$t;eSBU+vQb6-VUd*AXOTyqvl41~XD>X%a707n z#IgrVJeyeT+I4R}(CNDNXX}gQ0VTn5%suwU_|2aig&h*$Io4)hlcpe9$tYUmHf;`z z3>)+E1+IJ@I964Jvp)O>~U$?8wxLOKRcV4EA-1E`p1?Jn(HQSS83ck z(KdR*o`qXo81r5i)i}1xoOCL^yUc<8jmgeShS5d&Jo!!HmXBw~UGRS@vwVP^sCoWML=k=@Kn z*s=JdV}A(;+e{UH>9((LyzOsKz0kq>LV;aWZ&OqIyql`>OUh>(*B)ozd4N-_E=SF_ zVWa1+?GI-xULbhZ%!glCwJFK%-{iH6qfbuTHv6!=fk}|*f3)kz<9&1XOxjg2N`w`KpFsDMzc_Zum0`~Sjs!fyprA;L_dCpedb5g(N-9^Xx zie%wc!j5&$%W~%SrT^)Qw{yy`;gG9oUK!>5J|i`HmEF-QGuLYg6GWvaM0EJ)w4J|D zTjsv*LD-|)wlYgN;;Zxws9s3yHIT;^wYBh+Y%{>9$E&OTwP3*`82Ox?;A^Wv>t z+)Y#IH2$~YH8b)%S0=I9UT$=jH~JjlocG0D{%z}r4VQDm)|C0HKUBV*p`iTw;z{)b z&FZ#~En_#ce{(+Wmm$k?LidH|o`dXrg5_U0N=JU=-_(9wJ5Rmo&m8|ry+Pgk)_rwf zZ};P7WBbbJ-#rR!B4>P^FSKhg9Z^`yk<`=FY~;YRnq{S5YNAi-mj^*YOFh{Pv~F;| z(Q4M&Ah5(`!iTER>i-|s-F@a1+Z!&)MqEs@t+QaRyp&kA#JtulzDU$!i}sucnHL$CDO|KE>Z$*9eEv2U zhP7rKeO=eS@VK=WYbIQ_ty1L>awwV9oo!TEa6{yb;$k!QEsc$KMbFNptm8jZA~t`m z@%*_9F@vL*gcl4Pig&j(MEz5V3= zg9*|%M6DS7bqWu8oHv^$dCw2NI7bd7DHt>(BFIIoW^T zBkId@^J{Ci89f${P7p6hQ8%;uafGSPot?`fM`_v=JVZ-l9&okJ)50VU<+F)g$&c=KIo7`qR#q1=pRaqO8`i0CTh08F_O;vt=l*-JygbTZc)R_lW@StI zIaOwp35N0$nIG`lYeoB&9lK!sl`*WOdH$W7oe>lDAK!HD-}>dKeHW`-#Zg%^#lV!w zZv^)|xU4IE&i+Nu*_qADzMR>1;ia9#i^c4sGMmId-{6YutW8-W`uprkpTAGEi#Rqt z|894yWVw(dkLs05*~3$UKWzJ1Aa!%ybs3Q(FEl4!xSg=Jbo~;6Q=1YE9F9H6T##}i zP5VKi9^c6WUR^4Qe+`s>WGr#`kQ2sp^1Seh2f@qix}2T2K4@Gv)xTI{@n?Q{_ z^PZ_@zWbOhSJ@z#^W}lC?}r`c_hj1CG>WQhjLmH3&z+mwmpN~_uJq%-&X>CD+vN8@ zc;>(pymcS{Ic}efl}|JtESmnYnO#qL>&GGk_dj!HC39%WwCY{uT>Sb$bGLiz>%ijPLo$6+CO0iyuzSHPsq-&<`ENEYXee8IcB}e{9R4*gmM~uretv9n zYj$#moABQSvtusma7-|_+j5pO?-!f8bOCR=$&US5jLGYY{n@(ee!OVUxv?zk@+MA> zb8<01eE&?;mEf9ndFtzm8*KdbFPdvNDpmi;bwPA8pK#_jD%mP z>Zh~U-ZrV_IpEB<^U%Tvt?xfu59by&E62sA zC$AH&xsfvGT8Yw$<(td*Y;fJ+&GPZdl*Ay6{k*gH zT?)3E@WIRGVRHM=-imFn&fU7US-j|}evb2|-f(H{eGiXjODCB%#T(pt+-mdCll{Rf ze)IW`!Jh=%kHl0hE4Op5OPXW4YLe`JwYk?zCck;$E?&9e^P}}=r`$QB`7NDKPCH|b zkG00U2c5B-gqLeS>D2qunEH6z{E5>e{MFywlDKu?;s4smBiq|Pa=L9fJfH8v0r`t> zX1_cdzD3>N;3u=x8`eLkS3gXu?0nE-S-4dF@r&;U&T;odZY=*1xam-P<;i>Zv<3gn z-v4v9uh_Tq-9iVi-I71iYI~9~#8YqgA^q8puRn|~ZF)9I*U&M>()vhe-T9z38T;L= z=Vlybty+0&{tfrK!)9x}!+(TqwygNLz%=~rJh>Z2Q7??8HGewG-<%+R>+JKzQ4 zyePC6KIq5tlsAQCeNgwgbzgUff7xhQ{c`O*4mTbr4xgEA=`xdh8V?&-`P^#BIWgsk zN0>9iYA!X!szZ5`m)1!0w@IdWGRHOq@H!#0-MVz* zhXdz796Y$%w8?$`!J?=G6D4}jREA}}1>_ygPN6c7VmhUWyoN(s6YSV{J!Dh{V zb-w#^Cj2=OsI*h9>0xs8wNIM6Sfu&QB&WtMJ6*ye7o8qnH@_#3<@rpGW&Kf``pQo!{|}xq=g8ZA+Qes9*c`hh(Q@s9>0Wwo8f7lu+!I&$S@Wd0ee(Jb8${bQknudU!$e*M}Fg zVh;J6&3)0~S>r16Sljl=tnT?4xHb73rOQC8_JOD}Gp7D-_oq_j@AvXu;ml z{e`=htxsT)uPX|Toh-h4VYZ3anZ4`wPwrGmn{v{`O*C0Ve~0C&~2OY~h11Umo7;%lAj*>bU5gLVcH+7 zMwRd#Uz=|~TOv9mgwZ*H`}OnLPW!g({*H}bmbh|PPPV@}dACD*S(ygIMP|#5k{>>> z%SAQwi{E&XKH14!dJ+34ah{iLwwxX>IpVLatY8bCTeHA;*2A5djKQG?nv18UtY0es zEs!ZgSo?>xGIx=}^puBkXA&OAKhWdwCRZyB{n~s zDE~j1`HTOy2a_vVWq+E-ZnA8Qd$2tH!%Nw_*BVb>Q+0pvRpIEnXKH4p2C1e`JJLSn z&PqA{?PhJ+q}&5DV?7vdFyGtq(Wq2(-xKNeA3mm5WWDU_yWnVF5Y4Z5d$Z;x=9+@n z>yLT=*z%*V{JYltfSW8gKZ)D<@B8&~a{R&jYHrU;B00_O{At_sxwPa`r`X(_)_Es; z@)sJ{GxGOev!VfOtd{Y~TN1@?H0 zBLdsh_ci;fJz8k_=WvvjpuEkUN5VbHN9|ni<@Bsm^?Q)6|8s7|$?y{aGSg=?u3bOr z&K-Zb$>MW2>TYzn)LB=v;@AtRxJ_-}-z0=TdAP7k_p)^4(%B!fK6e&0GV|Zang0Hg z;BGCx&DyWeTovoS+%D!3A2zIQI&R2$ zQ_cB>pNz#!-eVImKs_0u`FLOw{Y=co314;(&CGYgd8^}7@K&x{C>i3&n1!F z>Hqm*dP;7PNVmCPo{zodgQI@CV5*) zUCAisd1tRJ%dow1{6~-epJ#JqX3mk+oWnC?&c_b<zldZA~`uV;rjBV&h`@DAX<1aEXCPg`47R-Hf zsdpOlqxPJSPofSQOK?RUd|TI-E1dU({Y(kRkt?^kChdK2UG2Qu&xF|#+fJ&TY~^e2 zO)GfG@V`dy_rZF{D1oB<7}m-5Ru_||=d{&pBs4m%`xD5Jx;VYv_ju_(3I391vnm&B zi=6p=t69r;99$~?u_=EsZ;Vw+v)3Zbxx3e^F5z;dQC@SB z^{?LDZr)Zi_jS5&_{mc_q19{t3zzxTy9BR)*~o0LM!EaNoyk)zFV6OPc%@x!Q}X>c zGW;*DAHQ}|sQ;+ihsn%)a@fv(ldek9PiL=AvHoEguEWS~W9BQLBjoer=xVPTC86BXHu*>^PZ;Jy&DrdFL1XnnV<7;^_FG7qh5>dyL&i<-}LCm9EF<^ zhu57rbX()s;_Yv`e9{tyy>=WpC~kSsQT^S^R-ThRGTr+#ihbu-=-m^EzPZhXegC8& ztHst82N%h2Vh&y^{Y^{kqV$c7i-%HqrLMl=d%Jm4cuB_QOrr#KE&1jAwNcq;`Q<8i zyqkCCg3q-VY4e{PWP3MXz3I7U6Z(ThjY` zcb}hkpRLQI)@^p@*1CfX*8jFtw1wAiSs=<&@$$G@OZ?Q_NsKdogr150X)HI# zbGltoEB`yQfSTR?a$7FC?pe_K?_tlh7Z)dW-pH1zeYf=mzkO7A<%{kzixUTGvbB$e znk)`Kt#_eEe4DP{$I@+!Ow}zCK4zC4-*&OnZc|CF%%3DynFp&<8q`GdwPp+NKPa4k zGWCy7zjtHm_g{;(@9vntw0gtABl7bud7Fsz_ewj9&!{+K_u!a$ropXgr4lacS`(&-~1N|+9^pkv;B{sWH{p~e{)sAg!rO^>u)6S ze|HsBZz@+4ToTc`!C?6kf$N*~4_|V(i0WFz(>JR*h-aY&i|Ym+$J2_OakCo_tewTJ zXVW6h$2Orb-{JiKEqpc`F2u&$xYWOX^}ep}yy0K1s71`a72WaI=h!N5k?RjF;dJZK z{deNvo~Y{|8kVMoRP@a&5&2WWA}{m3n9ow{0o&s0+8-+;mR}OLyKvy-ZuRoV*IK%T zw+24)bucumbPBdO+`8_CWBaNX{d&2@O%wlY&B&aaz2zJ)@7-LU3P$D{D@A?Lvu|7z zF1Sq(+sMZIYRT%4FO08$os#~#CwA)tWvM9P^LMYiP5zx>JpJwi>)R^qn>@t|9(4Dy zI9P?;Ty9s?`96h>y(Y(jRa=(D-0F;Sa!rK)y3pb&C97Te|2DMytqq!QnZYFPvq3%P z@2bkK*IpaeWbe5qQQgSS-(`6H<9oZfp5yLcB7ED(MBY=`@Nqrx27cKZi2muFmF8K&BOZ1Vi-4XX-P z28%yC(*BxL*{X?s`_6X{g{vP-n=zHyrGMv1fpe2GZML^>_*^mXPqX~F4?Eds&v}@{ zpP}*2Uv^XQj*I@~LJlSwug#BJ>{+#__y5}D=l)-2U7y$6Cgk|vc(?w}d!53LOvgkH z`aFA7`>k}XZ@{(flH4047l$c^98%A5T3)i&w?d0ykI2MLUsrxe6}a1c*TNz;yE)m< zWOrE4d86akH(H)A_0wZ`IFm6;lHu2bqqDoxuezOnaByBxbYbNBW&GFAHmX}4yt4k% zOtHAvQ{Kh;*Sym{t7?99kBoSKlf>g=)Bj}{#XmiwWoJ3nS81lZy493|oqY4NKhMfu z`#L4T=3mVDq`ssWS7liaE>=~WhUKloHATWaTQb~!%iTSAZ^E4ao!ct9u0L}L&Ype! zN2;!5qvdtq$SwDF%(}D8X0z|EUwr&@4st1mo3g%Wq+&paHo6iPphb$CD+`< zC9bJIuW8$Vo>%0|R-c+;p0md;9C$BM@rd=l=$4)C&VSdss?R=m{jK@0km8r_XZOwB zbTD1#W(&J+u-dxC$7McGcD*j_XJjV+?^%=Jool9fdktNsZE~;oO3t_2scZE|k-I=N z*CcznPEWh`twrwK@^WWZ+DF`NW{lrs7GCcvKX>EWnKQ1Y&*A&vWd71c{ZOIrKU`K@Tz8iJ-CLhraiZ-af4F+nx8&NBHJ^63SFh)f@7h{$I8y0FNtjZ_azB>u zGxqq!do9#Bb$!(@;V>ul3bqIHJ_R2+a$Sn4?v|HLW_mzx+LuQwPYJM|e?2Ah!`j&& z!gt;|($Tzo+m9yse4g92wZ9&B^IcY!yZm@bZru6`xvREPpH|76a!G}k>iuj0Ted4KJilB3;~$1Yyl zbFC?O{_EG%9@y~oynbXdKlVZYeDULtu3N;d&QR`uqiT7_?Ch5%>&({n%S=}NbtJ}Q z_qBIZck0D`e|C4PT~WoHU7pv3kFS#6rt&W1Y`XQA39^~Doll6b`SRRO=F1|Vn0E)y zip8v!Jtna}!u;bQ&NRdP*4w+1b$30R^`b|NKh#c0LGVlO!*n~rJHb*9pT?}aZux83 zVZ*-NVUIMK9qi{_KNMjk(N-~6sPFX}&g-Gq3+9|E*;ep8W3vDC4>S6g7i8_8_iMl2 z{fotu#d06Mt7;YQy%;V1|8-5llxu4rAAh$v`IhS@2JIc!+N-~9)%$hG_+>_2?YqOb zYjSIkT}@bK|NUY@UBT@2>rEeCTJEy^^)=s!UsFr(X763UHgnC_V=>p`Z_jGaJ#73i z?uz(6%l-RK{+GLdwtCXrSI<8-KF>KkN0YgDR{OVguixA4yY~B+e0cY}47c(h*$+!& zZI?-BPj0q6{>)a-?w!`1C)4(1f1K<)b8_F8<=nYN*UoLdrm=OM^!lsIQ?5U}Z2p|Z zIlA7eEPj6Jbxq-UrSC#ZDjYNgzgS)qa*UVTDZIXIy>iF1q`LJoug_})*}0|&R2R&9 zzAxEmkB8cI(;TPxbGxl7ySHZ*1DJX*KE^x3(O32(Pv+m?6eYJ6|}6K{WrVcTB$L3XzF&;6_B$xZwBdd+cXX*Ib^$p$^=SN&J}Wvw>6SSDkR@Qg!a;UhT8RwqG}&GhcV6bp6*q$G%@PeHnk- zYI)7nUs+%MrDm1i72D(4T`ekmzE;VCwK(?Ry{$jv7N-QT{!jjs-g5ldd#U%~3(e zKm4_dwI{M^<2Q5lo6`B`ypoI4Z^zVrwyHThH~H(`CA@jdA3RXo&YAxz?a{pJ2WP#G zIdA#;#^sXwo_`s09#39gdH2rkoXuOi3*;7mjQIaV^iJ|;y+f5!)xJ!tb;5VP>3u!h z=>4v;LlM{CpFQdJ?8Y9p{6mq))%GP{*FO6$bjSSDE(Kg!T-#r>T-nn-@4#}WXQkQm zmzn*$u%&#j`~Q2(KAU_L(e0`H6jE=qHu>x9@;6oz{j1OZROg*6X5zoA_w2{xj^RJH zXzSHhe^Y3T$}|o?nk@flevGg!_REq|N82-O)GD4E;jx8_Uy~tBZfQH*3J-<72aMw^}fyb z&Ih3^yV)eNmpQ2SB>ycwce!A0VH!`yEH{Z>e`WjJ8y98PZml+1U;FX?tmF;Pe&oil zH(6(6<5zW~=0{Arx~<60@4o5DUlb=~{GPV{_qyL~_r53>{Q1&7KRM{{9`{b4itm#) zuKpymF6#BIgs)#GbE>ZVbwPf9@Hf>}Lf2>RQR{xOS1Z?iX8X1$52f2e|8o7BJb#6Z#|j9Cmz_cdfoc$@abpy^S;EG z?XTR-n!K)feV6QVmjbU>CrlmJrgD|^$-bUnJg@CFk9M+y@U8G)*MBc>{MK#O@gw48 z%+HShmicpykIy^u)$4KYrQ^>IKevkVGJA30y*!sf)X8~IPQ6c(EY>|a>-xco4xV0r zjP|Eo$S*!S{|twIjJfX5oRVhddA~i2w=6DJTl4N>B5#yxkWkqEkI&*Bt@4#KU;25~ z>kD&Y{&al$bJlpzqU}dQRxi4l-?vb5?+gEB2X|@xQ#a)IpE~v4*L!>R?z@(~T=z=- z%~{Xp-kQwP=b3OT^!oL!t4}{;HJL`3P&Hk*{K4`M$EN%*uAFT8 zpZ!Gg8;uQqbwq<7&~2{?A5ZjQAHYxAG!bT|7^W~^WXV?|FduZ|1c$D z<)j&>u58^mb=fo7?6vv5V*GViw%0GbxHKoe9pRjf2J=J{njNZpItk5o7H;t zJI@|vz1s87^7p7hs9y5!qpiI9{vvmUA%c?(*F1L|9{`! zYxm#fUbZ*qsX6!SIX7N=Ie*Ek^Z);xf4}$h-1m1@)!&I@GX8tEX3GWNUo+qCxi@*M zg8B7Do`+t|zw_Ju!~d`G|F^1!);X`Pw~K$&#n-v=zxF%(H+%lR&ENlh+xES=zwfVl zF+E{n<)QnF9q(t=AActMdb`})f6@oH@B6y8+WyZ&{`Y^MsN3HZit=22L`L>YYg*^3 z%MK^MMc@B*tvbK*bo9Hu9}aOxH+8IkvGbH#dCxNSyZ!Ay9K3hUD@m3A)fapI=k`k5 z%=y>LBh|NS?ssq1zM1`f-S;3mbWr~93-|AJUsuQ9b^d+6{@>@` zxc>>Uhq~%?tuB0CX1+Jm`(NGr?{)9*z5n;_eIDn6>$fTjKAF9Y_*mZ0{#0V_S?g<2 z{bfaee_h{S_kQ>Nzwh?S|9QZE`#;;%9n&~2iO!lE=EYL~|9gGCcY=4)UNyh@1$U3J zmGmrcf2%(E3D>nfeBY*g-}w63y)x^UbHO2}d)U2E|7P}XzIDGd&A-0B{W`y9Tk$=) zn&N!t=i2)3t_CYvY%M)#>L{xneDd?J8-JEBwQpY2yKZXx*L{`#n|hx`ZP{^e@z#B} zx?k|k`?gKyvr(0rZ^ev~*w*FU58_SK8kypC13davl%n>V{eLX~|Hs#0)8&nEqTT|k zwa+wOY~R;%Zm+PT=M{Fl4~^CD>%Q-PzxQ?Q`(5Q_W!qE@CP}DA{g|^yZn5dlHJeVP ztIj((iNSN(9;Rsw|2|FMzvp}Y|8M!XSBKTsxyC!SmZ|5fHu+ti^UpIP)boM#{U68H zdaXG$cTZT<;=uai>z2pgJ&)Ssk@QzSpydDW{r`WLFcnpF3`Wx4!c?eAjyUyHB% z$Et2TcE-~#eBwvLTXN<0_tgK#zCZb4#v6I_-tflxYx>W|X72AeFM6!>*}821@9RAu ztTM{E=UQ}o^V!n7_vU0OS3fTBvsisL#w9rUn*WV=p*yNii0q#~`@hbl1W-xdAH`(3 zx-4&#<*t8oBI2*FZgva*yLNSbZtrR@gW1ZQ!Kw_|hT#Gm!kEN(J~wGLPP*gyP0prb zgKE$u2lXJot9zDBQSe&yYg5NoyM8yeYmY+x^TXAnEDX4?Zks^JBlLv`_ta z`rYK}*C!8Vzpnp#z5cG>WtEV)jb1E!ujvVzoR`|N;Oy!L_WvH+-+S?ORYZ}7Vu?~m zSn**&-;3|+WV6qeMp-#LpT7Uk)9U+wo|$h?nP8`~?#a3f8z(!=XD|7rb@APmsdIW~ z8o%^(yY~L#ojXy*lltxcoG*P~a((O0Co6nnu7#@Y*}1LogL>byE3??!nDQzv_0~Q9 zbue-EDK7I_v(jxOgx_uZ@rPeZO}6+=N$sQqmz5Z|*}OHmo&I{c%ZJR1mpc2>otWl$ zXEJxLG+Q=jqVub4;YisnrJMKf+iSMmOzh0Fn+%p!v*Z7sExnYo_p(Lq(z5}N9$Yz@ z{z9cz$Z7uC-=OmAt;>b%FwT(qYq{5{oQx_E-H^L%UyY*RpUw8aH&@4P-}hMd{f_do zIwcLssU{B`rESBf9&XF{lUW;^q9{1Uqf%5yaLSb`u5YWNgIfE)w8qVkpTe>4``-6= zg&dbR+LebZN$l0`75;7|W_vwTwdqC8*Q??0YadJBulQ@SS=eX81*MzCO`hjenmDl3A{~Zzh6ZQE(zyV%=lUL^J;#1Q> zfpo@j+12pU{nL_7)_?Z)0qOVtcU%NVY&+lvQ{?f||Yjg9=tgk;azrI!JVsX;9xB2ze)k}ZL z|Nkf-9rWXM{Qs)oJ#!t59#*jaY%|}J`1_^MeE~N9nk|*4IcKyJz>Y;T$@+WRWCrUz#X4GvisK1uF1XW#QdB3P<8H|O5^ z$M5`~sx+$WHeU7HoLyG$#WH_Onct83oSaWWqK+QB@a%D2Uc<3x#}a)XzqZPrYPNEx z-~S`e|3w(C-#G~DL)JI!|F(5~?tPvzqZcg!O&LCn_cP}&@h^Hl zbv?`b?e)L6$N$fnb@sk?^2r6^tA(66yIGD(%v3f1Fv+|2_>bLL|KpTiT;1SeP^S_j zTA|wHcjH?4;q7xdzDXXe|2e(>=01%_A=k|3{hnrAIZ^TM!s&V{^{fqi_adCT<$FO zc*@k$HUDOB5iXy7{|M_dtMsGqyA}4WeP!JE|IhjVdsKbwqMvVWnxwW~ZSE6K2bDS@ zf%Sg>pZNbv@%~ohcb0SElx=$Ht!ym##>GH#;?0{s zr@P+!Jn#FT_2)UPB&S@NW^yFDgzfNOt7~&k-zsV5vf-sJb1Wk>Fq&sFUxN$B%h z_C)vP=go$G`k^%*mzL{He(&|T^yS<=>o({;zW8H_a>Qk|6ASCMgsQ(emVW<((wB$Z9N}&dM0eW|7P0Uc|r%(mrfPF_uP$1CO1zZw%Fxp z?RCrL|91Y|xqeIB?XPzlUK!i(SQ~rWO#5%~-0JLJZ@U`LgZ%E*x-XyjD7`RUs^T)0 z#p}%+7ORJo8~(hU|LGRJUd;b?j$< zK3{Ok9X0Wa^XG&QRw}*N`Yl(bX>Q9x=MB?V{Mu#~RlDq@;@_DW3);8a+pa^ZFC$%&UW)+_yeF3`D9*zsiI`q>v3`q^FB6@Fpi zk>mH~bpMLFFY`y{_q7i`ER(sV&bukS_*^EmYTtuTJN#KLHnQ(hOy``>a^bmAs8vDG z4fFjcJLk-0yVMzeWYu||ENfm9{+JJ!osCxcmTi7(wX11iE>Di>j+@Wk%(jTSZMAmM z{@2g0%dgAX^)KPT${qZ5-w$4yKd-mcKKk$Ey6ahcBRW$&%hbN$pa_lD&rUuwFpCi*5L zD|waujB>;B!(hc8ZAZpX|quZiu; z;>uI(yi;Gi`DgXE#rXQcdL6+p_BDHxV)vWYl+EL?>kL2q(NT;w=Zm$Zi+0_Y)z4H$#Cz4{i|k7KeP6A)v1-0w@PyIe#~)7n|hn@BeS_mby<~vg?1v=I?CHDJ?o7$zn6Q z84?=}rhjBOe3x77$JdBg;g6Q~@|s9A9yB;pAbr|{qa~p|qlJ+(UMw!*wDiC8>a+8O zC;wl*t9se$Rl8UDd3JQi)$m(JFyY~D` zc1h{zA~AUu4!7nwk(bS7;S*SNti$E_uO99$Yi+QryX0>*yY7*0tPi_&c>U6sHGA9S z-#&8gI{qd4W`?=_oNVd*MVnrj-~Y1I&UN>{$MLn9d%Q1tU%Pei{wd{I=cdjy5URK$ zwBY^fIxF#)J1tEdJ_Pn(*i!#e^+HROdeq!g23F}ZK2|F^XDAwR$}%TNnmZUUFYhyJ z;Sqj3*>Dn5(x*54rvp+M=8ErPwCInothit%w}<1A1b>6@h3CfF{~ll4XL9`0W9atYoXzxn*Qnu%fnT#hzpZ!S!}UIi03)kGyA^>i?5hOMUV+^>2-j{FHrv8SV>y z@z>DhjXxrHaO?UntpA_9%gq&3@X??ptFiI)6d(^t%Lu74+7iVU=VnP2Sto9Skz_e@UZMt9xDXX!N- z;%BA5KV@w4OuIDkfU`$}{l%~#wb`#FgEY-;-uH37sLy9kki41fVBkEvF*QX(&F!4@ zZk~BhBc3nXn;66vD7#R)A^F%!mi7S4uNMTSiY}4-UU6T~=1Bjy#i~{@n13Nx0;C>Q6 zWqFL_-jvr8wQp|-d-*v`dao;0pX?{TCET)fihtafl`C|&EIl@RO@o?TvQ?8gKUbW} zB=L&w?VvCr=QAiFYpG=-{QLO*WOc0?0l_+Dnf(|%&+|p_}o2j*5zjhba?GoU7T6A zzK7+TaPHd~C)JErC@DW_KGQSf#E#RS@9$mrIgEwH*z4ly3r1NyQ%-C?w!tW5?*_&g zM#G+j0}Q-1X-gz@%o*SQeHFg{mfg}r&fg}_|C92VUH^dKVNMPPjsp*0@w#x!vI)pb z{_C+8Sm5huT~TuOc;D|eoQqe@TT$OS_53F}HC69V`+6KE*zJg9wl8si^V#q~pu(&* zy|$M2ACCx^-O3j=T=6Y)>zL~L zwz~iSbc!*ZA>{uJr~F=f1=s11+1GwaV{Q6zM7;Lvw{p3x&+4&jZ1a77-%kzPU2$;o zzYEOsA2_=2KVw_#-W;>NI zMZH?bnCm87Fv+M!GU8Z&d(*;A_WcVV?M+%CVagb5@`*2V^?&|<5BckNFsil*`SYy# z^kbF&sl}~r*|NqBJUdNpoeJ@{XJGnM`(?5G-F>Iq-5-R;OGJIWV%fi-_V26DhOg^+ z@9#VRJo%fPqs{#7?gdjBEtz%V|NpwaegCiB_t}>=iX_agarORsKcC; zHjpajXJQbtE%ixz@>t4_LCvbG@5+zvKJH_i8GcCLw#g{@Sh~LYF57|zjeCh!J@&sQ zo@3$ajXr+s0V7Mx|Bv$j3qJ?_-fe61s=ese9qzocC32&-M+Kho3Ue zytOL-mwQ}B*Q?j7$VD&Ryp&7`tVN za!z5)6k4olG5x#)qe{;tkrPZ@jrMJv0x2AGjW?o`3+v+HnXTg)|aN+-hs?`z|N2Qfl+g~iKnb!E`#P3ZEjz!uM z%E^zS`|kgJSH8V)(-zJt7Y&WP#ZQO}d^yBtkdm*gz|p{H%=+c(@?x7L2l;>}ydS5{ zd%32a!ND`Y{mQhByc(JJe@yzAm2%|A9wdLH@#rWV08YoXkq^|DTA5fcKwT9|7x6;{C8FVuVwl#zCI`| z`mpPAa-93FHMVgTRqOU%E|Ji^ez`RFX#L-L;Gp!FzWBM#Txo?FA!@RmHZ3f74!E){ zPME~#(_@}|_`(M}hQ^+3{TPFUo*cHh3$rh!sa$v~;k&R?XMSONMMa{7qFblq)6A1M z)}0RT$#LVl-@u^2!Sb$ALEu1!rZE3G>$DeE$ATT_t&q)C;a6x7{0lk-RWiVVHNPTh zPk7aG$&0rtHfrwE*A`Hz-}MDF7$7~t)Q{0|m+AylOQw(m0u6_>IXIX!8y>t`smxz$ z+j7A>F422!92XPIOWnI~6kF$+E_)#%U->2YcFE*GP7lwE{_$51HnWQ{Y)DP4cRq1g z?R?QTJB@IU^-G=<{C+Ukq(1NNuC0xS8Ww!2IJLV&%+iAW0n45l#d7Ct8oqv*T9@rS zb5XI$*FZ^4Ti5Gz7Vl2+dA9V+ZJUrV8?iH;&pKY8J9_z){9?mOo)YFKV)4 z{kkff&|CGtUM@F3EGclre1gQ<7i#A>dq{pi&BAisZt{M^kAeAezNc>;>*4#rp|-w3 z;ltzj*q-eiJWK}1Tn*$hJ_S6NeVoa{(0JyU{jFCQosb4CWbMQWV;Qsu-H|OUzTsth@zq~SA?$Q1QvX1fB z7WC|4Y+4=i?8h1vhwU%&4({}Lf2K83%Fk$WAB&t5(`%Px0}1KL+#FxN=j_q`r#$WX z(SO=(*I7cYrKBiGtT`}W#2_g}(k<16&EJ-xcVp?9h>yp1=zZ9evLQOJ`gQdEU6nC^ z*bV$Uw@JvpU7fv?H$b$}v4QjdEl2zF6TgKO2)zGsU5%Mj!Jz4db)WgleGgv7zOTBT z=1|!zkz=!ZvSHlQp8|(JHLdzpHM1e%@k_Qmo`%gfP5 zc)+)1;@U!!Wf>n#K5ld8dSjFflcd-6Pd;N_sVhvN@?`klsU6fv7(tat~ z<`LuGl5;T`b}Rg^o$7wFpr+VQ`k1qeb97wQA$`l)(R*6{r3L=C`Ep^mQ|+rgQ|4Th zQ<&kRX6wzlWc$Suy-U`+Y#j_v`dA5BFmuj`>EV5>bu0g9hVh1J_ZS@71Us~M{OooR z%I8i#Ct;+*GbO|zQ&O|d^Y64NmG2~Cg>RL*btST?+&+KAnx(+@=ab2|>kM-{n4DSX zFs-%G{n4Ygt5LwA#gKj32c?YQXr&JacRafO$>d%m|Cg!i;?LKub(_2~M9luhga0;% zQkk0=IX)S%>GIw_d{X(u>KvPfsmEjt7#m*j3rGmOk&kOovhr&0QGehsZ@Y$}>5H(& zm3iNKyE$HfySiq_zI3pksgTUxwYv5xbJLf(d|&6Es93W3=E^z#57g!V z`{I!~L+kq6`=h1UST3@&oOHCD$hXS-yX%+-oZg?)#+8x0MZ(?9HQ|ngkekPrIY%Un{Pu8F7D#+o zGj!$%FbvqEcsFX}Mc z8B^B(05k&ZJHKI@D918?n}i01grt>5>lOMHETy%7CI0Ctj&sOYtWLi3+^!ysSI%-=bbU+a=sDx*1m6ywzy#4;6o* z@^^7JqvHXKxzjHxeq{)?YIQHVSf5+<;R4%)XA$!>GPL~__L^_6_;}K5Hlx?B7=`RF zFRfkgboq@{P8ozTYTOf(lTk28&OSNiVbTc+m&S<+FRnbFyWxt? z)1%B>6)_Sg9p-%6${1m^ZrZ&qf;U*$7>&)D6@(oej_=$iWBkZwwv9f+^2avTw-O3I zo?>{_K85j${@;X-@P_9z6tAtjQM%E@Fb_L6W&1hH zU6o8zlYNX#`Yuc7GPIPm$$8FZ{=vHM!oukcGc#shZRTh2`aad!`0v8SC3DYhH{s!U zB`mikHgeBZ{mRz2F<(IQwNrd&HpN|)=Vpo_~#P77t=R!4q@z(U528TV9 zc2>HDfky3i+6qhzO{lz@e7rY*lXJH2V^D(CQQ7cHqUxOMFTd$8cl~@R_gFaeyzTcp z-xyrJPhH(ta`o=H-R~5qC?B{}b@O5Fy8HL`R2Cac_^y)*b&L?bXZl=?$N7<)fT7+u z{+b8Ov&|2?%r+3JkWqDLZ`5e(3TKUYF646vnl`P zZD?>xQ(uh1vEkUJxN83BN6BZl9_GmQuKnC~Fxzw5@)L#+PI4#j(@f{<`W2AyBh5G~MZ!Hva+&!I>V_hv9%SSl@ z6SlldC4M43ijmUHj~N-BiIybuaY&gr9Q$`5eSU43bnt;omJCm3eRS-uV@S0*^}hCf zwfXzG`C5yX+Agf#Qi=A-pZM-_wUwxV%jAC^7x&aM zY-o4@KI>l2TK_!DnV!O$(lzqx>>t>d*cN`canW9KfDL~p|JiJ9#>rh56W&N|maaO!Vd427jP-W0OdMI-3LWzs6a=INzLb5E<9KBscj4+WyB*u^t@(Cc{@b5T zjE;XM30J;te6Y)850hi^!Od(BB+?ZGBtCA~$lkQ)#FwM@LLDaDV`yAt#<*lp_q3e* zKhKrtIkZm~+`;(B#)0JyQ^K*67LV@EU~XiXBhqk5T*1p$keA=>#nyCDT|=wBi_Yx( zZJHVq^t&J2{OYi{>Pfp^zgq2=1*{yCT)i*d>if1T{^Pmd&mH+Bp4|PuA)T+n;!tK}|;Cu8WCtB)De3 zt7MTB^gg27F6bvbLHx)+OShM{?<>!H^NVz`R{=^BH?sXw|z87Yf z)VVRG>o8jFdNr%~;+(?xZwKtFSQ<2csWKO+gs>tlg zGud_n&#J$!JQm4w7vAzNGF_!sc1&O4$ItWib&s3HCpn65=~PobU18kPbNTnZ@B7~B zCLNp0c-mm0rbi{Sq`jQq0>%R@T$N>CB>8(}_C-J1X2O&3YO&4fq*GVF_x@1+p}70> z7Lz?)Cn7#MZ8gc^VG#1(d4TID+bLatCI<%T4{QQVPYy&mTnjv{w|-i*tHe+0!$hvwa^DjgrR(e$Iq+YWcMvGpYCp++ z0?&)O&)RoGM4+ z+?F%y`Mk`hZ+-sM@pIwb40G{U(~CF$JAQqMa^vO+4!^|Ke(62OC*Y$6YW4>)sZGw` zXt>OVy+`=M!D4}oq?p+gdW0XJ2`~ua(OJ*^_^1TSyl*)x^$iqQC(l$ougo#QD5Pia z0=~niIT&Z~2rK+J$X{3R+3iz;!5hhyJc~pGL@F7pBUKbmbT{?0vo?MFz2eepK9*kj zzYE>>_%m1vXjsKHDtzF$5b^HGQ`RqyvZuEvIb8U0$=%^tw^#$;U&aj;T;4Ak6g>97 zSQoPQoGd$+>|^5#9q&udZFRDGH!Hbn57R-=MLN>wr)`av3UdpIt3Rt<{mt&v#Qq$I z3(eDQ-Y$qf;QaaW)?3RSKQoZbY@a^=`Tb41*li93#4_3zxyuWftlz?JF_|~PgDvCw z@?WC&v;RNNy)^N_VXp<2f^)z0%Atk~WAeQ>Tdo{SJ`nIE@gmFOgAxX-Y|I)S{J#JH z-`NF5B0TA-eH&AlxFuJe`ciZXd;sI+!zVt68KhLK_RD2nG;RHsv%!jPm(My{Ut(-h zpWVLv?-Yk=sx`@?8S2|pu2-1&o!t9p`YgK@?gk1o+zk|VRIxD1CA|N}_+#tzsqDAy zEUdCSHDozNE_(8FACTX`EWuP{(^ztMo2PTTPiY@M%poKC^s1QT#CW5l z>%Tqy_-AIaT*)Vnbq)csdopJ8R6Kuk^Kq&9^-odm{`Rc7+3p2vx1E*ExBmR)wsf}N z#L20p#m;rfx>w~LHvFB^u)yqN(z&k=%jVuHut`)Ym?sqRd~(^G?l1KX4=TOtGUBB< zX9TDTJ15>3GXPJOe?IY)H%H0H;=sJWjSULUj6EN>M0lMIFmP*qWmT?Yp!C}C@R8z& zt$c1m0x3%x0^+9d%&R)U)BoVO-M5Xqt7kII<_T7CuyXiN#ORpNt*)hzkr@%wsIZq& z=cV_21tt#L6AV@iN^==|7_^?gWZK}S|FYn~+0rUyf1Vb`21dsP`u&Qw#}~8n-*Z{e zdGGT*Rx#$JvyGP<66B|RyU=?7S@X|U{sU8WDp=-My;|wZHf{UI4VTR3f4C>}a#l_5 zWKM&O{rL_TqQA&}YPck~Wy*E_zh56raK9kK-u97k#riK-XBr4u;~8 z4j=X`wg0ldmBmM6p1H#X>BDh17+7@ocUDUIxE!0fa8pdm&c2Bo!t+_1PQ6vneSS-5 z&idm$BL020DHQ^eB@PoVoU*Xf4pFHQf8Jlc*zJA-l zuKeKUHU0+yzpE8i=)ax#Hqn2!zf2e-8;8_UPH|nvVms+YxzCmU$|+P_Tx|F@){}Ea z0FQ{m3sqk4FtcgQjXWU^2K}6mPbe6ko3?tMRfTqiV1?V1Nc9{hZU5-jzF2M!yXuOC z&EZB08Jq$FXChV}c6cWE=f`pTeX_mUjY&KV2luctI<_erY)e;nUa>Y=Q6b~A{bIdO z9BeF)4<5PhC+FyJ;ht*ckK~RiFVzga4^Ka>EFrKZoL9nnvkY(vg_Q7di{it9G`yJa|oz>Z&>h;S0HAo&2e#6#$S7G zP5n~c@W8eAz?NcNl>;k`Jf^iV9-P+3xRFUfLg0+@iQ)@#j&T!sLLO|~b*a>7{p4F) z8y582J!X{H^5%HQdhf%hjP^`>{Dyyv|AmdJTO68ZH*Z_=Sa45_oTHri4=BblItnIi z&f(efQRoxbE%O=s$=*VHci?BJ@vcxw`H7UW;xqz)1=GG z-1K{C;-0D%%GLa3(-t!~{c1P=>$cx+?b~x7K`qM-*SCM!ZD}Jv#g2a^|JiJHMz&T* zrUQ9*ca?rm6%;{+1Zb-o(WrJZ{W2|a0#kFz2{}uL33{H4?s4`jUngCkI+1_NLdX9X zr|&<^tSrL zXHU$#e3-H6x#Gu#m2XuNf@b>cJ9=#Pqv$#tw$+NMIuZG@=kkW#4Dk;9CzwSTt@*7OQXU8>u$cb<0_Nv?iatJ#E^hJv(1d7VBBq|IMgjU3!kM z$Fa`FZ8_{5QU92Z-SSztreggDCbRkFALp-#|8;5lJ0?ekzJsYHy960#nXUc2>4S^i z*DJxZ5AIrbUywzkL6YsR1*4Q?*(ZC;io%MrdmsDCbKK^BpYliI=dn{2>&zpQ-R`yi z-TFzp_}160GW&k5Pt0FajTr73k+$ulsP8YXb4<6cZzx6iH3U_)8DZ@2@7}; z)zJS&Lio>`pDDA=1GRSPiJiC^=Wx&Dvy#GzZg>4g^QvzBukYAd8g(56WD_n({5ox( zFeCgz%;mJdM~-u`JofftW023^UAv=?@zB1V8RwSjr*Jf6e+Ny{yk~M`xKdH^(&So~J?!LfIrrFq)?j~iU;QE)yOVYGnJ z{7}*Z301jf_4zeL#&R}nHqAY(hufD;m^fk9o~ND{pUnKo>zwt^m)q+8CbCGzD6|Nsv3zdIIb(B3{?ifj z33+qA9G+q7*TCa2dC$qyGhVR2pHdsouqCzjug%){-ihnfF4u0Kym8YpH;vLaRnPOT zq@3M+?D6T_IeU5yA1w91wa|D^-5!63&<9idDqk4*m1yt1wBK}!{P|0tmV8`jTXTBx z?FtSCwoertvb*(|8tk?@nP0s=J=AYcg@evsmFP|17C7DeqPc)=0#nnsXJ3EL_$%j_ zdXnjZ@Wlr|pQWm>7yHb7visD5jdi=!q}b<`ZDRXZ!Dd@h*>Hiq*r&2_&ldOiGupKu z7o_i#6fgGKeQIIs|C1ZPnK^wn7P3g@ys-6|>7{e7zkKVDD_0z2k}taM&!jfx_`k5S zG)_3q$#G4-hB*jS?LT4N!yv^J$snvPz@k!7%Ha6eb>4E;x11-xMC`1dYRGn=alxEI zwut?Ip6ciSk!H4e96o=_(e)b**cuZ4_w)SeIN;&1VO#IUh75Mv= z=wfBjlT+4I9(y^#WB#1ildG8iF8OS;?nnM<7J>Hix7oqfUusyJrnOyE+FUaI&Pk>h z#%ceuZ_M*NaKGk>! zKZM(#<|$m45x%h2{#^F@kJHQ(RSKpFd0b!oGR7qS#e0T>D#kB89;kX9Xfc{8k>++z z$WS3evh#T7!=wNS?MB57AuK-_o9|_?9FsAYV^fMjvcDFwEl8K zLe&gGgL8YzKW*L3B%C1baMF8klXL1xZQ0B6Caxw+)?Id;s4kXatp8!1|4RV{4jopO z+eRN3I0($$8oTGg-5}jrd%E+hZ{Idk;F$5!-)P#Z{5>b-=N@Zp+*5nQjG?0LvGn~L z4GY@Y`O9_NS9iB1)IGeJK9i~G+*$hvF%H$NOI0t-T5~v5o)#!b%JFrZc#!Rw1g9In0Lz629=AD$=MA3j zHOQQO;1+X2MU2GFds21JW~Of|&NXg1)u}6fEB~lBkNm6A41)54>r*sg{5Cp4*nv%2{j)?O*mr#LTkYNcLiJX|%#G8J zG2cDFou71D?2%ypsq1C6ip-7s7P*SQ)KK_(r}%uXoYS7`^Qtl?spm_rH)dAcOh?zYe>$U#82HsOe5;yw2V%I7Z`_A4--Q0A~P zZ0c{GsBHepYMZ-3zk-9}gXfo>W zSitzVnrgTmgA`PK)fR2KezkjlJeinDtE)}<9jY`5OLHs-fU zcp<;*S2YjEqr0V!kv0qc%}+L&PdI*e(>`{+O$KehmcM<*Rrf{SuL%Or!vf3Hf1G_)eY7LH-1ds`f;oK2NQ*kwoiMe{xD&C%g@81m2C4>RN?ah zC-c|#iyih~V4T2^__$k5!6$#or-tRfwwM0;5d5D(Zp)Ttvjw?&Hvj*8mVU9sy-~?# z;qv=mrqoofuKf67dF4VL%e4*{x&s+hE7v#}>^tFOf5zBmvhLjP8(445O8)h9mt{lz zpT(-PoS%sbWUPz4X2$m9S=FCxf0xPgSXdgJk{9GZQ3*?LNRTpq>FROdPUQ1d#S{1O z3+(9-oMEFtJNihGs(Bji47S9iSyfaWfw(VrP$)1TT_ljQFp_sD9=vmO0BQ{NYtoQ01 zy0Gf-1y+{IVupjqzphPG_$eW9MgN#Ahtlp8$A1S{0;Wyxvw3Q+c8cq6%=XDo)uVdq zQ=eQEHJZjW^_X;lvh(Aq?0gP3Y%IFrms)L_ei+_kbbNefvl>&AZNLTDd4UY<28*Z5 zsp*t&i|OvOyClfK+u?NBvR`U}r(V+E_4dD9`jjdc=j+{2d)U}yXBi%MK)k9!WWqAu zq6bHdbK+F2|FUX*y&G?N@1Lx|k@8I{><4!y+e}*PvCXFWrRD+O^4_(D>gk&_XGJ&Y zJjmjkk^C%yvG&tN_AMW>s@wawO0)kxSk35v$WC8!T3Fqsi3cJ*4%DV!UHi`YOCfCj zRE%>*LXXhn^iHuC8*I+}_@rlGV8h#}!PY3qxU9myLQldqj+J4eVVUjWg90D97TxXU zd-3Vc$#f0l4X>C4dt~^z6F$Bx-(PLKsb_jk>V;$5AEZ5e7H~%SM8|KtB!>WbCZ8Xd z{S?F!Dq`Zr7=5m7Z@aC$B0hzE&jfkP4hE?W_arRYCpB;vWyb_H=53f;{#jQy-s@PS zdM<h%)8F@a_uiM|xWyzOz>@HoHU5?K?YKS%Zj0r~Ob6Wg9Q+(6q)#|^N%2>= zd@bvwOTG+T5vPqk%1sS74k?UW)^S1gzKfd3r*EhyLk2IOo{CR86b#+-zn>8#i?yibH=eo<>;X~q5 z>#y!i?kWjQAFnV5-c#7N*JcO2 zjd6+EzvPK?+_$QUlIPVFJf@v%oNnX&L)HCLq0c({8tAO|M^B zmGeAV$jejNJm>i}3){jEdKXzAui&wZmO5q~;41IpXwB%zFWjIYaKe})fw81w`D{6l zhLsHpwydjcGA1}PdN@sH?_J*QcgeRwfWxPK%iMDlisc*|`0odOY4rVaG{xDz(b!O5 zq2D6Fb^Vw4$W527|7JXRjP?Dm*D+W4ZC-Qldd6(|vbm1)*Mr6enHLrUFBYD*xzPV> zna;cmht&_9`ur;5i6FaP<87vYS2Zofx6IVJ_Im2<5|s}dge;a-e|jM|H?801&5Y%8 zKkmMMxv$!#D$2{<`dGM?_W78y|DP1TZ;IZY_xIbgv$Jpio1DkTWvLf(b7%HB+t`^i z@*)I_nLqPtOulwxmVwX?9-#ye7q{-`eTo~WWJjJhnk@2y;f~8Mex8(yrIpcVxQkuR zWMAAQE!DHQhEcZdY|KWTqZzZk56Cy4I$-5Kd18!n?u_MqOBo$cC!N>3FUYduj>DGp zeMU=eWuJU|Bl>WL)_;wrZ6CQAK3-s|+mltvQd!5q(6GAU`qcXj$8Pm+?Wrl`jqUfl ze!V!CNi%QJx1*Bs4HMYUS$v9mc-L1-;7dYdc~$D0kFxnC96t)=x7zb^u&^-}JvhFD zz2t?OzdrK;xFmC+Mq$ z#@8b}oQv69jBd#-($QxUV^CPnn$LP*;&K*S$G;hipGS1%A4s^X%+X@-if3;XqoaT0 z0ksQ-IsFQ=UZ2g--~8F;y4ePv7i+3n8Z~QK^cqBy7u|m%xBjH-ya#&%W}bUr>iak4 z^^Q%)F6{sfwH@OT_|m4mAaT!>jc0yMU0?H5Phg32g_!jDh6Nkh7+f8W&iFE6VgIWL zzV8Kx9<#DAH6KuWU%KhSx&`wacizy(Ref$Y|CgGE2a%ptFM3$&)Eo0Ys7drU z{S8!;QaEw-T*Lnl?e=$gdW;z6PT81P;d9}#)3H-auKC^TX;9YZ_UCA3;V@cvKt7*a z;XuL17c1`fI&}4Iv3YCF#>3#~-L5Mhp~kl2L(lw%1pOThEj`N3CxlN59A6)@r=#Kj zR^3lVa^E;UalB&hS7J1y4$C5^Ap!)&)nm_ z*)%$mWd2>wy~yS(i^+-20k%J1Sh@GtEIpw1-u%Jy`Be=O zwMBRD1jzk&+SI-6&#z}u#k*fm?qfOU#dNm!g{An*`IXQGZ55qD8BRN2a-Z{E7j&#` zVbTExf!|AN`kENi?%ZC&A7kkB%1bgtSafbrhnYmrw5t;8Y@!F4Pe|B1OlaJ+B_nd; z^uFUt%q#7xK1!e8D)|1^F?qYj8w?`v7uad48*Hm!h>>tw&@6t+P@yY4cb!}Q>Iy&m zC#o6i_gSTXI632ax44fzgJR_|g@C1Vs-A3KE-L%doAYAu^gVN#&5s?6__>Ea;Gl6? z5rfAQt@(Nq-1!TbbL3Q_&MnjKRd-mnr;5?x@xk3Q+yiF+TCx8L!-uCk)wrv&&ba>O zyf}UR9z*s;SJvx4VQDZs_ElGsDfO4T{mVrn{a>csyS2~3-qylmnf`&0UlFTpbH88v zaR2Y!`?<#(9_%vd*=Kf<`NWHdTwEtN+A$yQS#Tr9Snk)#e(ejc+_9QfDLFkkof)@T z_nnNit(klF6P|D?cu7Cw!CTBW6|9m~r|WFgGZuH&<>oP2wab4J z-x5B5&g<~nhfA;WKYpObAt1}#^old%nE5V!)g#k)Wmt;e?da9~kQXmMA<=WXP346i zRfP`!-w$gRUkZBnmbqi8@)z$5;SHxFq>JxGc&~G1;B;6SYtp;^*Pax)pgEV_cWFxH zFVI|XcDF=Nwf&3R?L`anZ!L^(5dOP>`ODPhw=5rs3$WCD^vVCYmj9Ia1@E|O1&%H2 zQum#qxT4{~Vu^{FpHF!zG@tmuDXDv0l1aEWN+H*=08?!*GKG^Ws_J6Uti+r&_A+5cXf#h&Z2?IGKHtiz9i?m5X&YGLO0Yf2@iz=g@4{|1_g==K-do%nvubqqgVsd&%(bo~U8xyKfM`m|-G?Waeq zCS?xYA626hSmaaqj_gX5W@cb>2#I&F{%~|PTgzuPrfErWyMAr{)XaACg5@rD1L^Dq z0uHB?U+gO0v%)zo`#|%)2hp?QUd*mzne{1wIqcKq@;#RE%{7IfQLU57{486S)-qhE zVQBg-)1O>qa6eDpW|hsnXAA01T~`04Ad&oMvFp5NlD7^l`FPO$r`N?0KUpJ>@82Hp z{g&D1&LpnNSe(8$-E{s7&AIXl6@kizZ)3DMQ#eYjk`q3iJa2sT!K{WJoyUh2o=%-G zYr$(4vx$vbUm9%OrZhe>Oj`29@CVQ2wZ{I3dcMOci5J`tn4e5&E~*fd?LNuA z`eXbrg*S@>@4lLvK1cd8!(NkyM4hj!^BcJLePulVW7YhO3;f9mK0SC^i@T*>S@dBBbMdbur)TnA@lW2^6uoES(i?|GKTO|lHurjZ>KErV@}Jau zSmd^{oSFMfB5s!dmy(7Di{<8K{`c}Yu*7I#pRb8*No<0Mk%*eS@~IaclA$Xz;Jv(=FlFTNUN!XBZslSzh!}I`)f;&5F}Mn3X>^ z_bpiWdTX)z_c!&E%}@Q_7Q=nSh=c? z|6uf(s(kzh!?8<}EC1AXl$-Q4e-wBx{-IIbs8DBZ@24%>Po4RxHT}nt=9-n;z8)-G zY4i7L_|Na$7kN3NuDwqclyhu|lU!K$nXOBm{loL#xZh!ojt_i2mY;P#e$}6SO5|~? zf6VKDO**H&TE8`8?bqFAFFhVCQgx6Ik1f$NyMJ7{;-a$A+gM9ZlZDq#PAkkl^s+=a zFpDXzV(BT)Pm8yw%G6z}+S*u`yW?GjuPnPl*x|698Q1ex{&`{5XMUZLA+u(;p3CN{ zOFVTp8q4+e9r?_Y9pAULbdCH;+kID7+rLmf{OP*cs^a}ytUf-eS?U{hpyl<+^BW`X zGTf}=$=Y3Xjyd7tq~}#{t=-*M^#1UaTYAc6x6$0=$tGH_ZSEH6JV@2uzki>o)t@z6 zPF=p&%y4j8TR)>?{-w`-i`M5iM!mGl(6?K{RM#8$x8wi1+*UsOm))<0-I)5Lm|hmu zScuPNW@eduW{Gm+bPdMIo;jNgrFdK&_XW%<)YMO&xN+iq#lo1nFV}63e_AXn|EW@Y zmsoGm_13L(tu6Ignl9eGzWU9^EoQNow`X`V|sII zcggF&{`yP*eBs5)w^P-5MZ)$KU8-g+ZQW`=wLJGMzsU6PsGmVUV<%s0d;K)L?7mw< zvF`3`>+kKo6%hAi;g=@%{s+tLzOH;b!+nBccbdZmxs%^Ge%&zcPxycB(wx)k;rwlb-to${e5vaCn$&mVOr{^VuHP@^l-gQ5vwG{sPhodY?U%4y{WAkLzsiZPmZV|8uIP@A@e#_r5wh`ODI8o_Bw@ zUUmrl6H@;)@#*&0pO~8NN%3*~s_9Yv{DPI`yPV_v%P;Rook*BEb=UC}4gE^@`lrJA zPuCxRx;FPpzo$EsxGv+b9k13FPpsn?*z@AzjBo3fu*?eaHF@6p$!hwpI-UCXwEPWM zwa*u}dGAeTOMj|->(jMAw({q$@7daGYG0Lo>udGaz?oa`Mao~d&n=aaxEN*>v;K5> zoz8hv#mJEVe(#$9uiAgj*DpKn%C2X7>@1GOFRWT8|2X&UX|KgqFGBKlrE6c_iu;){ zHU8Gt+A691Q#-}tU)XTy{to$F!=td{f1kpx*K&?=2PaRS{Pz9*Tgn-k7Lr$ZE1q^Op zKiRM%-ZpjCj;EIWZOO;Hcb;0cU#jx?#e$f~l@DeG{3|Q^(dqVl>C|$$-k{3wyVsqm zY`t~N|M*F-*(Wb-{HMA3)Ox$=>*omcCNKEy*IE64(e6_onYnBJtPy!syH@#qM4iq0 zRO@v$Tdsdw6+ZLQDYwO+*PV_}zV5B9{`SV!7gNKd>NMqcZ@a|9@oV<6h6VjO>-DQE z9v=JWp%75>=)=Y5pqaR6sc##L^}93L8L#v`-m3f9TkliP&d;Zgo}LwEe(!pAv5ioL zjEaMM_}>z}OP?8=`VVvP@=uRrQk%SEpJ~MMC+3Xd&6kh7iF)cCd!M~>wcz`zEpx2J z{2!<5M%QXKw@-gmb#`Obai^cluUdya4}3DQeZ%wM{a+OoR`hK8wB%c)7*o@CCf2F8 z(-y7#+w?i9GWNRLp0{7M?rBAL9jlV@U1@dP>FM_xjn}s}zFy7ew!LI+aCPi!n_I6d zkDsjI-}YEv;l=#CUkkP@efY|=cjgOW{YsYm-}imb{lDc>^x+rU!T+=NZ~1oN^8Kmv zzc@=?535`eAA9_F_9wL-7QHB@lA^0$OQz@{#hjLKmZ?~2NS$!Nsx=qDp3=U)GvuD( zVWG9BEX4aiZk`sKX!rvb8hhoW4=T4&NHy=+@+>5nZN+q;7rq?_YDLugjgHzIJcL&3Nmw+N%d&Ow)>=n^C&9_~kyI z>#sgr$z7fP>Caue8V)OkjF~^;|9_3&{?W;~HhCL+)BF1Wzqi+CGqU_%wy0?N$A!8R z=X~7s&GPSsdB0wpR$eXLvtKR$5V%}d50CYCe_7;k!Q87>|I5tuc{@LXCNA#Z+#((x zxlm+o-&6PSdHhFzPuQI+p})KI^|k!`dwX{NoxZ$nmc=EfsdJSd%(1?I+&%Z(*VfwE z)qe|rvD^PR`1a&EmU#w35}Z9OZcO3fOm7$;A5rT#*O+*`VZr_zpX*Qm-Q2PC;ni&{ zEVWZ^yD$AKdnef6b}OS}{ciPo{&nlunJiCNZu}q5^lVDTy&2j24!@M|{&RTJ{u#ox z1%D4UE>K_Iu;A=IH3Nko&&>D#JO(;qikE|_bB6wz%VCpdl&FAgj?v|0sAJNPKd|;a zhfzTMk3-^S$zPl0|0GmrTeLUZHrXxV{SYbj?Yz?as_VP+_I%sAes5t>(WbwTxo&T~ zHEFf#&X;FB9<&N&=uMU8nDVai!S#LLwz@wTG%@szi`y^C@rlFk@0ZKWEYb%(-I0A-x?1V)ZrirC=Z`ZqExNjN`~JUg z&F5L{F?n?3{%u}?J&(9d?p8OlT>JT?$x@X|TcGBN_hGeV>O23P|9EwM-Pd08eII*g zgO*zA@xHg-_BEr<4Q!*w124~pgRkn|{{Wr(wC#V)zklEN@7GQJ`{%j+{eS-iI7BQ( zboe)mFZ$2+O)+!9h5!1@T`!)d?g=_H>s$|uoCDKYQCH@s{lBiR-)7s?e@A%-lcV?H zh6mC2K21BT{NnKfwXJ*{cO|w>{wWELM&(9rWyaG7?>@f!+4`BmhmSA*|9k)c-n7>G z&$I96BwYB5G>(Y;UU-K6QDHw97*ClUDN~Nu!5FZ$C?eeS%-Y7A_uf=>yCh0#;(O>343hmU=TD zc3AlM1+Rk7s>yMsoNM@lf8C1V#M|ssRKPB|Lx40L)busVyq$UfE zf!B(SJU27T7Q9|97*f{o;Om9{mrviTZaCL?|M|U-JZvnr?i;qZH6C>TB^ z9tKDK?jP|Urw>nS+w01s@@hiIPq-tusyz577qL2hPr3Gk;yXX9Vt&?kJ+ph_dguB1 zpB@jiJQdDdu`!%}%J_WF<_#u)Kquu%3w&9x^hh~U>ev%5mRgQ0+W+@7*=gjiln^+w zgM*_?d52fCSuG^BT#sdH+`dd)3V^Le!jZ{9K~kxLSwt^GeH<_c<0? z3NKn$gEo}kmj2=J0F*6q&p&8=FK9ATmlw1W;J!^$-1qP04hI(4^PE>+;cU47p2)gS z3V!z?8K88MgM%)^^}YM1=*V!tVN~AEe|4&s@YxKR)ti?aK38sBtWPHrpnfCbf-zVDFaQ zIr~71=h~M0 zS9|vx%&6hBxpCI(-RZo$yT0C@ZJvMc$Ho4-EvEM_&)5=>`kaHKVZnQw#4DE!n(UMx z=Rd0vy~n0146lv~el%TQd6tc-Rv_en#j`Mjov|}eO;c_Z_h4ucw!Fn+(Y0Ma zA$`6=!jH}K|K?N&9x>!kJbhw0zVbtn$$&`Cik&G;sR>Qosa)oXHH^&6Eg4dhLFssTEV;a@0&MYQee%; z-%E4r_QdbpX$P%~Kz4aN*yY905zQD~WWo0C+NN0j(DxE^Ke2PD-SmVM?)Py1q z-aRGMJ}W_T#|EpLQEvC9uY5C$spB~pOLE!$7nvtYbj?viW8G?&H}A9U6(kwjlJxs_ zT>C0&vhFui_=XuWi5pJch_6`ZAdr0g5W~UbpqYD6qPSe8KuUlodTm6OZP@ur!L6bi zr^4OlnNQGX;aJCWj-emTztK!#q2CkoSWB|lxhnrz@o}uX=dh*XKUX>*OLk3aR_eaC z>#wu#$)IWb6UTHw%0S&pZ%xBG-HPf9;%v?5U7lWh&mR>x?fqoqJJ9k^}{Zspa_@C<^K+TW)f7d5Y4R_ei zUdZV9R1H-3gTot=l5Oq@MQoI5_<1UP-=|}%5yg*Vabw=jB+ZcjWkP z@56VYfe+K%J(VHg2k6pq^SH08!tYl6eI5VbN#Vw&58bL(Pf?<)hefWQQ--z4JpbOF z-6nT#efj&1!|q?KEFX%h7=6wyJTXnOW?A-#mZs z$5H*djkWpD9BrG9OGQi1dyEor%8j2VJIpvMedu^W5&ok5Y dJ3szs_@kz8{4$}ul!1YP!PC{xWt~$(69BwE9^3!` literal 0 HcmV?d00001 diff --git a/examples/ecl_qt/qt/main.cpp b/examples/ecl_qt/qt/main.cpp new file mode 100644 index 000000000..7c848db0a --- /dev/null +++ b/examples/ecl_qt/qt/main.cpp @@ -0,0 +1,43 @@ +#include "hybrid_main.h" +#include +#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(); +} diff --git a/examples/ecl_qt/qt/resource.qrc b/examples/ecl_qt/qt/resource.qrc new file mode 100644 index 000000000..79809ee68 --- /dev/null +++ b/examples/ecl_qt/qt/resource.qrc @@ -0,0 +1,5 @@ + + + madeinlisp.png + + From 2f2b3defd1336bae08319e00a7490771aeb30b0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 13 Aug 2016 09:02:15 +0200 Subject: [PATCH 54/92] examples: ecl_demo: make example more portable --- .gitignore | 5 ++++ examples/ecl_qt/README.md | 43 ++++++++++++++++++++----------- examples/ecl_qt/qt/ecl_qtdemo.pro | 10 ++++--- examples/ecl_qt/qt/main.cpp | 2 +- 4 files changed, 40 insertions(+), 20 deletions(-) diff --git a/.gitignore b/.gitignore index 366e31e87..1c43702a1 100644 --- a/.gitignore +++ b/.gitignore @@ -62,3 +62,8 @@ 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 diff --git a/examples/ecl_qt/README.md b/examples/ecl_qt/README.md index d37c3622d..7c4c9dc0f 100644 --- a/examples/ecl_qt/README.md +++ b/examples/ecl_qt/README.md @@ -1,4 +1,6 @@ -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. +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: @@ -8,24 +10,35 @@ Before you build the demo, make sure you have those dependencies installed: 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). +We use the external Lisp package :lparallel so you better download +that package in advance using `(ql:quickload :lparallel)`. + +# Build -# Build ## Build CL Library and FASB -Run `make` in current directory and you get two files, if successful. `lisp-envi.a` and `hello-lisp-system--all-systems.fasb`. -## Configure your Qt Project -cd to the directory `qt` and open that Qt project with your Qt Creator. Change the three paths I marked for you, if necessary. -1. `INCLUDEPATH`: The path that contains ecl/ecl.h. -In Linux it may be `/usr/include/`. -2. `LIBS`:The path that leads to the shared library of ECL. -In Linux, it may be `/usr/lib/libecl.so/`. -## Build Qt Project -Build your Qt Project. This will generate an executable file for you. -## Engage `fasb` file -After your Qt project is built, move the `hello-lisp-system--all-systems.fasb` file that generated in build step 1 into the directory containing the executable file. + +Run `make` in current directory and you get two files, 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. + +After you go through the steps above, go for the executable file and +try that demo. Happy hacking with ECL! diff --git a/examples/ecl_qt/qt/ecl_qtdemo.pro b/examples/ecl_qt/qt/ecl_qtdemo.pro index 8e1692d9f..70e42dbe4 100644 --- a/examples/ecl_qt/qt/ecl_qtdemo.pro +++ b/examples/ecl_qt/qt/ecl_qtdemo.pro @@ -22,11 +22,13 @@ HEADERS += hybrid_main.h \ FORMS += hybrid_main.ui -#The include path that contains ecl/ecl.h -INCLUDEPATH += /usr/local/include -#The ECL shared library directory. -LIBS += /usr/local/lib/libecl.dylib +# The include path that contains ecl/ecl.h +QMAKE_CFLAGS += `ecl-config --cflags` +# The ECL shared library directory. +QMAKE_LFLAGS += `ecl-config --ldflags` -lecl + +# Lisp library written by a user LIBS += $$_PRO_FILE_PWD_/../lisp-envi.a diff --git a/examples/ecl_qt/qt/main.cpp b/examples/ecl_qt/qt/main.cpp index 7c848db0a..330662a46 100644 --- a/examples/ecl_qt/qt/main.cpp +++ b/examples/ecl_qt/qt/main.cpp @@ -2,7 +2,7 @@ #include #include "cl_bridge_utils.hpp" -string CL_MAIN_FASB = "\"hello-lisp-system--all-systems.fasb\""; +string CL_MAIN_FASB = "\"../hello-lisp-system--all-systems.fasb\""; string CL_MAIN_PACKAGE_NAME = "hello-lisp"; /* Initialization. From 4dd7ec150b91f2aba21eb42ea0cf8b5f80c1caa2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 13 Aug 2016 12:51:43 +0200 Subject: [PATCH 55/92] example: ecl_qt: move files to qt/ After the first build stage movie files to the qt/ directory (covered in *.lisp files and Makefile). --- examples/ecl_qt/Makefile | 6 +++--- examples/ecl_qt/README.md | 5 +++-- examples/ecl_qt/build_fasl.lisp | 2 +- examples/ecl_qt/build_static.lisp | 2 +- examples/ecl_qt/qt/ecl_qtdemo.pro | 2 +- examples/ecl_qt/qt/main.cpp | 2 +- 6 files changed, 10 insertions(+), 9 deletions(-) diff --git a/examples/ecl_qt/Makefile b/examples/ecl_qt/Makefile index fca1ceeb4..50f131632 100644 --- a/examples/ecl_qt/Makefile +++ b/examples/ecl_qt/Makefile @@ -1,13 +1,13 @@ all:lisp-envi.a hello-lisp-system--all-systems.fasb #lisp environment. -lisp-envi.a: lisp-envi.asd lisp-envi.lisp build_static.lisp +qt/lisp-envi.a: lisp-envi.asd lisp-envi.lisp build_static.lisp ecl -load build_static.lisp #your lisp system. -hello-lisp-system--all-systems.fasb: hello-lisp-system.asd hello-lisp.lisp \ +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 hello-lisp-system--all-systems.fasb lisp-envi.a + -rm -f qt/hello-lisp-system--all-systems.fasb qt/lisp-envi.a diff --git a/examples/ecl_qt/README.md b/examples/ecl_qt/README.md index 7c4c9dc0f..7145c51e9 100644 --- a/examples/ecl_qt/README.md +++ b/examples/ecl_qt/README.md @@ -17,8 +17,9 @@ that package in advance using `(ql:quickload :lparallel)`. ## Build CL Library and FASB -Run `make` in current directory and you get two files, if -successful. `lisp-envi.a` and `hello-lisp-system--all-systems.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 diff --git a/examples/ecl_qt/build_fasl.lisp b/examples/ecl_qt/build_fasl.lisp index 1a0ac253a..ec7ac92cb 100644 --- a/examples/ecl_qt/build_fasl.lisp +++ b/examples/ecl_qt/build_fasl.lisp @@ -4,5 +4,5 @@ (asdf:make-build :hello-lisp-system :type :fasl :monolithic t - :move-here "./") + :move-here "qt/") (quit) diff --git a/examples/ecl_qt/build_static.lisp b/examples/ecl_qt/build_static.lisp index 375b233ce..9d0588e73 100644 --- a/examples/ecl_qt/build_static.lisp +++ b/examples/ecl_qt/build_static.lisp @@ -3,6 +3,6 @@ (asdf:make-build :lisp-envi :type :static-library - :move-here "./") + :move-here "qt/") (quit) diff --git a/examples/ecl_qt/qt/ecl_qtdemo.pro b/examples/ecl_qt/qt/ecl_qtdemo.pro index 70e42dbe4..d3cb849ca 100644 --- a/examples/ecl_qt/qt/ecl_qtdemo.pro +++ b/examples/ecl_qt/qt/ecl_qtdemo.pro @@ -29,7 +29,7 @@ QMAKE_CFLAGS += `ecl-config --cflags` QMAKE_LFLAGS += `ecl-config --ldflags` -lecl # Lisp library written by a user -LIBS += $$_PRO_FILE_PWD_/../lisp-envi.a +LIBS += $$_PRO_FILE_PWD_/lisp-envi.a RESOURCES += \ diff --git a/examples/ecl_qt/qt/main.cpp b/examples/ecl_qt/qt/main.cpp index 330662a46..7c848db0a 100644 --- a/examples/ecl_qt/qt/main.cpp +++ b/examples/ecl_qt/qt/main.cpp @@ -2,7 +2,7 @@ #include #include "cl_bridge_utils.hpp" -string CL_MAIN_FASB = "\"../hello-lisp-system--all-systems.fasb\""; +string CL_MAIN_FASB = "\"hello-lisp-system--all-systems.fasb\""; string CL_MAIN_PACKAGE_NAME = "hello-lisp"; /* Initialization. From 9199f21bd045a636f5e2385d2d3f5bb8ed42aa19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 13 Aug 2016 12:52:47 +0200 Subject: [PATCH 56/92] examples: ecl_qt: fix makefile target names --- examples/ecl_qt/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/ecl_qt/Makefile b/examples/ecl_qt/Makefile index 50f131632..9b1ebc84c 100644 --- a/examples/ecl_qt/Makefile +++ b/examples/ecl_qt/Makefile @@ -1,4 +1,4 @@ -all:lisp-envi.a hello-lisp-system--all-systems.fasb +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 From ab7ba370f19fd1ed6549e35e675c1231d7bacb62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 13 Aug 2016 13:51:40 +0200 Subject: [PATCH 57/92] examples: ecl_qt: fix pro file --- examples/ecl_qt/qt/ecl_qtdemo.pro | 1 + 1 file changed, 1 insertion(+) diff --git a/examples/ecl_qt/qt/ecl_qtdemo.pro b/examples/ecl_qt/qt/ecl_qtdemo.pro index d3cb849ca..d5640b9c8 100644 --- a/examples/ecl_qt/qt/ecl_qtdemo.pro +++ b/examples/ecl_qt/qt/ecl_qtdemo.pro @@ -24,6 +24,7 @@ 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` -lecl From 93ea93f06a68dda71e7965084544b57750cbef98 Mon Sep 17 00:00:00 2001 From: lexicall Date: Sat, 13 Aug 2016 13:49:14 +0000 Subject: [PATCH 58/92] Added notice for OSX users. --- examples/ecl_qt/README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/examples/ecl_qt/README.md b/examples/ecl_qt/README.md index 7145c51e9..49f22273e 100644 --- a/examples/ecl_qt/README.md +++ b/examples/ecl_qt/README.md @@ -41,6 +41,10 @@ working with make). 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) From 3f6a4b99a766724f7bdc6b63de899b74f740b2fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 13 Aug 2016 16:05:13 +0200 Subject: [PATCH 59/92] cosmetic: trailing whitespace --- examples/ecl_qt/README.md | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/examples/ecl_qt/README.md b/examples/ecl_qt/README.md index 49f22273e..fcf9ceae6 100644 --- a/examples/ecl_qt/README.md +++ b/examples/ecl_qt/README.md @@ -41,9 +41,11 @@ working with make). 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/` +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! From 93fb2bced28bf1ac8c28ce8c1d0b46dd00a2a166 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 14 Aug 2016 15:00:50 +0200 Subject: [PATCH 60/92] cosmetic: add missing line break --- src/c/unixsys.d | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 81de2b063..b875e56f0 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -320,7 +320,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); From fe320c04e4fcd29b8f588742167df7162af138c9 Mon Sep 17 00:00:00 2001 From: lexicall Date: Tue, 16 Aug 2016 08:04:21 +0000 Subject: [PATCH 61/92] Small modification to make this demo able to run in Qt Creator. --- examples/ecl_qt/qt/ecl_qtdemo.pro | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/ecl_qt/qt/ecl_qtdemo.pro b/examples/ecl_qt/qt/ecl_qtdemo.pro index d5640b9c8..1bb003f09 100644 --- a/examples/ecl_qt/qt/ecl_qtdemo.pro +++ b/examples/ecl_qt/qt/ecl_qtdemo.pro @@ -27,11 +27,11 @@ QMAKE_CFLAGS += `ecl-config --cflags` QMAKE_CXXFLAGS += `ecl-config --cflags` # The ECL shared library directory. -QMAKE_LFLAGS += `ecl-config --ldflags` -lecl +QMAKE_LFLAGS += `ecl-config --ldflags` # Lisp library written by a user LIBS += $$_PRO_FILE_PWD_/lisp-envi.a - +LIBS += -lecl RESOURCES += \ resource.qrc From 51fbe7181876802eafdeae3b08674f3125898371 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 19 Aug 2016 12:27:27 +0200 Subject: [PATCH 62/92] dffi: make :default default convention, not :cdecl --- src/lsp/ffi.lsp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 76e4c53f2..21c87c277 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -594,7 +594,7 @@ bound to this value during the execution of body." ;;; FIXME! We should turn this into a closure generator that produces no code. #+DFFI -(defmacro def-lib-function (name args &key returning module (call :cdecl)) +(defmacro def-lib-function (name args &key returning module (call :default)) (multiple-value-bind (c-name lisp-name) (lisp-to-c-name name) (let* ((return-type (ffi::%convert-to-return-type returning)) (return-required (not (eq return-type :void))) @@ -603,9 +603,9 @@ bound to this value during the execution of body." (defun ,lisp-name ,(mapcar #'first args) (si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args)) ,call)))))) -(defmacro def-function (name args &key module (returning :void) (call :cdecl)) +(defmacro def-function (name args &key module (returning :void) (call :default)) "Syntax: (def-function name args - &key module (returning :void) (call :cdecl) + &key module (returning :void) (call :default) Declares a foreign function." (declare (ignorable call)) @@ -758,7 +758,7 @@ Loads a foreign library." (if *use-dffi* (multiple-value-bind (name call-type) (if (consp name) (values-list name) - (values name :cdecl)) + (values name :default)) (let ((arg-types (mapcar #'second arg-desc)) (arg-names (mapcar #'first arg-desc))) `(si::make-dynamic-callback From 5031b7de4d4469ca4ae06674dd9b8e99a6df803b Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Fri, 19 Aug 2016 09:29:00 -0400 Subject: [PATCH 63/92] fix for #276 VirtualFree is invoked with wrong parameters. - VirtualFree with MEM_RELEASE must be invoked with 0 size. --- src/c/main.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/main.d b/src/c/main.d index 981da13c0..1d0ecb0a4 100755 --- a/src/c/main.d +++ b/src/c/main.d @@ -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 From 1e5e86c1d2702dbdf3a5cd7924bb8f4c7f6d1d02 Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Tue, 23 Aug 2016 15:28:23 -0400 Subject: [PATCH 64/92] Fix on several minor issue on thread. - fix #262 to manage CTRL+c on Win. - unregistered thread are left registered and enviroment not cleanup. - manage when a finalizer is invoked before a valid enviroment is available. --- src/c/alloc_2.d | 36 ++++++++++++++++++++++++++++++++++++ src/c/threads/process.d | 2 +- src/c/unixint.d | 24 ++++++++++-------------- 3 files changed, 47 insertions(+), 15 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 7e785d392..377eaa845 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -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) { + 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; + } CL_NEWENV_BEGIN { if (finalizer != ECL_T) { funcall(2, finalizer, o); diff --git a/src/c/threads/process.d b/src/c/threads/process.d index a53b0ea07..19e98e340 100755 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -382,7 +382,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 +391,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; diff --git a/src/c/unixint.d b/src/c/unixint.d index 087b87c5c..9d375e956 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -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; } From 28a0f957fe4d75f997f1c0f84e5046e2f2b7b327 Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Mon, 29 Aug 2016 03:55:16 -0400 Subject: [PATCH 65/92] Use the project comment style. --- src/c/alloc_2.d | 40 +++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 377eaa845..b6d5c7f75 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1143,25 +1143,27 @@ wrapped_finalizer(cl_object o, cl_object finalizer) || 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; + /* + * 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; } CL_NEWENV_BEGIN { if (finalizer != ECL_T) { From 5f0beddf69445855a98e88875ae98fb646a449e7 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Tue, 30 Aug 2016 21:37:24 +0300 Subject: [PATCH 66/92] Better printing of method objects. Print method qualifiers. For specializers, print class names, not class objects, and print eql specializers. (defmethod m :around (a b (c (eql "10")))) was # # #)> becomes # --- src/clos/print.lsp | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 939556965..cd944cd63 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -199,12 +199,18 @@ 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) From 9ae08a510310cdd6a042a9ac02a15b8aea696088 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 1 Sep 2016 21:59:25 +0200 Subject: [PATCH 67/92] num_rand: put declaration above assignment MSVC 2010 doesn't like mixing declarations and the rest of the code. Fixes #283 (patch provided by Vadim Penzin). --- src/c/num_rand.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 66205ef65..92ba68a4f 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -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); From 326829fd58b733f6f42e81f2e53a7b8c5860c7c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 2 Sep 2016 09:35:13 +0200 Subject: [PATCH 68/92] ieee-fp: provide NAN/INFINITY definitions for VS Visual Studio 2010 (_MSC_VER 1600) doesn't like 0.0/0.0 and alike. Add conditionalized definition for this (non-C99) compiler. Fixes #282. Solution contributed by Vadim Penzin. --- src/h/internal.h | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/src/h/internal.h b/src/h/internal.h index 53ed6b3e4..568c29b9a 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -596,12 +596,32 @@ extern cl_object si_wait_for_all_processes _ECL_ARGS((cl_narg narg, ...)); */ #ifndef INFINITY -# define INFINITY (1.0/0.0) -#endif +# if _MSC_VER == 1600 +union { + uint8_t bytes [ sizeof ( float ) ]; + float inf; +} __ecl_inf = { + { 0, 0, 0xf0, 0x7f } +}; +# define INFINITY (__ecl_inf.inf) +# else +# define INFINITY (1.0/0.0) +# endif /* _MSC_VER == 1600 */ +#endif /* INFINITY */ #ifndef NAN -# define NAN (0.0/0.0) -#endif +# if _MSC_VER == 1600 +union { + uint8_t bytes [ sizeof ( float ) ]; + float nan; +} __ecl_nan = { + { 0, 0, 0xc0, 0x7f } +}; +# define NAN (__ecl_nan.nan) +# else +# define NAN (0.0/0.0) +# endif /* _MSC_VER == 1600 */ +#endif /* ~NAN */ #ifdef __cplusplus } From 05ecb5dfd037f11dafaafea8040dc1d3d73b5b98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 5 Sep 2016 16:53:16 +0200 Subject: [PATCH 69/92] load: if file doesn't have an extension try it Until now ECL have tried to guess the file extension first, before verifying if the file without the extension exists. First try loading file without an extension, only after that try guessing. Fixes #284. --- src/c/main.d | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 1d0ecb0a4..66229d00b 100755 --- a/src/c/main.d +++ b/src/c/main.d @@ -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(); From 21b30c8c1e079db8587fc76286140c4d5213d6f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 08:54:46 +0200 Subject: [PATCH 70/92] newdoc: add comment about the ext:*load-hooks* --- src/doc/new-doc/standards/index.txi | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/doc/new-doc/standards/index.txi b/src/doc/new-doc/standards/index.txi index e33e6b6a0..804e831d9 100644 --- a/src/doc/new-doc/standards/index.txi +++ b/src/doc/new-doc/standards/index.txi @@ -114,6 +114,34 @@ @node System construction @section System construction +@c ext:*load-hooks*, si::*load-search-list* variable: + +@c EXT:*LOAD-HOOKS* is an assoc array of form ((TYPE . LOAD-FUNCTION)), +@c where TYPE is either a string (i.e "lisp", "fasb" etc.), wildcard +@c :WILD (matching any extension) and NIL for no +@c extension. LOAD-FUNCTION is a symbol of a function used to load the +@c file of the TYPE type. + +@c If the argument SOURCE of LOAD is a stream, it is read as an ordinary +@c lisp source code, otherwise it should a pathname (or a string which +@c may be coerced to it). + +@c If pathname doesn't have a directory, host nor device components, +@c then file is looked in the `:SEARCH-LIST` directories (defaulting to +@c si::*load-search-list*) and if found – loaded with LOAD (with +@c pathname with a directory merged from the search-list). + +@c Otherwise (if a pathname does have a directory or the file can't be +@c found in the SEARCH-LIST) and the file type is neither NIL or :WILD, +@c then the assoc value of the TYPE is looked up in EXT:*LOAD-HOOKS* and +@c funcalled on the file (if the TYPE doesn't exist, we load a file as a source code). + +@c If file type is NIL or :WILD, then we try to "guess" it's extension +@c trying extensions from the EXT:*LOAD-HOOKS* in order in which they +@c appear on the list. By default, first entry is (NIL +@c . SI:LOAD-SOURCE), so if there is a file without extension in the +@c directory, it will be treated as a source code. Otherwise we'll try +@c known extensions. @node Environment @section Environment From 5024c38e3330269e26171682dc3339570a71d95e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 18:00:31 +0200 Subject: [PATCH 71/92] cosmetic: indent --- src/c/alloc_2.d | 32 ++++++++++++++------------------ 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index b6d5c7f75..017cd0ad7 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1137,26 +1137,22 @@ wrapped_finalizer(cl_object o, cl_object finalizer) { if (finalizer != ECL_NIL && finalizer != NULL) { 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 ) + 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: + * 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; From 0f6793aab4b2057e0659b1e66c1c4cb2741aabfe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 18:01:04 +0200 Subject: [PATCH 72/92] alloc_2: wrapped_finalizer: fix no-thread builds --- src/c/alloc_2.d | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 017cd0ad7..48531a0b1 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1136,6 +1136,7 @@ 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 @@ -1161,6 +1162,7 @@ wrapped_finalizer(cl_object o, cl_object finalizer) &ofn, &odata); return; } +#endif /* ECL_THREADS */ CL_NEWENV_BEGIN { if (finalizer != ECL_T) { funcall(2, finalizer, o); From 09fe4d93643732f1cc1856a00d5ab7e248160b25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 18:01:25 +0200 Subject: [PATCH 73/92] si_{nan,infinity}: don't go through ecl_make_* MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ecl_make_*_float performs FPE handling – we don't need it in this case. We want this not being handled. --- src/c/number.d | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/src/c/number.d b/src/c/number.d index 06d1dee4e..235469b2a 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -920,19 +920,13 @@ _ecl_float_to_integer(float d) #ifdef ECL_IEEE_FP cl_object si_nan() { -#ifdef ECL_LONG_FLOAT - ecl_make_long_float(NAN); -#else - ecl_make_double_float(NAN); -#endif + cl_object x = ecl_alloc_object(t_doublefloat); + ecl_double_float(x) = NAN; } cl_object si_infinity() { -#ifdef ECL_LONG_FLOAT - ecl_make_long_float(INFINITY); -#else - ecl_make_double_float(INFINITY); -#endif + cl_object x = ecl_alloc_object(t_doublefloat); + ecl_double_float(x) = INFINITY; } #endif /* ECL_IEEE_FP */ From 7544863af1989168072aaa722305fe8ba153a9fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 18:02:53 +0200 Subject: [PATCH 74/92] cosmetic: typo --- src/h/impl/math_fenv.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/h/impl/math_fenv.h b/src/h/impl/math_fenv.h index e6d4d1e81..3a416ac31 100644 --- a/src/h/impl/math_fenv.h +++ b/src/h/impl/math_fenv.h @@ -30,7 +30,7 @@ * - Activate explicitely signaling of exceptions * - Insert explicit checks for exceptions * - * The first taks is achieved using feenableexcept() or an equivalent + * The first task is achieved using feenableexcept() or an equivalent * function. The second task is only needed on some platforms where * exceptions are activated by one floating point computation but are * only signaled with the _next_ floating point instruction (Read x86 From 06347ae9d57c0388ebb69a1684e4cb57a4cce6bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 18:03:01 +0200 Subject: [PATCH 75/92] internal.h: include math.h --- src/h/internal.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/h/internal.h b/src/h/internal.h index 568c29b9a..6bf8792c3 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -517,8 +517,9 @@ extern void ecl_interrupt_process(cl_object process, cl_object function); extern cl_object si_wait_for_all_processes _ECL_ARGS((cl_narg narg, ...)); /* - * Fake several ISO C99 mathematical functions + * Fake several ISO C99 mathematical functions if not available */ +#include #ifndef HAVE_EXPF # ifdef expf From 33699e142fcf6558493908edcf46bf622c1b3ca1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 18:27:18 +0200 Subject: [PATCH 76/92] numlib: trap-fpe on inf constant definitions --- src/lsp/numlib.lsp | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/lsp/numlib.lsp b/src/lsp/numlib.lsp index b96e20cf4..1bd7c9d84 100644 --- a/src/lsp/numlib.lsp +++ b/src/lsp/numlib.lsp @@ -74,15 +74,19 @@ )) #+ieee-floating-point -(let ((inf (si::infinity))) - (defconstant short-float-positive-infinity (coerce inf 'short-float)) - (defconstant short-float-negative-infinity (coerce (- inf) 'short-float)) - (defconstant single-float-positive-infinity (coerce inf 'single-float)) - (defconstant single-float-negative-infinity (coerce (- inf) 'single-float)) - (defconstant double-float-positive-infinity (coerce inf 'double-float)) - (defconstant double-float-negative-infinity (coerce (- inf) 'double-float)) - (defconstant long-float-positive-infinity (coerce inf 'long-float)) - (defconstant long-float-negative-infinity (coerce (- inf) 'long-float))) +(let ((bits (si:trap-fpe 'last nil))) + (unwind-protect + (locally (declare (notinline -)) + (let ((inf (si:infinity))) + (defconstant short-float-positive-infinity (coerce inf 'short-float)) + (defconstant short-float-negative-infinity (coerce (- inf) 'short-float)) + (defconstant single-float-positive-infinity (coerce inf 'single-float)) + (defconstant single-float-negative-infinity (coerce (- inf) 'single-float)) + (defconstant double-float-positive-infinity (coerce inf 'double-float)) + (defconstant double-float-negative-infinity (coerce (- inf) 'double-float)) + (defconstant long-float-positive-infinity (coerce inf 'long-float)) + (defconstant long-float-negative-infinity (coerce (- inf) 'long-float)))) + (si:trap-fpe bits t))) (defconstant imag-one #C(0.0 1.0)) From 517bc6a0140c799df26e0c013174be8e0e6fd251 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 21:07:48 +0200 Subject: [PATCH 77/92] configure: check for feenableexcept --- src/configure | 12 ++++++++++++ src/configure.ac | 2 +- src/ecl/configpre.h | 3 +++ 3 files changed, 16 insertions(+), 1 deletion(-) diff --git a/src/configure b/src/configure index 167d6c25f..f487d00bf 100755 --- a/src/configure +++ b/src/configure @@ -9273,6 +9273,18 @@ fi done +for ac_func in feenableexcept +do : + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` +ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + for ac_func in expf logf sqrtf cosf sinf tanf sinhf coshf tanhf \ floorf ceilf fabsf frexpf ldexpf log1p log1pf log1pl \ diff --git a/src/configure.ac b/src/configure.ac index deb6fc8f4..1e141c702 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -709,7 +709,7 @@ AC_CHECK_FUNCS( [nanosleep alarm times select setenv putenv] \ [lstat mkstemp sigprocmask isatty tzset] \ [gettimeofday getrusage] ) -dnl AC_CHECK_FUNCS( [ feenableexcept ] ) +AC_CHECK_FUNCS( [ feenableexcept ] ) AC_CHECK_FUNCS( [expf logf sqrtf cosf sinf tanf sinhf coshf tanhf] \ [floorf ceilf fabsf frexpf ldexpf log1p log1pf log1pl] \ diff --git a/src/ecl/configpre.h b/src/ecl/configpre.h index 6e42e2397..73cb606a3 100644 --- a/src/ecl/configpre.h +++ b/src/ecl/configpre.h @@ -129,6 +129,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H +/* Define to 1 if you have the `feenableexcept' function. */ +#undef HAVE_FEENABLEEXCEPT + /* Define to 1 if you have the header file. */ #undef HAVE_FENV_H From e640ef1c2b072ee1d23afcbf007d18269c2e6d9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Sep 2016 21:55:56 +0200 Subject: [PATCH 78/92] haiku: define ESOCKTNOSUPPORT to ENOTSUP Haiku lacks some parts of POSIX API. Workaround to make sockets work. --- contrib/sockets/sockets.lisp | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/contrib/sockets/sockets.lisp b/contrib/sockets/sockets.lisp index 6e680c008..7cf4f2cb5 100755 --- a/contrib/sockets/sockets.lisp +++ b/contrib/sockets/sockets.lisp @@ -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" From ee0152431cb5e12befc4ef42470ae39ff4321efb Mon Sep 17 00:00:00 2001 From: Elias Pipping Date: Tue, 6 Sep 2016 12:22:24 +0000 Subject: [PATCH 79/92] Implement ext:terminate-process --- CHANGELOG | 3 +++ src/c/symbols_list.h | 1 + src/c/symbols_list2.h | 1 + src/c/unixsys.d | 27 +++++++++++++++++++++++++++ src/cmp/proclamations.lsp | 1 + src/h/external.h | 2 +- 6 files changed, 34 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 14f309400..7e0bdb27a 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -39,6 +39,9 @@ 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 argument. + ** Enhancements - Initial port for the Haiku platform The port is done by Kacper Kasper's work, one of Haiku developers. diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 81e099a16..632a029c6 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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, ext_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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 8c90e3b1c..ebf2be93e 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -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","ext_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"}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index b875e56f0..3daf1b738 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -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)) @ { diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 671d1abb9..22531484e 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -1329,6 +1329,7 @@ (values (or null two-way-stream) (or null integer) ext:external-process)) +(proclamation ext:terminate-process (t &optional gen-bool) null) (proclamation ext:make-weak-pointer (t) ext:weak-pointer :no-side-effects) (proclamation ext:weak-pointer-value (ext:weak-pointer) t) diff --git a/src/h/external.h b/src/h/external.h index 285b06d36..79b8d827a 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1891,7 +1891,7 @@ extern ECL_API cl_object si_make_pipe(); extern ECL_API cl_object si_run_program _ECL_ARGS((cl_narg narg, cl_object command, cl_object args, ...)); extern ECL_API cl_object si_external_process_wait _ECL_ARGS((cl_narg narg, cl_object h, ...)); extern ECL_API cl_object si_close_windows_handle(cl_object h); - +extern ECL_API cl_object ext_terminate_process _ECL_ARGS((cl_narg narg, cl_object process, ...)); /* unicode -- no particular file, but we group these changes here */ From 8aa777416aa5703ca26310d240fc578aac92cb0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Sep 2016 08:13:43 +0200 Subject: [PATCH 80/92] tests: be asdf 2.* friendly Remove `:if-feature' in favour of #+/#- --- src/tests/ecl-tests.asd | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/tests/ecl-tests.asd b/src/tests/ecl-tests.asd index 1738fd1cd..d7fdb24b5 100644 --- a/src/tests/ecl-tests.asd +++ b/src/tests/ecl-tests.asd @@ -14,15 +14,21 @@ ((:file "ansi") (:file "mixed") (:file "compiler") - (:file "embedding" :if-feature (:not :ecl-bytecmp)) - (:file "foreign-interface" :if-feature :ffi) - (:file "metaobject-protocol" :if-feature :clos) - (:file "multiprocessing" :if-feature :threads))) + #-ecl-bytecmp + (:file "embedding") + #+ffi + (:file "foreign-interface") + #+clos + (:file "metaobject-protocol") + #+threads + (:file "multiprocessing"))) (:module features :default-component-class asdf:cl-source-file.lsp :components - ((:file "external-formats" :if-feature :unicode) - (:file "ieee-fp" :if-feature :ieee-floating-point))))) + (#+unicode + (:file "external-formats") + #+ieee-floating-point + (:file "ieee-fp"))))) (asdf:defsystem #:ecl-tests/stress :serial t @@ -31,7 +37,8 @@ (:module stress :default-component-class asdf:cl-source-file.lsp :components - ((:file "multiprocessing" :if-feature :threads))))) + (#+threads + (:file "multiprocessing"))))) ;;; General tests (asdf:defsystem #:ecl-tests/ansi) From 6ac9c2481a26ef3e4b98c82e12baa770bcc34c3b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Sep 2016 08:41:00 +0200 Subject: [PATCH 81/92] tests: haiku doesn't have /usr We could make it /dev though --- src/tests/regressions/compiler.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/regressions/compiler.lsp b/src/tests/regressions/compiler.lsp index 94cba22c4..2743f716a 100644 --- a/src/tests/regressions/compiler.lsp +++ b/src/tests/regressions/compiler.lsp @@ -302,7 +302,7 @@ ;;; (truename #p"/tmp/foo") signals an error because //usr is ;;; parsed as a hostname. ;;; -#-windows +#-(or windows haiku) (test cmp.0013.truename (si:system "rm -rf foo; ln -sf //usr/ foo") (is (equal (namestring (truename "./foo")) "/usr/")) From 0d3ef482cf57852cc2dea2376e7eee547fe9df6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Sep 2016 09:31:33 +0200 Subject: [PATCH 82/92] tests: add external process API suite --- src/tests/ecl-tests.asd | 3 ++- src/tests/ecl-tests.lisp | 4 +++- src/tests/features/external-process.lsp | 27 +++++++++++++++++++++++++ 3 files changed, 32 insertions(+), 2 deletions(-) create mode 100644 src/tests/features/external-process.lsp diff --git a/src/tests/ecl-tests.asd b/src/tests/ecl-tests.asd index 1738fd1cd..08b644427 100644 --- a/src/tests/ecl-tests.asd +++ b/src/tests/ecl-tests.asd @@ -22,7 +22,8 @@ :default-component-class asdf:cl-source-file.lsp :components ((:file "external-formats" :if-feature :unicode) - (:file "ieee-fp" :if-feature :ieee-floating-point))))) + (:file "ieee-fp" :if-feature :ieee-floating-point) + (:file "external-process"))))) (asdf:defsystem #:ecl-tests/stress :serial t diff --git a/src/tests/ecl-tests.lisp b/src/tests/ecl-tests.lisp index b5761d63b..46b78ce40 100644 --- a/src/tests/ecl-tests.lisp +++ b/src/tests/ecl-tests.lisp @@ -27,6 +27,7 @@ (suite 'make-check '(features/eformat features/ieee-fp + features/eprocess regressions/ansi+ regressions/mixed regressions/cmp @@ -47,7 +48,8 @@ (suite 'features '(features/eformat - features/ieee-fp)) + features/ieee-fp + features/eprocess)) ;;; Some syntactic sugar for 2am diff --git a/src/tests/features/external-process.lsp b/src/tests/features/external-process.lsp new file mode 100644 index 000000000..d65059ce6 --- /dev/null +++ b/src/tests/features/external-process.lsp @@ -0,0 +1,27 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Author: Daniel Kochmański +;;;; Created: 2016-09-07 +;;;; Contains: External process interaction API +;;;; + +(in-package :cl-test) + +(suite 'features/eprocess) + +(test external-process.0001.run-program/wait/terminate + (let ((p (nth-value 2 (ext:run-program #-windows "sleep" + #+windows "timeout" + (list "3") :wait nil)))) + (is (eql :running (ext:external-process-wait p nil)) + "process doesn't run") + (ext:terminate-process p) + (sleep 1) + (multiple-value-bind (status code) + (ext:external-process-wait p nil) + (is (eql :signaled status) + "status is ~s, should be ~s" status :signalled) + (is (eql ext:+sigterm+ code) + "signal code is ~s, should be ~s" code ext:+sigterm+)) + (finishes (ext:terminate-process p)))) From 3d1300f65a7133471a1b4686552d47fe4edb92c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Sep 2016 09:43:07 +0200 Subject: [PATCH 83/92] changelog: improve info --- CHANGELOG | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 7e0bdb27a..f8f21fd27 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -40,11 +40,13 @@ arity dependent on platform) is also possible. =(ext:random-state-array random-state)=. - ext:terminate-process: new extension for external processes. Usage: -=(ext:terminate-process process)= with a second, optional argument. +=(ext:terminate-process process)= with a second, optional boolean argument +whenever termination should be forced or not. ** Enhancements - Initial port for the Haiku platform -The port is done by Kacper Kasper's work, one of Haiku developers. +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 From b8b9571410685b3aee3e8316eee30896a0f7aba8 Mon Sep 17 00:00:00 2001 From: Elias Pipping Date: Wed, 7 Sep 2016 09:02:42 +0000 Subject: [PATCH 84/92] Fix declaration of terminate-process --- src/c/symbols_list.h | 2 +- src/c/symbols_list2.h | 2 +- src/h/external.h | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 632a029c6..eb81875b0 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1225,7 +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, ext_terminate_process, -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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index ebf2be93e..f59852bc7 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1225,7 +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","ext_terminate_process"}, +{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"}, diff --git a/src/h/external.h b/src/h/external.h index 79b8d827a..48403d332 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1891,7 +1891,7 @@ extern ECL_API cl_object si_make_pipe(); extern ECL_API cl_object si_run_program _ECL_ARGS((cl_narg narg, cl_object command, cl_object args, ...)); extern ECL_API cl_object si_external_process_wait _ECL_ARGS((cl_narg narg, cl_object h, ...)); extern ECL_API cl_object si_close_windows_handle(cl_object h); -extern ECL_API cl_object ext_terminate_process _ECL_ARGS((cl_narg narg, cl_object process, ...)); +extern ECL_API cl_object si_terminate_process _ECL_ARGS((cl_narg narg, cl_object process, ...)); /* unicode -- no particular file, but we group these changes here */ From 29ab40fde87597a4e34133eb11a29c74b12856dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Sep 2016 14:29:21 +0200 Subject: [PATCH 85/92] tests: bytecmp: be more bytecmp friendly --- .gitignore | 2 ++ src/tests/regressions/compiler.lsp | 30 ++++++++++++++------- src/tests/regressions/foreign-interface.lsp | 5 ++-- src/tests/universe.lisp | 7 +++-- 4 files changed, 28 insertions(+), 16 deletions(-) diff --git a/.gitignore b/.gitignore index 1c43702a1..124c5fa73 100644 --- a/.gitignore +++ b/.gitignore @@ -67,3 +67,5 @@ regressions/eformat-tests/*.txt /examples/ecl_qt/lisp-envi.a /examples/ecl_qt/qt/.qmake.stash /examples/ecl_qt/qt/Makefile +*fasc +*.orig diff --git a/src/tests/regressions/compiler.lsp b/src/tests/regressions/compiler.lsp index 2743f716a..42af71556 100644 --- a/src/tests/regressions/compiler.lsp +++ b/src/tests/regressions/compiler.lsp @@ -526,18 +526,25 @@ (ext:with-clean-symbols (foo) (test cmp.0025.paths (let* ((output (compile-file-pathname "tmp/aux" :type :fasl)) + #-ecl-bytecmp (h-file (compile-file-pathname output :type :h)) + #-ecl-bytecmp (c-file (compile-file-pathname output :type :c)) + #-ecl-bytecmp (data-file (compile-file-pathname output :type :data))) (is-true (and (zerop (si::system "rm -rf tmp; mkdir -p tmp")) - (with-compiler ("aux-compiler.0103-paths.lsp" :output-file output :c-file t - :h-file t :data-file t) + (with-compiler ("aux-compiler.0103-paths.lsp" + :output-file output + :c-file t :h-file t :data-file t) '(defun foo (x) (1+ x))) (probe-file output) + #-ecl-bytecmp (probe-file c-file) + #-ecl-bytecmp (probe-file h-file) + #-ecl-bytecmp (probe-file data-file) (zerop (si::system "rm -rf tmp; mkdir -p tmp")) (delete-file "aux-compiler.0103-paths.lsp")))))) @@ -955,7 +962,7 @@ ;;; of a mismatch between the position of the fields bytecodes.entry ;;; and cfun.entry ;;; -#-ecl-bytcmp +#-ecl-bytecmp (test cmp.0040.bytecodes-entry-position (let ((indices (funcall (compile nil '(lambda () @@ -1017,10 +1024,12 @@ *compiler.0122*)) (is-eql :bytecodes (compiler.0122a)) + #-ecl-bytecmp (is-eql :c/c++ (progn (compile 'compiler.0122a) (compiler.0122a) *compiler.0122*)) + #-ecl-bytecmp (is-eql :c/c++ (compiler.0122a)))) @@ -1099,15 +1108,16 @@ #+ieee-floating-point (ext:with-clean-symbols (infty-test) (test cmp.0047.infinity-test - (finishes (compile nil - (lambda () - (> 0.0 ext:single-float-negative-infinity)))) + (finishes + (compile nil + (lambda () + (> 0.0 ext:single-float-negative-infinity)))) (is-true - (progn - (with-compiler ("aux-compiler-0048.infty-test.2.lsp" :load t) - '(defun doit () (> 0.0 ext:single-float-negative-infinity))) + (let ((ofile + (with-compiler ("aux-compiler-0048.infty-test.2.lsp" :load t) + '(defun doit () (> 0.0 ext:single-float-negative-infinity))))) (delete-file "aux-compiler-0048.infty-test.2.lsp") - (delete-file "aux-compiler-0048.infty-test.2.fas") + (delete-file ofile) (doit))))) diff --git a/src/tests/regressions/foreign-interface.lsp b/src/tests/regressions/foreign-interface.lsp index 1351fede8..1f32679a7 100644 --- a/src/tests/regressions/foreign-interface.lsp +++ b/src/tests/regressions/foreign-interface.lsp @@ -22,7 +22,7 @@ ;;; ;;; Header should be included as ;;; - +#-ecl-bytecmp (test ffi.0001.callback (is (and (zerop (si::system "rm -rf tmp; mkdir tmp")) @@ -47,6 +47,7 @@ ;;; Description: ;;; Callback examples based on the C compiler ;;; +#-ecl-bytecmp (test ffi.0002.callback-sffi-example (is (and (zerop (si::system "rm -rf tmp; mkdir tmp")) @@ -75,7 +76,7 @@ int (*foo)(int) = #0; ;;; Callback examples based on the DFFI. Only work if this feature ;;; has been linked in. ;;; -#+dffi +#+(and dffi (not ecl-bytecmp)) (test ffi.0003.callback-dffi-example (is (and (zerop (si::system "rm -rf tmp; mkdir tmp")) diff --git a/src/tests/universe.lisp b/src/tests/universe.lisp index c66e297df..223c50d70 100644 --- a/src/tests/universe.lisp +++ b/src/tests/universe.lisp @@ -454,13 +454,12 @@ (list (+ x 1) (+ y 2) (+ z 3))) (defgeneric meaningless-user-generic-function-for-universe (x y z) - #+(or (not :gcl) :ansi-cl) (:method ((x integer) (y integer) (z integer)) (+ x y z))) + (:method ((x integer) (y integer) (z integer)) (+ x y z))) +#+ (or) (eval-when (:load-toplevel :execute) (compile 'meaningless-user-function-for-universe) - ;; Conditionalize to avoid a cmucl bug - #-(or cmu gcl ecl) (compile 'meaningless-user-generic-function-for-universe) - ) + (compile 'meaningless-user-generic-function-for-universe)) (defparameter *functions* (list #'cons #'car #'append #'values From 1398fd381a8a8ea92ddd84654bdd8772cf29e583 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Sep 2016 14:49:16 +0200 Subject: [PATCH 86/92] cleanup: purge clx --- LICENSE | 1 - Makefile.in | 2 +- doc/ansi_packages.xml | 15 +- doc/copyright.xmlf | 1 - doc/preface.xmlf | 1 - msvc/Makefile | 10 +- msvc/doc/Makefile | 27 +- msvc/ecl/config.h.msvc6 | 2 - src/Makefile.in | 6 +- src/clx/.cvsignore | 1 - src/clx/CHANGES | 55 - src/clx/NEWS | 164 - src/clx/README | 112 - src/clx/README-R5 | 52 - src/clx/attributes.lisp | 643 - src/clx/big-requests.lisp | 31 - src/clx/buffer.lisp | 1417 -- src/clx/bufmac.lisp | 184 - src/clx/build-clx.lisp | 33 - src/clx/clx-module.lisp | 5 - src/clx/clx.asd | 216 - src/clx/clx.lisp | 940 - src/clx/cmudep.lisp | 19 - src/clx/debug/debug.lisp | 77 - src/clx/debug/describe.lisp | 1243 -- src/clx/debug/event-test.lisp | 237 - src/clx/debug/keytrans.lisp | 266 - src/clx/debug/trace.lisp | 456 - src/clx/debug/util.lisp | 167 - src/clx/defsystem.lisp | 568 - src/clx/demo/.cvsignore | 1 - src/clx/demo/bezier.lisp | 39 - src/clx/demo/beziertest.lisp | 81 - src/clx/demo/clclock.lisp | 78 - src/clx/demo/clipboard.lisp | 200 - src/clx/demo/clx-demos.lisp | 1051 - src/clx/demo/gl-test.lisp | 477 - src/clx/demo/hello.lisp | 65 - src/clx/demo/mandel.lisp | 558 - src/clx/demo/menu.lisp | 382 - src/clx/demo/zoid.lisp | 58 - src/clx/dep-allegro.lisp | 2210 --- src/clx/dep-openmcl.lisp | 1123 -- src/clx/depdefs.lisp | 693 - src/clx/dependent.lisp | 4097 ---- src/clx/display.lisp | 680 - src/clx/dpms.lisp | 168 - src/clx/exclMakefile | 168 - src/clx/exclREADME | 56 - src/clx/exclcmac.lisp | 260 - src/clx/excldefsys.lisp | 186 - src/clx/excldep.c | 76 - src/clx/excldep.lisp | 435 - src/clx/fonts.lisp | 367 - src/clx/gcontext.lisp | 972 - src/clx/generalock.lisp | 72 - src/clx/gl.lisp | 3692 ---- src/clx/glx.lisp | 632 - src/clx/graphics.lisp | 447 - src/clx/image.lisp | 2668 --- src/clx/input.lisp | 1897 -- src/clx/keysyms.lisp | 433 - src/clx/macros.lisp | 1097 -- src/clx/manager.lisp | 795 - src/clx/manual/clx.texinfo | 18312 ------------------ src/clx/package.lisp | 397 - src/clx/provide.lisp | 56 - src/clx/requests.lisp | 1491 -- src/clx/resource.lisp | 700 - src/clx/screensaver.lisp | 69 - src/clx/shape.lisp | 192 - src/clx/sockcl.lisp | 163 - src/clx/socket.c | 156 - src/clx/test/.cvsignore | 1 - src/clx/test/image.lisp | 160 - src/clx/test/trapezoid.lisp | 72 - src/clx/text.lisp | 1084 -- src/clx/translate.lisp | 562 - src/clx/xinerama.lisp | 93 - src/clx/xrender.lisp | 1154 -- src/clx/xtest.lisp | 154 - src/clx/xvidmode.lisp | 730 - src/compile.lsp.in | 52 - src/configure | 38 - src/configure.ac | 19 - src/doc/Makefile.in | 12 +- src/doc/help.lsp | 2 +- src/doc/new-doc/introduction/copyrights.txi | 1 - src/h/config.h.in | 3 - src/util/ecl.spec | 5 +- src/util/search | 8 +- 91 files changed, 22 insertions(+), 58829 deletions(-) delete mode 100644 src/clx/.cvsignore delete mode 100644 src/clx/CHANGES delete mode 100644 src/clx/NEWS delete mode 100644 src/clx/README delete mode 100644 src/clx/README-R5 delete mode 100644 src/clx/attributes.lisp delete mode 100644 src/clx/big-requests.lisp delete mode 100644 src/clx/buffer.lisp delete mode 100644 src/clx/bufmac.lisp delete mode 100644 src/clx/build-clx.lisp delete mode 100644 src/clx/clx-module.lisp delete mode 100644 src/clx/clx.asd delete mode 100644 src/clx/clx.lisp delete mode 100644 src/clx/cmudep.lisp delete mode 100644 src/clx/debug/debug.lisp delete mode 100644 src/clx/debug/describe.lisp delete mode 100644 src/clx/debug/event-test.lisp delete mode 100644 src/clx/debug/keytrans.lisp delete mode 100644 src/clx/debug/trace.lisp delete mode 100644 src/clx/debug/util.lisp delete mode 100644 src/clx/defsystem.lisp delete mode 100644 src/clx/demo/.cvsignore delete mode 100644 src/clx/demo/bezier.lisp delete mode 100644 src/clx/demo/beziertest.lisp delete mode 100644 src/clx/demo/clclock.lisp delete mode 100644 src/clx/demo/clipboard.lisp delete mode 100644 src/clx/demo/clx-demos.lisp delete mode 100644 src/clx/demo/gl-test.lisp delete mode 100644 src/clx/demo/hello.lisp delete mode 100644 src/clx/demo/mandel.lisp delete mode 100644 src/clx/demo/menu.lisp delete mode 100644 src/clx/demo/zoid.lisp delete mode 100644 src/clx/dep-allegro.lisp delete mode 100644 src/clx/dep-openmcl.lisp delete mode 100644 src/clx/depdefs.lisp delete mode 100644 src/clx/dependent.lisp delete mode 100644 src/clx/display.lisp delete mode 100644 src/clx/dpms.lisp delete mode 100644 src/clx/exclMakefile delete mode 100644 src/clx/exclREADME delete mode 100644 src/clx/exclcmac.lisp delete mode 100644 src/clx/excldefsys.lisp delete mode 100644 src/clx/excldep.c delete mode 100644 src/clx/excldep.lisp delete mode 100644 src/clx/fonts.lisp delete mode 100644 src/clx/gcontext.lisp delete mode 100644 src/clx/generalock.lisp delete mode 100644 src/clx/gl.lisp delete mode 100644 src/clx/glx.lisp delete mode 100644 src/clx/graphics.lisp delete mode 100644 src/clx/image.lisp delete mode 100644 src/clx/input.lisp delete mode 100644 src/clx/keysyms.lisp delete mode 100644 src/clx/macros.lisp delete mode 100644 src/clx/manager.lisp delete mode 100644 src/clx/manual/clx.texinfo delete mode 100644 src/clx/package.lisp delete mode 100644 src/clx/provide.lisp delete mode 100644 src/clx/requests.lisp delete mode 100644 src/clx/resource.lisp delete mode 100644 src/clx/screensaver.lisp delete mode 100644 src/clx/shape.lisp delete mode 100644 src/clx/sockcl.lisp delete mode 100644 src/clx/socket.c delete mode 100644 src/clx/test/.cvsignore delete mode 100644 src/clx/test/image.lisp delete mode 100644 src/clx/test/trapezoid.lisp delete mode 100644 src/clx/text.lisp delete mode 100644 src/clx/translate.lisp delete mode 100644 src/clx/xinerama.lisp delete mode 100644 src/clx/xrender.lisp delete mode 100644 src/clx/xtest.lisp delete mode 100644 src/clx/xvidmode.lisp diff --git a/LICENSE b/LICENSE index 62eeb8eac..8334fc8ba 100644 --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Makefile.in b/Makefile.in index 700ae7da1..c217ec74c 100644 --- a/Makefile.in +++ b/Makefile.in @@ -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 ==================== diff --git a/doc/ansi_packages.xml b/doc/ansi_packages.xml index 537d9af14..f4eb01930 100644 --- a/doc/ansi_packages.xml +++ b/doc/ansi_packages.xml @@ -55,12 +55,6 @@ CMP The compiler - - XLIB - CLX - XLIB - CLX library for X-Windows - SB-BSD-SOCKETS @@ -86,12 +80,11 @@ In we list all packages available in &ECL;. The nicknames are aliases for a package. Thus, system:symbol may be written as - sys:symbol or si:symbol. The module field - explains which library provides what package. For instance, the + sys:symbol or si:symbol. The module + field explains which library provides what package. For instance, the ASDF is obtained when loading the - ASDF library with (require 'asdf); and the - XLIB package when configuring and loading the - CLX library. + ASDF library with (require + 'asdf). diff --git a/doc/copyright.xmlf b/doc/copyright.xmlf index a3e8c1e14..c0c0de522 100644 --- a/doc/copyright.xmlf +++ b/doc/copyright.xmlf @@ -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. diff --git a/doc/preface.xmlf b/doc/preface.xmlf index c2bc03bd8..f2c7466e7 100644 --- a/doc/preface.xmlf +++ b/doc/preface.xmlf @@ -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. diff --git a/msvc/Makefile b/msvc/Makefile index cc66c15ce..25f931d2e 100755 --- a/msvc/Makefile +++ b/msvc/Makefile @@ -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 diff --git a/msvc/doc/Makefile b/msvc/doc/Makefile index b64dcbfe9..f5af5ddcc 100644 --- a/msvc/doc/Makefile +++ b/msvc/doc/Makefile @@ -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 diff --git a/msvc/ecl/config.h.msvc6 b/msvc/ecl/config.h.msvc6 index cef0825ec..162f81832 100755 --- a/msvc/ecl/config.h.msvc6 +++ b/msvc/ecl/config.h.msvc6 @@ -249,8 +249,6 @@ typedef unsigned int uint32_t; * FEATURES LINKED IN: */ -/* CLX */ -#define CLX 1 /* Locatives */ /* #undef LOCATIVE */ /* Use old MIT LOOP macro system */ diff --git a/src/Makefile.in b/src/Makefile.in index f6249a940..d0398ce3c 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -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,10 +261,10 @@ 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." diff --git a/src/clx/.cvsignore b/src/clx/.cvsignore deleted file mode 100644 index be303db03..000000000 --- a/src/clx/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.fasl diff --git a/src/clx/CHANGES b/src/clx/CHANGES deleted file mode 100644 index f87ce9418..000000000 --- a/src/clx/CHANGES +++ /dev/null @@ -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. diff --git a/src/clx/NEWS b/src/clx/NEWS deleted file mode 100644 index 73b1ef003..000000000 --- a/src/clx/NEWS +++ /dev/null @@ -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. - diff --git a/src/clx/README b/src/clx/README deleted file mode 100644 index 7e7dbc0ab..000000000 --- a/src/clx/README +++ /dev/null @@ -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"))' -ASDFized version and ongoing by Daniel Barlow -and (mostly, these days) Christophe Rhodes diff --git a/src/clx/README-R5 b/src/clx/README-R5 deleted file mode 100644 index 6ae50e2bf..000000000 --- a/src/clx/README-R5 +++ /dev/null @@ -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. - diff --git a/src/clx/attributes.lisp b/src/clx/attributes.lisp deleted file mode 100644 index 07d6376ea..000000000 --- a/src/clx/attributes.lisp +++ /dev/null @@ -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)) diff --git a/src/clx/big-requests.lisp b/src/clx/big-requests.lisp deleted file mode 100644 index 4f369b598..000000000 --- a/src/clx/big-requests.lisp +++ /dev/null @@ -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))))) diff --git a/src/clx/buffer.lisp b/src/clx/buffer.lisp deleted file mode 100644 index 9a0214d5b..000000000 --- a/src/clx/buffer.lisp +++ /dev/null @@ -1,1417 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains 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. -;;; - -;; A few notes: -;; -;; 1. The BUFFER implements a two-way buffered byte / half-word -;; / word stream. Hooks are left for implementing this with a -;; shared memory buffer, or with effenciency hooks to the network -;; code. -;; -;; 2. The BUFFER object uses overlapping displaced arrays for -;; inserting and removing bytes half-words and words. -;; -;; 3. The BYTE component of these arrays is written to a STREAM -;; associated with the BUFFER. The stream has its own buffer. -;; This may be made more efficient by using the Zetalisp -;; :Send-Output-Buffer operation. -;; -;; 4. The BUFFER object is INCLUDED in the DISPLAY object. -;; This was done to reduce access time when sending requests, -;; while maintaing some code modularity. -;; Several buffer functions are duplicated (with-buffer, -;; buffer-force-output, close-buffer) to keep the naming -;; conventions consistent. -;; -;; 5. A nother layer of software is built on top of this for generating -;; both client and server interface routines, given a specification -;; of the protocol. (see the INTERFACE file) -;; -;; 6. Care is taken to leave the buffer pointer (buffer-bbuf) set to -;; a point after a complete request. This is to ensure that a partial -;; request won't be left after aborts (e.g. control-abort on a lispm). - -(in-package :xlib) - -(defconstant +requestsize+ 160) ;; Max request size (excluding variable length requests) - -;;; This is here instead of in bufmac so that with-display can be -;;; compiled without macros and bufmac being loaded. - -(defmacro with-buffer ((buffer &key timeout inline) - &body body &environment env) - ;; This macro is for use in a multi-process environment. It provides - ;; exclusive access to the local buffer object for request generation and - ;; reply processing. - `(macrolet ((with-buffer ((buffer &key timeout) &body body) - ;; Speedup hack for lexically nested with-buffers - `(progn - (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) - ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-buffer-body. () ,@body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.with-buffer-body.)) - (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) - buffer - '.buffer.))) - `(let (,@(unless (eq buf buffer) `((,buf ,buffer)))) - ,@(unless (eq buf buffer) `((declare (type buffer ,buf)))) - ,(declare-bufmac) - (when (buffer-dead ,buf) - (x-error 'closed-display :display ,buf)) - (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) - -(defun with-buffer-function (buffer timeout function) - (declare (type display buffer) - (type (or null number) timeout) - (type function function) - #+clx-ansi-common-lisp - (dynamic-extent function) - ;; FIXME: This is probably more a bug in SBCL (logged as - ;; bug #243) - (ignorable timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (with-buffer (buffer :timeout timeout :inline t) - (funcall function))) - -;;; The following are here instead of in bufmac so that event-case can -;;; be compiled without macros and bufmac being loaded. - -(defmacro read-card8 (byte-index) - `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int8 (byte-index) - `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card16 (byte-index) - #+clx-overlapping-arrays - `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int16 (byte-index) - #+clx-overlapping-arrays - `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card32 (byte-index) - #+clx-overlapping-arrays - `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int32 (byte-index) - #+clx-overlapping-arrays - `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card29 (byte-index) - #+clx-overlapping-arrays - `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro event-code (reply-buffer) - ;; The reply-buffer structure is used for events. - ;; The size slot is used for the event code. - `(reply-size ,reply-buffer)) - -(defmacro reading-event ((event &rest options) &body body) - (declare (arglist (buffer &key sizes) &body body)) - ;; BODY may contain calls to (READ32 &optional index) etc. - ;; These calls will read from the input buffer at byte - ;; offset INDEX. If INDEX is not supplied, then the next - ;; word, half-word or byte is returned. - `(with-buffer-input (,event ,@options) ,@body)) - -(defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index) - &body body) - (unless (listp sizes) (setq sizes (list sizes))) - ;; 160 is a special hack for client-message-events - (when (set-difference sizes '(0 8 16 32 160 256)) - (error "Illegal sizes in ~a" sizes)) - `(let ((%reply-buffer ,reply-buffer) - ,@(and display `((%buffer ,display)))) - (declare (type reply-buffer %reply-buffer) - ,@(and display '((type display %buffer)))) - ,(declare-bufmac) - ,@(and display '(%buffer)) - (let* ((buffer-boffset (the array-index ,(or index 0))) - #-clx-overlapping-arrays - (buffer-bbuf (reply-ibuf8 %reply-buffer)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) - (when (or (member 16 sizes) (member 160 sizes)) - `((buffer-woffset (index-ash buffer-boffset -1)) - (buffer-wbuf (reply-ibuf16 %reply-buffer)))) - (when (member 32 sizes) - `((buffer-loffset (index-ash buffer-boffset -2)) - (buffer-lbuf (reply-ibuf32 %reply-buffer)))))) - (declare (type array-index buffer-boffset)) - #-clx-overlapping-arrays - (declare (type buffer-bytes buffer-bbuf)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf))))) - buffer-boffset - #-clx-overlapping-arrays - buffer-bbuf - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) '(buffer-bbuf)) - (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) - (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) - #+clx-overlapping-arrays - (macrolet ((%buffer-sizes () ',sizes)) - ,@body) - #-clx-overlapping-arrays - ,@body))) - -(defun make-buffer (output-size constructor &rest options) - (declare (dynamic-extent options)) - ;; Output-Size is the output-buffer size in bytes. - (let ((byte-output (make-array output-size :element-type 'card8 - :initial-element 0))) - (apply constructor - :size output-size - :obuf8 byte-output - #+clx-overlapping-arrays - :obuf16 - #+clx-overlapping-arrays - (make-array (index-ash output-size -1) - :element-type 'overlap16 - :displaced-to byte-output) - #+clx-overlapping-arrays - :obuf32 - #+clx-overlapping-arrays - (make-array (index-ash output-size -2) - :element-type 'overlap32 - :displaced-to byte-output) - options))) - -(defun make-reply-buffer (size) - ;; Size is the buffer size in bytes - (let ((byte-input (make-array size :element-type 'card8 - :initial-element 0))) - (make-reply-buffer-internal - :size size - :ibuf8 byte-input - #+clx-overlapping-arrays - :ibuf16 - #+clx-overlapping-arrays - (make-array (index-ash size -1) - :element-type 'overlap16 - :displaced-to byte-input) - #+clx-overlapping-arrays - :ibuf32 - #+clx-overlapping-arrays - (make-array (index-ash size -2) - :element-type 'overlap32 - :displaced-to byte-input)))) - -(defun buffer-ensure-size (buffer size) - (declare (type buffer buffer) - (type array-index size)) - (when (index> size (buffer-size buffer)) - (with-buffer (buffer) - (buffer-flush buffer) - (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size)))) - (new-buffer (make-array new-buffer-size :element-type 'card8 - :initial-element 0))) - (setf (buffer-obuf8 buffer) new-buffer) - #+clx-overlapping-arrays - (setf (buffer-obuf16 buffer) - (make-array (index-ash new-buffer-size -1) - :element-type 'overlap16 - :displaced-to new-buffer) - (buffer-obuf32 buffer) - (make-array (index-ash new-buffer-size -2) - :element-type 'overlap32 - :displaced-to new-buffer)))))) - -(defun buffer-pad-request (buffer pad) - (declare (type buffer buffer) - (type array-index pad)) - (unless (index-zerop pad) - (when (index> (index+ (buffer-boffset buffer) pad) - (buffer-size buffer)) - (buffer-flush buffer)) - (incf (buffer-boffset buffer) pad) - (unless (index-zerop (index-mod (buffer-boffset buffer) 4)) - (buffer-flush buffer)))) - -(declaim (inline buffer-new-request-number)) - -(defun buffer-new-request-number (buffer) - (declare (type buffer buffer)) - (setf (buffer-request-number buffer) - (ldb (byte 16 0) (1+ (buffer-request-number buffer))))) - -(defun with-buffer-request-function (display gc-force request-function) - (declare (type display display) - (type (or null gcontext) gc-force)) - (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) - (with-buffer (display :inline t) - (multiple-value-prog1 - (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) - (display-invoke-after-function display)))) - -(defun with-buffer-request-function-nolock (display gc-force request-function) - (declare (type display display) - (type (or null gcontext) gc-force)) - (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) - (multiple-value-prog1 - (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) - (display-invoke-after-function display))) - -(defstruct (pending-command (:copier nil) (:predicate nil)) - (sequence 0 :type card16) - (reply-buffer nil :type (or null reply-buffer)) - (process nil) - (next nil #-explorer :type #-explorer (or null pending-command))) - -(defun with-buffer-request-and-reply-function - (display multiple-reply request-function reply-function) - (declare (type display display) - (type generalized-boolean multiple-reply)) - (declare (type function request-function reply-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function reply-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function reply-function)) - (let ((pending-command nil) - (reply-buffer nil)) - (declare (type (or null pending-command) pending-command) - (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (progn - (with-buffer (display :inline t) - (setq pending-command (start-pending-command display)) - (without-aborts (funcall request-function display)) - (buffer-force-output display) - (display-invoke-after-function display)) - (cond (multiple-reply - (loop - (setq reply-buffer (read-reply display pending-command)) - (when (funcall reply-function display reply-buffer) (return nil)) - (deallocate-reply-buffer (shiftf reply-buffer nil)))) - (t - (setq reply-buffer (read-reply display pending-command)) - (funcall reply-function display reply-buffer)))) - (when reply-buffer (deallocate-reply-buffer reply-buffer)) - (when pending-command (stop-pending-command display pending-command))))) - -;; -;; Buffer stream operations -;; - -(defun buffer-write (vector buffer start end) - ;; Write out VECTOR from START to END into BUFFER - ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER - (declare (type buffer buffer) - (type array-index start end)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (wrap-buf-output (buffer) - (funcall (buffer-write-function buffer) vector buffer start end)) - nil) - -(defun buffer-flush (buffer) - ;; Write the buffer contents to the server stream - doesn't force-output the stream - ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER - (declare (type buffer buffer)) - (unless (buffer-flush-inhibit buffer) - (let ((boffset (buffer-boffset buffer))) - (declare (type array-index boffset)) - (when (index-plusp boffset) - (buffer-write (buffer-obuf8 buffer) buffer 0 boffset) - (setf (buffer-boffset buffer) 0) - (setf (buffer-last-request buffer) nil)))) - nil) - -(defmacro with-buffer-flush-inhibited ((buffer) &body body) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) - `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer))) - (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf))) - (unwind-protect - (progn - (setf (buffer-flush-inhibit ,buf) t) - ,@body) - (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.))))) - -(defun buffer-force-output (buffer) - ;; Output is normally buffered, this forces any buffered output to the server. - (declare (type buffer buffer)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (buffer-flush buffer) - (wrap-buf-output (buffer) - (without-aborts - (funcall (buffer-force-output-function buffer) buffer))) - nil) - -(defun close-buffer (buffer &key abort) - ;; Close the host connection in BUFFER - (declare (type buffer buffer)) - (unless (null (buffer-output-stream buffer)) - (wrap-buf-output (buffer) - (funcall (buffer-close-function buffer) buffer :abort abort)) - (setf (buffer-dead buffer) t) - ;; Zap pointers to the streams, to ensure they're GC'd - (setf (buffer-output-stream buffer) nil) - (setf (buffer-input-stream buffer) nil) - ) - nil) - -(defun buffer-input (buffer vector start end &optional timeout) - ;; Read into VECTOR from the buffer stream - ;; Timeout, when non-nil, is in seconds - ;; Returns non-nil if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type buffer buffer) - (type vector vector) - (type array-index start end) - (type (or null number) timeout)) - (declare (clx-values eof-p)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (unless (= start end) - (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-function buffer) - buffer vector start end timeout)))) - (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) - result))) - -(defun buffer-input-wait (buffer timeout) - ;; Timeout, when non-nil, is in seconds - ;; Returns non-nil if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type buffer buffer) - (type (or null number) timeout)) - (declare (clx-values timeout)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-wait-function buffer) - buffer timeout)))) - (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) - result)) - -(defun buffer-listen (buffer) - ;; Returns T if there is input available for the buffer. This should never - ;; block, so it can be called from the scheduler. - (declare (type buffer buffer)) - (declare (clx-values input-available)) - (or (not (null (buffer-dead buffer))) - (wrap-buf-input (buffer) - (funcall (buffer-listen-function buffer) buffer)))) - -;;; Reading sequences of strings - -;;; a list of pascal-strings with card8 lengths, no padding in between -;;; can't use read-sequence-char -(defun read-sequence-string (buffer-bbuf length nitems result-type - &optional (buffer-boffset 0)) - (declare (type buffer-bytes buffer-bbuf) - (type array-index length nitems buffer-boffset)) - length - (with-vector (buffer-bbuf buffer-bytes) - (let ((result (make-sequence result-type nitems))) - (do* ((index 0 (index+ index 1 string-length)) - (count 0 (index1+ count)) - (string-length 0) - (string "")) - ((index>= count nitems) - result) - (declare (type array-index index count string-length) - (type string string)) - (setq string-length (read-card8 index) - string (make-sequence 'string string-length)) - (do ((i (index1+ index) (index1+ i)) - (j 0 (index1+ j))) - ((index>= j string-length) - (setf (elt result count) string)) - (declare (type array-index i j)) - (setf (aref string j) (card8->char (read-card8 i)))))))) - -;;; Reading sequences of chars - -(defmacro define-transformed-sequence-reader (name totype transformer reader) - (let ((ntrans (gensym))) - `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) - (declare - (type reply-buffer reply-buffer) - (type t result-type) - (type array-index nitems start index) - (type (or null sequence) data) - (type (or null (function (,totype) t)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (if transform - (flet ((,ntrans (v) (funcall transform (,transformer v)))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) - (,reader reply-buffer result-type nitems #',ntrans data start index)) - (,reader reply-buffer result-type nitems #',transformer data start index))))) - -(define-transformed-sequence-reader read-sequence-char character - card8->char read-sequence-card8) - -;;; Reading sequences of card8's - -(defmacro define-list-readers ((name tname) type size step reader) - `(progn - (defun ,name (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (,size) :index index) - (do* ((j nitems (index- j 1)) - (list (nthcdr start data) (cdr list)) - (index 0 (index+ index ,step))) - ((index-zerop j)) - (declare (type array-index index j) (type list list)) - (setf (car list) (,reader index))))) - (defun ,tname (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data) - (type (function (,type) t) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (with-buffer-input (reply-buffer :sizes (,size) :index index) - (do* ((j nitems (index- j 1)) - (list (nthcdr start data) (cdr list)) - (index 0 (index+ index ,step))) - ((index-zerop j)) - (declare (type array-index index j) (type list list)) - (setf (car list) (funcall transform (,reader index)))))))) - -(define-list-readers (read-list-card8 read-list-card8-with-transform) card8 - 8 1 read-card8) - -#-lispm -(defun read-simple-array-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) - (with-vector (data (simple-array card8 (*))) - (with-buffer-input (reply-buffer :sizes (8)) - (buffer-replace data buffer-bbuf start (index+ start nitems) index)))) - -#-lispm -(defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) - (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card8 (*))) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card8 (funcall transform (read-card8 index)))))))) - -(defun read-vector-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card8 index)))))) - -(defun read-vector-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card8) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card8 index))))))) - -(defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec)) - `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) - (declare - (type reply-buffer reply-buffer) - (type t result-type) - (type array-index nitems start index) - (type (or null sequence) data) - (type (or null (function (,type) t)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (,tlist reply-buffer nitems result transform start index) - (,list reply-buffer nitems result start index))) - #-lispm - ((simple-array ,type (*)) - (if transform - (,tsa reply-buffer nitems result transform start index) - (,sa reply-buffer nitems result start index))) - ;; FIXME: general sequences - (t - (if transform - (,tvec reply-buffer nitems result transform start index) - (,vec reply-buffer nitems result start index)))) - result))) - -(define-sequence-reader read-sequence-card8 card8 - (read-list-card8 read-list-card8-with-transform) - (read-simple-array-card8 read-simple-array-card8-with-transform) - (read-vector-card8 read-vector-card8-with-transform)) - -(define-transformed-sequence-reader read-sequence-int8 int8 - card8->int8 read-sequence-card8) - -;;; Reading sequences of card16's - -(define-list-readers (read-list-card16 read-list-card16-with-transform) card16 - 16 2 read-card16) - -#-lispm -(defun read-simple-array-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) - (with-vector (data (simple-array card16 (*))) - (with-buffer-input (reply-buffer :sizes (16) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (read-card16 index)))) - #+clx-overlapping-arrays - (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) - -#-lispm -(defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (funcall transform (read-card16 index)))))))) - -(defun read-vector-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (16) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card16 index))) - #+clx-overlapping-arrays - (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) - -(defun read-vector-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card16) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card16 index))))))) - -(define-sequence-reader read-sequence-card16 card16 - (read-list-card16 read-list-card16-with-transform) - (read-simple-array-card16 read-simple-array-card16-with-transform) - (read-vector-card16 read-vector-card16-with-transform)) - -(define-transformed-sequence-reader read-sequence-int16 int16 - card16->int16 read-sequence-card16) - -;;; Reading sequences of card32's - -(define-list-readers (read-list-card32 read-list-card32-with-transform) card32 - 32 4 read-card32) - -#-lispm -(defun read-simple-array-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) - (with-vector (data (simple-array card32 (*))) - (with-buffer-input (reply-buffer :sizes (32) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (read-card32 index)))) - #+clx-overlapping-arrays - (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) - -#-lispm -(defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) - (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card32 (*))) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (funcall transform (read-card32 index)))))))) - -(defun read-vector-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (32) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card32 index))) - #+clx-overlapping-arrays - (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) - -(defun read-vector-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card32) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card32 index))))))) - -(define-sequence-reader read-sequence-card32 card32 - (read-list-card32 read-list-card32-with-transform) - (read-simple-array-card32 read-simple-array-card32-with-transform) - (read-vector-card32 read-vector-card32-with-transform)) - -(define-transformed-sequence-reader read-sequence-int32 int32 - card32->int32 read-sequence-card32) - -;;; Writing sequences of chars - -(defmacro define-transformed-sequence-writer (name fromtype transformer writer) - (let ((ntrans (gensym))) - `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare - (type buffer buffer) - (type sequence data) - (type array-index boffset start end) - (type (or null (function (t) ,fromtype)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (if transform - (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) - (,writer buffer boffset data start end #',ntrans)) - (,writer buffer boffset data start end #',transformer))))) - -(define-transformed-sequence-writer write-sequence-char character - char->card8 write-sequence-card8) - -;;; Writing sequences of card8's - -(defmacro define-list-writers ((name tname) type step writer) - `(progn - (defun ,name (buffer boffset data start end) - (declare - (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks ,type - ((list (nthcdr start data))) - ((type list list)) - (do ((j 0 (index+ j ,step))) - ((index>= j chunk)) - (declare (type array-index j)) - (,writer j (pop list))))) - (defun ,tname (buffer boffset data start end transform) - (declare - (type buffer buffer) - (type list data) - (type array-index boffset start end) - (type (function (t) ,type) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (writing-buffer-chunks ,type - ((list (nthcdr start data))) - ((type list list)) - (do ((j 0 (index+ j ,step))) - ((index>= j chunk)) - (declare (type array-index j)) - (,writer j (funcall transform (pop list)))))))) - -;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8 -#+ti -(progn - (defun write-list-card8 (buffer boffset data start end) - (writing-buffer-chunks card8 - ((list (nthcdr start data))) - ((type list list)) - (dotimes (j chunk) - (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list))))) - (defun write-list-card8-with-transform (buffer boffset data start end transform) - (writing-buffer-chunks card8 - ((list (nthcdr start data))) - ((type list lst)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (pop lst))))))) - -#-ti -(define-list-writers (write-list-card8 write-list-card8-with-transform) card8 - 1 write-card8) - -;;; Should really write directly from data, instead of into the buffer first -#-lispm -(defun write-simple-array-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card8 (*))) - (writing-buffer-chunks card8 - ((index start (index+ index chunk))) - ((type array-index index)) - (buffer-replace buffer-bbuf data - buffer-boffset - (index+ buffer-boffset chunk) - index))) - nil) - -#-lispm -(defun write-simple-array-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card8 (*))) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (declare (type (function (t) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec)) - `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare - (type buffer buffer) - (type sequence data) - (type array-index boffset start end) - (type (or null (function (t) ,type)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (typecase data - (list - (if transform - (,tlist buffer boffset data start end transform) - (,list buffer boffset data start end))) - #-lispm - ((simple-array ,type (*)) - (if transform - (,tsa buffer boffset data start end transform) - (,sa buffer boffset data start end))) - (t ; FIXME: general sequences - (if transform - (,tvec buffer boffset data start end transform) - (,vec buffer boffset data start end)))))) - -(define-sequence-writer write-sequence-card8 card8 - (write-list-card8 write-list-card8-with-transform) - (write-simple-array-card8 write-simple-array-card8-with-transform) - (write-vector-card8 write-vector-card8-with-transform)) - -(define-transformed-sequence-writer write-sequence-int8 int8 - int8->card8 write-sequence-card8) - -;;; Writing sequences of card16's - -(define-list-writers (write-list-card16 write-list-card16-with-transform) card16 - 2 write-card16) - -#-lispm -(defun write-simple-array-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(define-sequence-writer write-sequence-card16 card16 - (write-list-card16 write-list-card16-with-transform) - (write-simple-array-card16 write-simple-array-card16-with-transform) - (write-vector-card16 write-vector-card16-with-transform)) - -;;; Writing sequences of int16's - -(define-list-writers (write-list-int16 write-list-int16-with-transform) int16 - 2 write-int16) - -#-lispm -(defun write-simple-array-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array int16 (*))) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (int16) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array int16 (*))) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(define-sequence-writer write-sequence-int16 int16 - (write-list-int16 write-list-int16-with-transform) - (write-simple-array-int16 write-simple-array-int16-with-transform) - (write-vector-int16 write-vector-int16-with-transform)) - -;;; Writing sequences of card32's - -(define-list-writers (write-list-card32 write-list-card32-with-transform) card32 - 4 write-card32) - -#-lispm -(defun write-simple-array-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card32 (*))) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card32 (*))) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(define-sequence-writer write-sequence-card32 card32 - (write-list-card32 write-list-card32-with-transform) - (write-simple-array-card32 write-simple-array-card32-with-transform) - (write-vector-card32 write-vector-card32-with-transform)) - -(define-transformed-sequence-writer write-sequence-int32 int32 - int32->card32 write-sequence-card32) - -(defun read-bitvector256 (buffer-bbuf boffset data) - (declare (type buffer-bytes buffer-bbuf) - (type array-index boffset) - (type (or null (simple-bit-vector 256)) data)) - (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0)))) - (declare (type (simple-bit-vector 256) result)) - (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) - (declare (type array-index i j)) - (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1)) - (k j (index+ k 1))) - ((zerop byte) - (when data ;; Clear uninitialized bits in data - (do ((end (index+ j 8))) - ((index= k end)) - (declare (type array-index end)) - (setf (aref result k) 0) - (index-incf k)))) - (declare (type array-index k) - (type card8 byte)) - (setf (aref result k) (the bit (logand byte 1))))) - result)) - -(defun write-bitvector256 (buffer boffset map) - (declare (type buffer buffer) - (type array-index boffset) - (type (simple-array bit (*)) map)) - (with-buffer-output (buffer :index boffset :sizes 8) - (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) - (declare (type array-index i j)) - (do ((byte 0) - (bit (index+ j 7) (index- bit 1))) - ((index< bit j) - (aset-card8 byte buffer-bbuf i)) - (declare (type array-index bit) - (type card8 byte)) - (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit)))))))) - -;;; Writing sequences of char2b's - -(define-list-writers (write-list-char2b write-list-char2b-with-transform) card16 - 2 write-char2b) - -#-lispm -(defun write-simple-array-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) - nil) - -#-lispm -(defun write-simple-array-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(define-sequence-writer write-sequence-char2b card16 - (write-list-char2b write-list-char2b-with-transform) - (write-simple-array-char2b write-simple-array-char2b-with-transform) - (write-vector-char2b write-vector-char2b-with-transform)) diff --git a/src/clx/bufmac.lisp b/src/clx/bufmac.lisp deleted file mode 100644 index 9bc1f8bdd..000000000 --- a/src/clx/bufmac.lisp +++ /dev/null @@ -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))))) diff --git a/src/clx/build-clx.lisp b/src/clx/build-clx.lisp deleted file mode 100644 index 5f4b0a32b..000000000 --- a/src/clx/build-clx.lisp +++ /dev/null @@ -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:"))) diff --git a/src/clx/clx-module.lisp b/src/clx/clx-module.lisp deleted file mode 100644 index e72651fc8..000000000 --- a/src/clx/clx-module.lisp +++ /dev/null @@ -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:")) \ No newline at end of file diff --git a/src/clx/clx.asd b/src/clx/clx.asd deleted file mode 100644 index a1ad6fbef..000000000 --- a/src/clx/clx.asd +++ /dev/null @@ -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))) diff --git a/src/clx/clx.lisp b/src/clx/clx.lisp deleted file mode 100644 index 400601e84..000000000 --- a/src/clx/clx.lisp +++ /dev/null @@ -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- (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 ))) - -;(defun -display () -; (declare (type ) -; (clx-values display))) - -;(defun -id () -; (declare (type ) -; (clx-values integer))) - -;(defun -equal (-1 -2) -; (declare (type -1 -2))) - -;(defun -p (-1 -2) -; (declare (type -1 -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 ( :type ) of font-info, -; there is a corresponding function: - -;(defun font- (font) -; (declare (type font font) -; (clx-values ))) - -(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))) diff --git a/src/clx/cmudep.lisp b/src/clx/cmudep.lisp deleted file mode 100644 index 572fdaa55..000000000 --- a/src/clx/cmudep.lisp +++ /dev/null @@ -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)) diff --git a/src/clx/debug/debug.lisp b/src/clx/debug/debug.lisp deleted file mode 100644 index 35e94d19f..000000000 --- a/src/clx/debug/debug.lisp +++ /dev/null @@ -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 diff --git a/src/clx/debug/describe.lisp b/src/clx/debug/describe.lisp deleted file mode 100644 index 1f29bfe9e..000000000 --- a/src/clx/debug/describe.lisp +++ /dev/null @@ -1,1243 +0,0 @@ -;;; -*- Mode: Lisp; Package: XLIB; Syntax: COMMON-LISP; Base: 10; Lowercase: Yes; -*- - -;;; Describe X11 protocol requests - -;;; -;;; 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 07/15/87 by LaMott G. OREN - -(in-package :xlib) - -(defparameter *request-parameters* (make-array (length *request-names*))) - -(defmacro x-request (name &rest fields) - (unless (zerop (mod (length fields) 3)) - (format t "~%Field length not a multiple of 3 for ~a" name)) - (let ((request (position name *request-names* :test #'string-equal))) - (if request - `(setf (aref *request-parameters* ,request) ',fields) - `(format t "~%~s isn't an X11 request name" ',name)))) - -(defun print-history-description (buffer &optional (start 0)) - ;; Display an output history - (reading-event (buffer) - (let ((request (card8-get start)) - (length (* 4 (card16-get (+ start 2)))) - (margin 5)) - (format t "~a (~d) length ~d" - (request-name request) request length) - (when (>= request (length *request-parameters*)) - (setq request 0)) - (do ((parms (aref *request-parameters* request) (cdddr parms)) - (j start)) - ((or (endp parms) (>= j length))) - (let ((len (first parms)) - (type (second parms)) - (doc (third parms)) - value) - (setq value (case len - (1 (card8-get j)) - (2 (card16-get j)) - (4 (card32-get j)))) - (format t "~%~v@t" margin) - (if value - (progn - (print-value j value type doc) - (incf j len)) - (progn - (format t "~2d ~10a ~a" - j type doc) - (case type - ((listofvalue listofcard32 listofatom) - (format t " Words:~%~v@t" margin) - (dotimes (k (floor (- length (- j start)) 4)) - (format t " ~d" (card32-get j)) - (incf j 4))) - (listofrectangle - (format t " Half-Words:~%~v@t" margin) - (dotimes (k (floor (- length (- j start)) 2)) - (format t " ~d" (card16-get j)) - (incf j 2))) - (x (when (integerp len) (incf j len))) ; Unused - (string8 - (format t " Bytes:~%~v@t" margin) - (dotimes (k (- length (- j start))) - (format t "~a" (int-char (card8-get j))) - (incf j))) - (otherwise - (format t " Bytes:~%~v@t" margin) - (dotimes (k (- length (- j start))) - (format t " ~d" (card8-get j)) - (incf j))))))))))) - -(defun print-value (i value type doc &aux temp) - (format t "~2d ~3d " i value) - (if (consp type) - (case (first type) - (bitmask (format t "~a" (nreverse (decode-mask (symbol-value (second type)) value))) - (setq type (car type))) - (member (if (null (setq temp (nth value (cdr type)))) - (format t "*****ERROR*****") - (format t "~a" temp)) - (setq type (car type)))) - (case type - ((window pixmap drawable cursor font gcontext colormap atom) - (format t "[#x~x]" value) - #+comment - (let ((temp (lookup-resource-id display value))) - (when (eq (first type) 'atom) - (setq temp (lookup-xatom display value))) - (when temp (format t " (~s)" (type-of temp))))) - (int16 (setq temp (card16->int16 value)) - (when (minusp temp) (format t "~d" temp))) - (otherwise - (when (and (numberp type) (not (= type value))) - (format t "*****ERROR*****"))))) - (format t "~30,10t ~10a ~a" type doc)) - -(x-request Error - 1 1 opcode - 1 CARD8 data - 2 8+n request-length - n LISTofBYTE data - ) - -(x-request CreateWindow - 1 1 opcode - 1 CARD8 depth - 2 8+n request-length - 4 WINDOW wid - 4 WINDOW parent - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height - 2 CARD16 border-width - 2 (MEMBER CopyFromParent InputOutput InputOnly) class - 4 (OR (MEMBER CopyFromParent) VISUALID) visual - 4 (BITMASK *create-bitmask*) value-mask - 4n LISTofVALUE value-list - ) - -(defparameter *create-bitmask* - #(background-pixmap background-pixel border-pixmap border-pixel bit-gravity - win-gravity backing-store backing-planes backing-pixel override-redirect - save-under event-mask do-not-propagate-mask colormap cursor)) - -(x-request ChangeWindowAttributes - 1 2 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 4 (BITMASK *create-bitmask*) value-mask - 4n LISTofVALUE value-list - ) - -(x-request GetWindowAttributes - 1 3 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request DestroyWindow - 1 4 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request DestroySubwindows - 1 5 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request ChangeSaveSet - 1 6 opcode - 1 (MEMBER insert delete) mode - 2 2 request-length - 4 WINDOW window -) - -(x-request ReparentWindow - 1 7 opcode - 1 x unused - 2 4 request-length - 4 WINDOW window - 4 WINDOW parent - 2 INT16 x - 2 INT16 y -) - -(x-request MapWindow - 1 8 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request MapSubwindows - 1 9 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request UnmapWindow - 1 10 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request UnmapSubwindows - 1 11 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request ConfigureWindow - 1 12 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 2 BITMASK value-mask - 2 x unused - 4n LISTofVALUE value-list -) - -(x-request CirculateWindow - 1 13 opcode - 1 (MEMBER RaiseLowest LowerHighest) direction - 2 2 request-length - 4 WINDOW window -) - -(x-request GetGeometry - 1 14 opcode - 1 x unused - 2 2 request-length - 4 DRAWABLE drawable -) - -(x-request QueryTree - 1 15 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request InternAtom - 1 16 opcode - 1 BOOL only-if-exists - 2 |2+(n+p)/4| request-length - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request GetAtomName - 1 17 opcode - 1 x unused - 2 2 request-length - 4 ATOM atom -) - -(x-request ChangeProperty - 1 18 opcode - 1 (MEMBER replace prepend append) mode - 2 |6+(n+p)/4| request-length - 4 WINDOW window - 4 ATOM property - 4 ATOM type - 1 CARD8 format - 3 x unused - 4 CARD32 length-of-data-in-format-units - n LISTofBYTE data - p x unused -) - -(x-request DeleteProperty - 1 19 opcode - 1 x unused - 2 3 request-length - 4 WINDOW window - 4 ATOM property -) - -(x-request GetProperty - 1 20 opcode - 1 BOOL delete - 2 6 request-length - 4 WINDOW window - 4 ATOM property - 4 (OR (MEMBER anypropertytype) ATOM) type - 4 CARD32 long-offset - 4 CARD32 long-length -) - -(x-request ListProperties - 1 21 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request SetSelectionOwner - 1 22 opcode - 1 x unused - 2 4 request-length - 4 (OR (MEMBER none) WINDOW) owner - 4 ATOM selection - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GetSelectionOwner - 1 23 opcode - 1 x unused - 2 2 request-length - 4 ATOM selection -) - -(x-request ConvertSelection - 1 24 opcode - 1 x unused - 2 6 request-length - 4 WINDOW requestor - 4 ATOM selection - 4 ATOM target - 4 (OR (MEMBER none) ATOM) property - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request SendEvent - 1 25 opcode - 1 BOOL propagate - 2 11 request-length - 4 (OR (MEMBER pointerwindow inputfocus) WINDOW) destination - 4 SETofEVENT event-mask - 32 n event -) - -(x-request GrabPointer - 1 26 opcode - 1 BOOL owner-events - 2 6 request-length - 4 WINDOW grab-window - 2 SETofPOINTEREVENT event-mask - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 4 (OR (MEMBER none) WINDOW) confine-to - 4 (OR (MEMBER none) CURSOR) cursor - 4 (OR (MEMBER currenttime) TIMESTAMP) timestamp -) - -(x-request UngrabPointer - 1 27 opcode - 1 x unused - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabButton - 1 28 opcode - 1 BOOL owner-events - 2 6 request-length - 4 WINDOW grab-window - 2 SETofPOINTEREVENT event-mask - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 4 (OR (MEMBER none) WINDOW) confine-to - 4 (OR (MEMBER none) CURSOR) cursor - 1 (OR (MEMBER anybutton) BUTTON)button - 1 x unused - 2 SETofKEYMASK modifiers -) - -(x-request UngrabButton - 1 29 opcode - 1 (OR (MEMBER anybutton) BUTTON) button - 2 3 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 2 x unused -) - -(x-request ChangeActivePointerGrab - 1 30 opcode - 1 x unused - 2 4 request-length - 4 (OR (MEMBER none) CURSOR) cursor - 4 (OR (MEMBER currenttime) TIMESTAMP) time - 2 SETofPOINTEREVENT event-mask - 2 x unused -) - -(x-request GrabKeyboard - 1 31 opcode - 1 BOOL owner-events - 2 4 request-length - 4 WINDOW grab-window - 4 (OR (MEMBER currenttime) TIMESTAMP) time - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 2 x unused -) - -(x-request UngrabKeyboard - 1 32 opcode - 1 x unused - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabKey - 1 33 opcode - 1 BOOL owner-events - 2 4 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 1 (OR (MEMBER anykey) KEYCODE) key - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 3 x unused -) - -(x-request UngrabKey - 1 34 opcode - 1 (OR (MEMBER anykey) KEYCODE) key - 2 3 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 2 x unused -) - -(x-request AllowEvents - 1 35 opcode - 1 (MEMBER AsyncPointer SyncPointer ReplayPointer AsyncKeyboard SyncKeyboard ReplayKeyboard) mode - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabServer - 1 36 opcode - 1 x unused - 2 1 request-length -) - -(x-request UngrabServer - 1 37 opcode - 1 x unused - 2 1 request-length -) - -(x-request QueryPointer - 1 38 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request GetMotionEvents - 1 39 opcode - 1 x unused - 2 4 request-length - 4 WINDOW window - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) start - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) stop -) - -(x-request TranslateCoords - 1 40 opcode - 1 x unused - 2 4 request-length - 4 WINDOW src-window - 4 WINDOW dst-window - 2 INT16 src-x - 2 INT16 src-y -) - -(x-request WarpPointer - 1 41 opcode - 1 x unused - 2 6 request-length - 4 (OR (MEMBER none) WINDOW) src-window - 4 WINDOW dst-window - 2 INT16 src-x - 2 INT16 src-y - 2 CARD16 src-width - 2 CARD16 src-height - 2 INT16 dst-x - 2 INT16 dst-y -) - -(x-request SetInputFocus - 1 42 opcode - 1 (MEMBER none pointerroot parent) revert-to - 2 3 request-length - 4 (OR (MEMBER none pointerroot) WINDOW) focus - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) time -) - -(x-request GetInputFocus - 1 43 opcode - 1 x unused - 2 1 request-length -) - -(x-request QueryKeymap - 1 44 opcode - 1 x unused - 2 1 request-length -) - -(x-request OpenFont - 1 45 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 FONT fid - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request CloseFont - 1 46 opcode - 1 x unused - 2 2 request-length - 4 FONT font -) - -(x-request QueryFont - 1 47 opcode - 1 x unused - 2 2 request-length - 4 FONTABLE font -) - -(x-request QueryTextExtents - 1 48 opcode - 1 BOOL odd-length-p - 2 |2+(2n+p)/4| request-length - 4 FONTABLE font - 2n STRING16 string - p x unused -) - -(x-request ListFonts - 1 49 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 max-names - 2 n length-of-pattern - n STRING8 pattern - p x unused -) - -(x-request ListFontsWithInfo - 1 50 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 max-names - 2 n length-of-pattern - n STRING8 pattern - p x unused -) - -(x-request SetFontPath - 1 51 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 number-of-STRs-in-path - 2 x unused - n LISTofSTR path - p x unused -) - -(x-request GetFontPath - 1 52 opcode - 1 x unused - 2 1 request-list -) - -(x-request CreatePixmap - 1 53 opcode - 1 CARD8 depth - 2 4 request-length - 4 PIXMAP pid - 4 DRAWABLE drawable - 2 CARD16 width - 2 CARD16 height -) - -(x-request FreePixmap - 1 54 opcode - 1 x unused - 2 2 request-length - 4 PIXMAP pixmap -) - -(x-request CreateGC - 1 55 opcode - 1 x unused - 2 4+n request-length - 4 GCONTEXT cid - 4 DRAWABLE drawable - 4 (BITMASK *gc-bitmask*) value-mask - 4n LISTofVALUE value-list -) - -(defconstant *gc-bitmask* - #(function plane-mask foreground - background line-width line-style cap-style join-style - fill-style fill-rule tile stipple tile-stipple-x-origin - tile-stipple-y-origin font subwindow-mode graphics-exposures clip-x-origin - clip-y-origin clip-mask dash-offset dashes arc-mode)) - - -(x-request ChangeGC - 1 56 opcode - 1 x unused - 2 3+n request-length - 4 GCONTEXT gc - 4 (BITMASK *gc-bitmask*) value-mask - 4n LISTofVALUE value-list -) - -(x-request CopyGC - 1 57 opcode - 1 x unused - 2 4 request-length - 4 GCONTEXT src-gc - 4 GCONTEXT dst-gc - 4 (BITMASK *gc-bitmask*) value-mask -) - -(x-request SetDashes - 1 58 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 GCONTEXT gc - 2 CARD16 dash-offset - 2 n length-of-dashes - n LISTofCARD8 dashes - p x unused -) - -(x-request SetClipRectangles - 1 59 opcode - 1 (MEMBER UnSorted YSorted YXSorted YXBanded) ordering - 2 3+2n request-length - 4 GCONTEXT gc - 2 INT16 clip-x-origin - 2 INT16 clip-y-origin - 8n LISTofRECTANGLE rectangles -) - -(x-request FreeGC - 1 60 opcode - 1 x unused - 2 2 request-length - 4 GCONTEXT gc -) - -(x-request ClearToBackground - 1 61 opcode - 1 BOOL exposures - 2 4 request-length - 4 WINDOW window - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height -) - -(x-request CopyArea - 1 62 opcode - 1 x unused - 2 7 request-length - 4 DRAWABLE src-drawable - 4 DRAWABLE dst-drawable - 4 GCONTEXT gc - 2 INT16 src-x - 2 INT16 src-y - 2 INT16 dst-x - 2 INT16 dst-y - 2 CARD16 width - 2 CARD16 height -) - -(x-request CopyPlane - 1 63 opcode - 1 x unused - 2 8 request-length - 4 DRAWABLE src-drawable - 4 DRAWABLE dst-drawable - 4 GCONTEXT gc - 2 INT16 src-x - 2 INT16 src-y - 2 INT16 dst-x - 2 INT16 dst-y - 2 CARD16 width - 2 CARD16 height - 4 CARD32 bit-plane -) - -(x-request PolyPoint - 1 64 opcode - 1 (MEMBER origin previous) coordinate-mode - 2 3+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 4n LISTofPOINT points -) - -(x-request PolyLine - 1 65 opcode - 1 (MEMBER origin previous) coordinate-mode - 2 3+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 4n LISTofPOINT points -) - -(x-request PolySegment - 1 66 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofSEGMENT segments -) - -(x-request PolyRectangle - 1 67 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofRECTANGLE rectangles -) - -(x-request PolyArc - 1 68 opcode - 1 x unused - 2 3+3n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 12n LISTofARC arcs -) - -(x-request FillPoly - 1 69 opcode - 1 x unused - 2 4+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 1 (MEMBER complex nonconvex convex) shape - 1 (MEMBER origin previous) coordinate-mode - 2 x unused - 4n LISTofPOINT points -) - -(x-request PolyFillRectangle - 1 70 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofRECTANGLE rectangles -) - -(x-request PolyFillArc - 1 71 opcode - 1 x unused - 2 3+3n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 12n LISTofARC arcs -) - -(x-request PutImage - 1 72 opcode - 1 (bitmap xypixmap zpixmap) format - 2 |6+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 CARD16 width - 2 CARD16 height - 2 INT16 dst-x - 2 INT16 dst-y - 1 CARD8 left-pad - 1 CARD8 depth - 2 x unused - n LISTofBYTE data - p x unused -) - -(x-request GetImage - 1 73 opcode - 1 (MEMBER error xypixmap zpixmap) format - 2 5 request-length - 4 DRAWABLE drawable - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height - 4 CARD32 plane-mask -) - -(x-request PolyText8 - 1 74 opcode - 1 x unused - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n LISTofTEXTITEM8 items - p x unused -) - -(x-request PolyText16 - 1 75 opcode - 1 x unused - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n LISTofTEXTITEM16 items - p x unused -) - -(x-request ImageText8 - 1 76 opcode - 1 n length-of-string - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n STRING8 string - p x unused -) - -(x-request ImageText16 - 1 77 opcode - 1 n number-of-CHAR2Bs-in-string - 2 |4+(2n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - 2n STRING16 string - p x unused -) - -(x-request CreateColormap - 1 78 opcode - 1 (MEMBER none all) alloc - 2 4 request-length - 4 COLORMAP mid - 4 WINDOW window - 4 VISUALID visual -) - -(x-request FreeColormap - 1 79 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request CopyColormapAndFree - 1 80 opcode - 1 x unused - 2 3 request-length - 4 COLORMAP mid - 4 COLORMAP src-cmap -) - -(x-request InstallColormap - 1 81 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request UninstallColormap - 1 82 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request ListInstalledColormaps - 1 83 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request AllocColor - 1 84 opcode - 1 x unused - 2 4 request-length - 4 COLORMAP cmap - 2 CARD16 red - 2 CARD16 green - 2 CARD16 blue - 2 x unused -) - -(x-request AllocNamedColor - 1 85 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 COLORMAP cmap - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request AllocColorCells - 1 86 opcode - 1 BOOL contiguous - 2 3 request-length - 4 COLORMAP cmap - 2 CARD16 colors - 2 CARD16 planes -) - -(x-request AllocColorPlanes - 1 87 opcode - 1 BOOL contiguous - 2 4 request-length - 4 COLORMAP cmap - 2 CARD16 colors - 2 CARD16 reds - 2 CARD16 greens - 2 CARD16 blues -) - -(x-request FreeColors - 1 88 opcode - 1 x unused - 2 3+n request-length - 4 COLORMAP cmap - 4 CARD32 plane-mask - 4n LISTofCARD32 pixels -) - -(x-request StoreColors - 1 89 opcode - 1 x unused - 2 2+3n request-length - 4 COLORMAP cmap - 12n LISTofCOLORITEM items -) - -(x-request StoreNamedColor - 1 90 opcode - 1 color-mask do-red_do-green_do-blue - 2 |4+(n+p)/4| request-length - 4 COLORMAP cmap - 4 CARD32 pixel - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request QueryColors - 1 91 opcode - 1 x unused - 2 2+n request-length - 4 COLORMAP cmap - 4n LISTofCARD32 pixels -) - -(x-request LookupColor - 1 92 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 COLORMAP cmap - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request CreateCursor - 1 93 opcode - 1 x unused - 2 8 request-length - 4 CURSOR cid - 4 PIXMAP source - 4 (OR (MEMBER none) PIXMAP) mask - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue - 2 CARD16 x - 2 CARD16 y -) - -(x-request CreateGlyphCursor - 1 94 CreateGlyphCursor - 1 x unused - 2 8 request-length - 4 CURSOR cid - 4 FONT source-font - 4 (OR (MEMBER none) FONT) mask-font - 2 CARD16 source-char - 2 CARD16 mask-char - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue -) - -(x-request FreeCursor - 1 95 opcode - 1 x unused - 2 2 request-length - 4 CURSOR cursor -) - -(x-request RecolorCursor - 1 96 opcode - 1 x unused - 2 5 request-length - 4 CURSOR cursor - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue -) - -(x-request QueryBestSize - 1 97 opcode - 1 (MEMBER cursor tile stipple) class - 2 3 request-length - 4 DRAWABLE drawable - 2 CARD16 width - 2 CARD16 height -) - -(x-request QueryExtension - 1 98 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request ListExtensions - 1 99 opcode - 1 x unused - 2 1 request-length -) - -(x-request SetKeyboardMapping - 1 100 opcode - 1 n keycode-count - 2 2+nm request-length - 1 KEYCODE first-keycode - 1 m keysyms-per-keycode - 2 x unused - 4nm LISTofKEYSYM keysyms -) - -(x-request GetKeyboardMapping - 1 101 opcode - 1 x unused - 2 2 request-length - 1 KEYCODE first-keycode - 1 CARD8 count - 2 x unused -) - -(x-request ChangeKeyboardControl - 1 102 opcode - 1 x unused - 2 2+n request-length - 4 BITMASK value-mask - 4n LISTofVALUE value-list -) - -(x-request GetKeyboardControl - 1 103 opcode - 1 x unused - 2 1 request-length -) - -(x-request Bell - 1 104 opcode - 1 INT8 percent - 2 1 request-length -) - -(x-request ChangePointerControl - 1 105 opcode - 1 x unused - 2 3 request-length - 2 INT16 acceleration-numerator - 2 INT16 acceleration-denominator - 2 INT16 threshold - 1 BOOL do-acceleration - 1 BOOL do-threshold -) - -(x-request GetPointerControl - 1 106 GetPointerControl - 1 x unused - 2 1 request-length -) - -(x-request SetScreenSaver - 1 107 opcode - 1 x unused - 2 3 request-length - 2 INT16 timeout - 2 INT16 interval - 1 (MEMBER no yes default) prefer-blanking - 1 (MEMBER no yes default) allow-exposures - 2 x unused -) - -(x-request GetScreenSaver - 1 108 opcode - 1 x unused - 2 1 request-length -) - -(x-request ChangeHosts - 1 109 opcode - 1 (MEMBER insert delete) mode - 2 |2+(n+p)/4| request-length - 1 (MEMBER internet decnet chaos) family - 1 x unused - 2 CARD16 length-of-address - n LISTofCARD8 address - p x unused -) - -(x-request ListHosts - 1 110 opcode - 1 x unused - 2 1 request-length -) - -(x-request ChangeAccessControl - 1 111 opcode - 1 (MEMBER disable enable) mode - 2 1 request-length -) - -(x-request ChangeCloseDownMode - 1 112 opcode - 1 (MEMBER destroy retainpermanent retaintemporary) mode - 2 1 request-length -) - -(x-request KillClient - 1 113 opcode - 1 x unused - 2 2 request-length - 4 (MEMBER alltemporary CARD32) resource -) - -(x-request RotateProperties - 1 114 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 2 n number-of-properties - 2 INT16 delta - 4n LISTofATOM properties -) - -(x-request ForceScreenSaver - 1 115 ForceScreenSaver - 1 (MEMBER reset activate) mode - 2 1 request-length -) - -(x-request SetPointerMapping - 1 116 opcode - 1 n length-of-map - 2 |1+(n+p)/4| request-length - n LISTofCARD8 map - p x unused -) - -(x-request GetPointerMapping - 1 117 opcode - 1 x unused - 2 1 request-length -) - -(x-request SetModifierMapping - 1 118 opcode - 1 KEYCODE Lock - 2 5 request-length - 1 KEYCODE Shift_A - 1 KEYCODE Shift_B - 1 KEYCODE Control_A - 1 KEYCODE Control_B - 1 KEYCODE Mod1_A - 1 KEYCODE Mod1_B - 1 KEYCODE Mod2_A - 1 KEYCODE Mod2_B - 1 KEYCODE Mod3_A - 1 KEYCODE Mod3_B - 1 KEYCODE Mod4_A - 1 KEYCODE Mod4_B - 1 KEYCODE Mod5_A - 1 KEYCODE Mod5_B - 2 x unused -) - -(x-request GetModifierMapping - 1 119 opcode - 1 x unused - 2 1 request-length -) - -#+comment -(x-request NoOperation - 1 127 opcode - 1 x unused - 2 1 request-length -) -;; End of file diff --git a/src/clx/debug/event-test.lisp b/src/clx/debug/event-test.lisp deleted file mode 100644 index 2d9a4dfe2..000000000 --- a/src/clx/debug/event-test.lisp +++ /dev/null @@ -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))) - )) diff --git a/src/clx/debug/keytrans.lisp b/src/clx/debug/keytrans.lisp deleted file mode 100644 index a1447b0b3..000000000 --- a/src/clx/debug/keytrans.lisp +++ /dev/null @@ -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 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) - diff --git a/src/clx/debug/trace.lisp b/src/clx/debug/trace.lisp deleted file mode 100644 index a16e180c2..000000000 --- a/src/clx/debug/trace.lisp +++ /dev/null @@ -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 diff --git a/src/clx/debug/util.lisp b/src/clx/debug/util.lisp deleted file mode 100644 index be78e2203..000000000 --- a/src/clx/debug/util.lisp +++ /dev/null @@ -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)) - diff --git a/src/clx/defsystem.lisp b/src/clx/defsystem.lisp deleted file mode 100644 index e6dfc978d..000000000 --- a/src/clx/defsystem.lisp +++ /dev/null @@ -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 ) -;;; (LOAD-CLX ) - -#-(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+) diff --git a/src/clx/demo/.cvsignore b/src/clx/demo/.cvsignore deleted file mode 100644 index be303db03..000000000 --- a/src/clx/demo/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.fasl diff --git a/src/clx/demo/bezier.lisp b/src/clx/demo/bezier.lisp deleted file mode 100644 index b226a373c..000000000 --- a/src/clx/demo/bezier.lisp +++ /dev/null @@ -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)))) diff --git a/src/clx/demo/beziertest.lisp b/src/clx/demo/beziertest.lisp deleted file mode 100644 index 2f42fb98d..000000000 --- a/src/clx/demo/beziertest.lisp +++ /dev/null @@ -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)))) diff --git a/src/clx/demo/clclock.lisp b/src/clx/demo/clclock.lisp deleted file mode 100644 index 7f3ef9280..000000000 --- a/src/clx/demo/clclock.lisp +++ /dev/null @@ -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))) diff --git a/src/clx/demo/clipboard.lisp b/src/clx/demo/clipboard.lisp deleted file mode 100644 index 5c0e03d92..000000000 --- a/src/clx/demo/clipboard.lisp +++ /dev/null @@ -1,200 +0,0 @@ -;;; This is a pretty direct translation of the Xlib selection test -;;; program by Tor Andersson found at -;;; , 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 -;;; -;;; (linked from ), 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))))) diff --git a/src/clx/demo/clx-demos.lisp b/src/clx/demo/clx-demos.lisp deleted file mode 100644 index 20d1bc96d..000000000 --- a/src/clx/demo/clx-demos.lisp +++ /dev/null @@ -1,1051 +0,0 @@ -;;; -*- Mode: Lisp; Package: Demos -*- -;;; -;;; This file contains various graphics hacks written and ported over the -;;; years by various and numerous persons. -;;; -;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. -;;; - -(defpackage :demos (:use :common-lisp) - (:export do-all-demos demo)) - -(in-package :demos) - - -;;;; Graphic demos wrapper macro. - -;;; This wrapper macro should be reconsidered with respect to its property -;;; list usage. Possibly a demo structure should be used with *demos* -;;; pointing to these instead of function names. Also, something should -;;; be done about a title window that displays the name of the demo while -;;; it is running. - -(defparameter *demos* nil) - -(defvar *display* nil) -(defvar *screen* nil) -(defvar *root* nil) -(defvar *black-pixel* nil) -(defvar *white-pixel* nil) -(defvar *window* nil) - -(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms) - `(progn - (defun ,fun-name ,args - ,doc - (unless *display* - #+:cmu - (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp) - (progn - (setf *display* (xlib::open-default-display)) - (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp) - (progn - ;; Portable method - (setf *display* (xlib:open-display (machine-instance))) - (setf *screen* (xlib:display-default-screen *display*))) - (setf *root* (xlib:screen-root *screen*)) - (setf *black-pixel* (xlib:screen-black-pixel *screen*)) - (setf *white-pixel* (xlib:screen-white-pixel *screen*))) - (let ((*window* (xlib:create-window :parent *root* - :x ,x :y ,y - :event-mask nil - :width ,width :height ,height - :background *white-pixel* - :border *black-pixel* - :border-width 2 - :override-redirect :on))) - (xlib:map-window *window*) - ;; - ;; I hate to do this since this is not something any normal - ;; program should do ... - (setf (xlib:window-priority *window*) :above) - (xlib:display-finish-output *display*) - (unwind-protect - (progn ,@forms) - (xlib:unmap-window *window*) - (xlib:display-finish-output *display*)))) - (setf (get ',fun-name 'demo-name) ',demo-name) - (setf (get ',fun-name 'demo-doc) ',doc) - (export ',fun-name) - (pushnew ',fun-name *demos*) - ',fun-name)) - - -;;;; Main entry points. - -(defun do-all-demos () - (loop - (dolist (demo *demos*) - (funcall demo) - (sleep 3)))) - -;;; DEMO is a hack to get by. It should be based on creating a menu. At -;;; that time, *name-to-function* should be deleted, since this mapping will -;;; be manifested in the menu slot name cross its action. Also the -;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for -;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". -;;; - -(defvar *name-to-function* (make-hash-table :test #'eq)) -(defvar *keyword-package* (find-package "KEYWORD")) - -(defun demo () - (macrolet ((read-demo () - `(let ((*package* *keyword-package*)) - (read)))) - (dolist (d *demos*) - (setf (gethash (intern (string-upcase (get d 'demo-name)) - *keyword-package*) - *name-to-function*) - d)) - (loop - (fresh-line) - (dolist (d *demos*) - (write-string " ") - (write-line (get d 'demo-name))) - (write-string " ") - (write-line "Help ") - (write-string " ") - (write-line "Quit") - (write-string "Enter demo name: ") - (let ((demo (read-demo))) - (case demo - (:help - (let* ((demo (read-demo)) - (fun (gethash demo *name-to-function*))) - (fresh-line) - (if fun - (format t "~&~%~A~&~%" (get fun 'demo-doc)) - (format t "Unknown demo name -- ~A." demo)))) - (:quit (return t)) - (t - (let ((fun (gethash demo *name-to-function*))) - (if fun - #+mp - (mp:make-process #'(lambda () - (loop - (funcall fun) - (sleep 2))) - :name (format nil "~S" demo)) - #-mp - (funcall fun) - (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) - - -;;;; Shared demo utilities. - -(defun full-window-state (w) - (xlib:with-state (w) - (values (xlib:drawable-width w) (xlib:drawable-height w) - (xlib:drawable-x w) (xlib:drawable-y w) - (xlib:window-map-state w)))) - - -;;;; Greynetic. - -;;; GREYNETIC displays random sized and shaded boxes in a window. This is -;;; real slow. It needs work. -;;; -(defun greynetic (window duration) - (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 - :drawable window)) - (gcontext (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel* - :tile pixmap - :fill-style :tiled))) - (multiple-value-bind (width height) (full-window-state window) - (dotimes (i duration) - (let* ((pixmap-data (greynetic-pixmapper)) - (image (xlib:create-image :width 32 :height 32 - :depth 1 :data pixmap-data))) - (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) - (xlib:draw-rectangle window gcontext - (- (random width) 5) - (- (random height) 5) - (+ 4 (random (truncate width 3))) - (+ 4 (random (truncate height 3))) - t)) - (xlib:display-force-output *display*))) - (xlib:free-gcontext gcontext) - (xlib:free-pixmap pixmap))) - -(defvar *greynetic-pixmap-array* - (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) - -(defun greynetic-pixmapper () - (let ((pixmap-data *greynetic-pixmap-array*)) - (dotimes (i 4) - (declare (fixnum i)) - (let ((nibble (random 16))) - (setf nibble (logior nibble (ash nibble 4)) - nibble (logior nibble (ash nibble 8)) - nibble (logior nibble (ash nibble 12)) - nibble (logior nibble (ash nibble 16))) - (dotimes (j 32) - (let ((bit (if (logbitp j nibble) 1 0))) - (setf (aref pixmap-data i j) bit - (aref pixmap-data (+ 4 i) j) bit - (aref pixmap-data (+ 8 i) j) bit - (aref pixmap-data (+ 12 i) j) bit - (aref pixmap-data (+ 16 i) j) bit - (aref pixmap-data (+ 20 i) j) bit - (aref pixmap-data (+ 24 i) j) bit - (aref pixmap-data (+ 28 i) j) bit))))) - pixmap-data)) - -#+nil -(defdemo greynetic-demo "Greynetic" (&optional (duration 300)) - 100 100 600 600 - "Displays random grey rectangles." - (greynetic *window* duration)) - - -;;;; Qix. - -(defstruct qix - buffer - (dx1 5) - (dy1 10) - (dx2 10) - (dy2 5)) - -(defun construct-qix (length) - (let ((qix (make-qix))) - (setf (qix-buffer qix) (make-circular-list length)) - qix)) - -(defun make-circular-list (length) - (let ((l (make-list length))) - (rplacd (last l) l))) - - -(defun qix (window lengths duration) - "Each length is the number of lines to put in a qix, and that many qix - (of the correct size) are put up on the screen. Lets the qix wander around - the screen for Duration steps." - (let ((histories (mapcar #'construct-qix lengths))) - (multiple-value-bind (width height) (full-window-state window) - (declare (fixnum width height)) - (xlib:clear-area window) - (xlib:display-force-output *display*) - (do ((h histories (cdr h)) - (l lengths (cdr l))) - ((null h)) - (do ((x (qix-buffer (car h)) (cdr x)) - (i 0 (1+ i))) - ((= i (car l))) - (rplaca x (make-array 4)))) - ;; Start each qix at a random spot on the screen. - (dolist (h histories) - (let ((x (random width)) - (y (random height))) - (rplaca (qix-buffer h) - (make-array 4 :initial-contents (list x y x y))))) - (rplacd (last histories) histories) - (let ((x1 0) (y1 0) (x2 0) (y2 0) - (dx1 0) (dy1 0) (dx2 0) (dy2 0) - tem line next-line qix - (gc (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :line-width 0 :line-style :solid - :function boole-c2))) - (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) - (dotimes (i duration) - ;; Line is the next line in the next qix. Rotate this qix and - ;; the qix ring. - (setq qix (car histories)) - (setq line (car (qix-buffer qix))) - (setq next-line (cadr (qix-buffer qix))) - (setf (qix-buffer qix) (cdr (qix-buffer qix))) - (setq histories (cdr histories)) - (setf x1 (svref line 0)) - (setf y1 (svref line 1)) - (setf x2 (svref line 2)) - (setf y2 (svref line 3)) - (xlib:draw-line window gc x1 y1 x2 y2) - (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) - (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) - (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) - (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) - (cond ((> dx1 10) (setq dx1 10)) - ((< dx1 -10) (setq dx1 -10))) - (cond ((> dy1 10) (setq dy1 10)) - ((< dy1 -10) (setq dy1 -10))) - (cond ((> dx2 10) (setq dx2 10)) - ((< dx2 -10) (setq dx2 -10))) - (cond ((> dy2 10) (setq dy2 10)) - ((< dy2 -10) (setq dy2 -10))) - (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) - (setq dx1 (- dx1)))) - (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) - (setq dx2 (- dx2)))) - (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) - (setq dy1 (- dy1)))) - (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) - (setq dy2 (- dy2)))) - (setf (qix-dy2 qix) dy2) - (setf (qix-dx2 qix) dx2) - (setf (qix-dy1 qix) dy1) - (setf (qix-dx1 qix) dx1) -` (when (svref next-line 0) - (xlib:draw-line window gc - (svref next-line 0) (svref next-line 1) - (svref next-line 2) (svref next-line 3))) - (setf (svref next-line 0) (+ x1 dx1)) - (setf (svref next-line 1) (+ y1 dy1)) - (setf (svref next-line 2) (+ x2 dx2)) - (setf (svref next-line 3) (+ y2 dy2)) - (xlib:display-force-output *display*)))))) - - -(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) - 0 0 700 700 - "Hypnotic wandering lines." - (qix *window* lengths duration)) - - - -;;;; Petal. - -;;; Fast sine constants: - -(defconstant d360 #o5500) -(defconstant d270 #o4160) -(defconstant d180 #o2640) -(defconstant d90 #o1320) -(defconstant vecmax 2880) - -(defparameter sin-array - '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 - #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 - #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 - #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 - #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 - #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 - #o23546 #o24106 #o24443 #o24774 #o25323 #o25645 - #o26165 #o26501 #o27011 #o27316 #o27617 #o30115 - #o30406 #o30674 #o31156 #o31434 #o31706 #o32154 - #o32416 #o32654 #o33106 #o33333 #o33554 #o33771 - #o34202 #o34406 #o34605 #o35000 #o35167 #o35351 - #o35526 #o35677 #o36043 #o36203 #o36336 #o36464 - #o36605 #o36721 #o37031 #o37134 #o37231 #o37322 - #o37407 #o37466 #o37540 #o37605 #o37646 #o37701 - #o37730 #o37751 #o37766 #o37775 #o40000)) - -(defmacro psin (val) - `(let* ((val ,val) - neg - frac - sinlo) - (if (>= val d180) - (setq neg t - val (- val d180))) - (if (>= val d90) - (setq val (- d180 val))) - (setq frac (logand val 7)) - (setq val (ash val -3)) - ;; - (setq sinlo (if (>= val 90) - (svref sin-array 90) - (svref sin-array val))) - ;; - (if (< val 90) - (setq sinlo - (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) - -3)))) - ;; - (if neg - (- sinlo) - sinlo))) - -(defmacro pcos (x) - `(let ((tmp (- ,x d270))) - (psin (if (minusp tmp) (+ tmp d360) tmp)))) - - -;;;; Miscellaneous petal hackery. - -(defmacro high-16bits-* (a b) - `(let ((a-h (ash ,a -8)) - (b-h (ash ,b -8))) - (+ (* a-h b-h) - (ash (* a-h (logand ,b 255)) -8) - (ash (* b-h (logand ,a 255)) -8)))) - -(defun complete (style petal) - (let ((repnum 1) - factor cntval needed) - (dotimes (i 3) - (case i - (0 (setq factor 2 cntval 6)) - (1 (setq factor 3 cntval 2)) - (2 (setq factor 5 cntval 1))) - (do () - ((or (minusp cntval) (not (zerop (rem style factor))))) - (setq repnum (* repnum factor)) - (setq cntval (1- cntval)) - (setq style (floor style factor)))) - (setq needed (floor vecmax repnum)) - (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) - - -;;;; Petal Parameters and Petal itself - -(defparameter continuous t) -(defparameter styinc 2) -(defparameter petinc 1) -(defparameter scalfac-fac 8192) - -(defun petal (petal-window &optional (how-many 10) (style 0) (petal 0)) - (let ((width 512) - (height 512)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*) - (let ((veccnt 0) - (nustyle 722) - (nupetal 3) - (scalfac (1+ (floor scalfac-fac (min width height)))) - (ctrx (floor width 2)) - (ctry (floor height 2)) - (tt 0) - (s 0) - (lststyle 0) - (lstpetal 0) - (petstyle 0) - (vectors 0) - (r 0) - (x1 0) - (y1 0) - (x2 0) - (y2 0) - (i 0) - (gc (xlib:create-gcontext :drawable petal-window - :foreground *black-pixel* - :background *white-pixel* - :line-width 0 :line-style :solid))) - (loop - (when (zerop veccnt) - (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal - style nustyle petstyle (rem (* petal style) d360) - vectors (complete style petal)) - (when continuous - (setq nupetal (+ nupetal petinc) - nustyle (+ nustyle styinc))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 - tt (rem (+ tt style) d360) - s (rem (+ s petstyle) d360) - r (pcos s)) - (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) - y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) - (when (/= i 1) - (xlib:draw-line petal-window gc x1 y1 x2 y2) - (xlib:display-force-output *display*))) - (when (> veccnt vectors) - (setq veccnt 0) - (setq how-many (1- how-many)) - (sleep 2) - (when (zerop how-many) (return))))))) - -(defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0)) - 100 100 512 512 - "Flower-like display." - (petal *window* how-many style petal)) - - -;;;; Hanoi. - -;;; Random parameters: - -(defparameter disk-thickness 15 "The thickness of a disk in pixels.") -(defparameter disk-spacing (+ disk-thickness 3) - "The amount of vertical space used by a disk on a needle.") -(defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.") -(defvar *vertical-velocity* 12 "The speed at which disks move up and down.") - -;;; These variables are bound by the main function. - -(defvar *hanoi-window* () "The window that Hanoi is happening on.") -(defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.") -(defvar *transfer-height* () "The height at which disks are transferred.") -(defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.") - -;;; Needle Functions - -(defstruct disk - size) - -(defstruct needle - position - disk-stack) - -;;; Needle-Top-Height returns the height of the top disk on NEEDLE. - -(defun needle-top-height (needle) - (- *hanoi-window-height* - (* disk-spacing (length (the list (needle-disk-stack needle)))))) - -(defvar available-disks - (do ((i 10 (+ i 10)) - (dlist () (cons (make-disk :size i) dlist))) - ((> i 80) dlist))) - -(defvar needle-1 (make-needle :position 184)) -(defvar needle-2 (make-needle :position 382)) -(defvar needle-3 (make-needle :position 584)) - -;;; Graphic interface abstraction: - -;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p" -;;; set to T. Update-Screen forces the display output. -;;; -(defmacro invert-rectangle (x y height width) - `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* - ,x ,y ,width ,height t)) - -(defmacro update-screen () - `(xlib:display-force-output *display*)) - - -;;;; Moving disks up and down - -;;; Slide-Up slides the image of a disk up from the coordinates X, -;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to -;;; move. START-Y must be greater than END-Y - -(defun slide-up (start-y end-y x disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- start-y end-y) *vertical-velocity*) - (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (- old-y *vertical-velocity*)) - (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (- old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) - ;; Loop body writes disk at new height & erases at old height. - (invert-rectangle x old-y disk-thickness width) - (invert-rectangle x new-y disk-thickness width) - (update-screen)))) - -;;; Slide-Down slides the image of a disk down from the coordinates X, -;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to -;;; move. START-Y must be less than END-Y. - -(defun slide-down (start-y end-y x disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- end-y start-y) *vertical-velocity*) - (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (+ old-y *vertical-velocity*)) - (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (+ old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) - ;; Loop body writes disk at new height & erases at old height. - (invert-rectangle X old-y disk-thickness width) - (invert-rectangle X new-y disk-thickness width) - (update-screen)))) - - -;;;; Lifting and Droping Disks - -;;; Lift-disk pops the top disk off of needle and raises it up to the -;;; transfer height. The disk is returned. - -(defun lift-disk (needle) - "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it." - (let* ((height (needle-top-height needle)) - (disk (pop (needle-disk-stack needle)))) - (slide-up height - *transfer-height* - (needle-position needle) - (disk-size disk)) - disk)) - -;;; Drop-disk drops a disk positioned over needle at the transfer height -;;; onto needle. The disk is pushed onto needle. - -(defun drop-disk (disk needle) - "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." - (push disk (needle-disk-stack needle)) - (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) - t) - - -;;; Drop-initial-disk is the same as drop-disk except that the disk is -;;; drawn once before dropping. - -(defun drop-initial-disk (disk needle) - "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." - (let* ((size (disk-size disk)) - (lx (- (needle-position needle) size))) - (invert-rectangle lx *transfer-height* disk-thickness (* size 2)) - (push disk (needle-disk-stack needle)) - (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) - t)) - - -;;;; Sliding Disks Right and Left - -;;; Slide-Right slides the image of a disk located at START-X, Y to the -;;; position END-X, Y. DISK-SIZE is the size of the disk. START-X is -;;; less than END-X. - -(defun slide-right (start-x end-x Y disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- end-x start-x) *horizontal-velocity*) - (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*)) - (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (invert-rectangle left-x Y disk-thickness pixels-left) - (update-screen))) - ;; Loop body adds chunk *horizontal-velocity* pixels wide to right - ;; side of disk, then chops off left side. - (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) - (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) - (update-screen)))) - -;;; Slide-Left is the same as Slide-Right except that START-X is greater -;;; than END-X. - -(defun slide-left (start-x end-x Y disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- start-x end-x) *horizontal-velocity*) - (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*) - (- right-x *horizontal-velocity*)) - (left-x (- (- start-x disk-size) *horizontal-velocity*) - (- left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) - (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) - (invert-rectangle left-x Y disk-thickness pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (update-screen))) - ;; Loop body adds chunk *horizontal-velocity* pixels wide to left - ;; side of disk, then chops off right side. - (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) - (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) - (update-screen)))) - - -;;;; Transferring Disks - -;;; Transfer disk slides a disk at the transfer height from a position -;;; over START-NEEDLE to a position over END-NEEDLE. Modified disk is -;;; returned. - -(defun transfer-disk (disk start-needle end-needle) - "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." - (let ((start (needle-position start-needle)) - (end (needle-position end-needle))) - (if (< start end) - (slide-right start end *transfer-height* (disk-size disk)) - (slide-left start end *transfer-height* (disk-size disk))) - disk)) - - -;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE. - -(defun move-one-disk (start-needle end-needle) - "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." - (drop-disk (transfer-disk (lift-disk start-needle) - start-needle - end-needle) - end-needle) - t) - -;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE -;;; obeying the rules of the towers of hannoi problem. To move the -;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage. - -(defun move-n-disks (n start-needle end-needle temp-needle) - "Moves the top N disks from START-NEEDLE to END-NEEDLE. - Uses TEMP-NEEDLE for temporary storage." - (cond ((= n 1) - (move-one-disk start-needle end-needle)) - (t - (move-n-disks (1- n) start-needle temp-needle end-needle) - (move-one-disk start-needle end-needle) - (move-n-disks (1- n) temp-needle end-needle start-needle))) - t) - - -;;;; Hanoi itself. - -(defun hanoi (window n) - (multiple-value-bind (width height) (full-window-state window) - (declare (ignore width)) - (let* ((*hanoi-window* window) - (*hanoi-window-height* height) - (*transfer-height* (- height (* disk-spacing n))) - (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* - :foreground *white-pixel* - :background *black-pixel* - :fill-style :solid - :function boole-c2))) - (xlib:clear-area *hanoi-window*) - (xlib:display-force-output *display*) - (let ((needle-1 (make-needle :position 184)) - (needle-2 (make-needle :position 382)) - (needle-3 (make-needle :position 584))) - (setf (needle-disk-stack needle-1) ()) - (setf (needle-disk-stack needle-2) ()) - (setf (needle-disk-stack needle-3) ()) - (do ((n n (1- n)) - (available-disks available-disks (cdr available-disks))) - ((zerop n)) - (drop-initial-disk (car available-disks) needle-1)) - (move-n-disks n needle-1 needle-3 needle-2) - t)))) - -;;; Change the names of these when the DEMO loop isn't so stupid. -;;; -(defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4)) - 0 100 768 300 - "Solves the Towers of Hanoi problem before your very eyes." - (let ((*horizontal-velocity* 3) - (*vertical-velocity* 1)) - (hanoi *window* how-many))) -;;; -(defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7)) - 0 100 768 300 - "Solves the Towers of Hanoi problem before your very eyes." - (hanoi *window* how-many)) - - - -;;;; Bounce window. - -;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of -;;; the screen. Optionally, the window can have an initial x velocity, -;;; screen border elasticity, and gravity value. The outer loop is -;;; entered the first time with the window at its initial height, but -;;; each iteration after this, the loop starts with the window at the -;;; bottom of the screen heading upward. The inner loop, except for the -;;; first execution, carries the window up until the negative velocity -;;; becomes positive, carrying the window down to bottom when the -;;; velocity is positive. Due to number lossage, ROUND'ing and -;;; TRUNC'ing when the velocity gets so small will cause the window to -;;; head upward with the same velocity over two iterations which will -;;; cause the window to bounce forever, so we have prev-neg-velocity and -;;; number-problems to check for this. This is not crucial with the x -;;; velocity since the loop terminates as a function of the y velocity. -;;; -(defun bounce-window (window &optional - (x-velocity 0) (elasticity 0.85) (gravity 2)) - (unless (< 0 elasticity 1) - (error "Elasticity must be between 0 and 1.")) - (unless (plusp gravity) - (error "Gravity must be positive.")) - (multiple-value-bind (width height x y mapped) (full-window-state window) - (when (eq mapped :viewable) - (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) - (left-of-window-at-right (- (xlib:drawable-width *root*) width)) - (y-velocity 0) - (prev-neg-velocity most-negative-fixnum) - (number-problems nil)) - (declare (fixnum top-of-window-at-bottom left-of-window-at-right - y-velocity)) - (loop - (when (= prev-neg-velocity 0) (return t)) - (let ((negative-velocity (minusp y-velocity))) - (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) - (when (and negative-velocity (>= y-velocity 0)) - (setf negative-velocity nil)) - (let ((next-x (+ x x-velocity))) - (declare (fixnum next-x)) - (when (or (> next-x left-of-window-at-right) - (< next-x 0)) - (setq x-velocity (- (truncate (* elasticity x-velocity))))) - (setq x next-x)) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*)))))))) - -;;; Change the name of this when DEMO is not so stupid. -;;; -(defdemo shove-bounce-demo "Shove-bounce" () - 100 100 300 300 - "Drops the demo window with an inital X velocity which bounces off - screen borders." - (bounce-window *window* 30)) - -(defdemo bounce-demo "Bounce" () - 100 100 300 300 - "Drops the demo window which bounces off screen borders." - (bounce-window *window*)) - - -;;;; Recurrence Demo - -;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu) - -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. - -;;; The author provides this software "as is" without express or -;;; implied warranty. - -;;; This routine plots the recurrence -;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 -;;; y <- .21 - x -;;; As described in a ?? 1983 issue of the Mathematical Intelligencer - -(defun recurrence (display window &optional (point-count 10000)) - (let ((gc (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel*))) - (multiple-value-bind (width height) (full-window-state window) - (xlib:clear-area window) - (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) - (xlib:display-force-output display) - (sleep 4)) - (xlib:free-gcontext gc))) - -;;; Draw points. X assumes points are in the range of width x height, -;;; with 0,0 being upper left and 0,H being lower left. -;;; hw and hh are half-width and half-height of screen - -(defun draw-ppict (win gc count x y hw hh) - "Recursively draw pretty picture" - (unless (zerop count) - (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture - (yf (floor (* (+ 0.7 y) hh )))) - (xlib:draw-point win gc xf yf) - (draw-ppict win gc (1- count) - (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) - (- 0.21 x) - hw - hh)))) - -(defdemo recurrence-demo "Recurrence" () - 10 10 700 700 - "Plots a cool recurrence relation." - (recurrence *display* *window*)) - - -;;;; Plaid - -;;; -;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover. -;;; - -(defmacro rect-x (rects n) - `(svref ,rects (ash ,n 2))) -(defmacro rect-y (rects n) - `(svref ,rects (+ (ash ,n 2) 1))) -(defmacro rect-width (rects n) - `(svref ,rects (+ (ash ,n 2) 2))) -(defmacro rect-height (rects n) - `(svref ,rects (+ (ash ,n 2) 3))) - -(defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10)) - (let ((gcontext (xlib:create-gcontext :drawable window - :function boole-c2 - :plane-mask (logxor *white-pixel* - *black-pixel*) - :background *white-pixel* - :foreground *black-pixel* - :fill-style :solid)) - (rectangles (make-array (* 4 num-rectangles) - :element-type 'number - :initial-element 0))) - (multiple-value-bind (width height) (full-window-state window) - (let ((center-x (ash width -1)) - (center-y (ash height -1)) - (x-dir -2) - (y-dir -2) - (x-off 2) - (y-off 2)) - (dotimes (iter (truncate num-iterations num-rectangles)) - (dotimes (i num-rectangles) - (setf (rect-x rectangles i) (- center-x x-off)) - (setf (rect-y rectangles i) (- center-y y-off)) - (setf (rect-width rectangles i) (ash x-off 1)) - (setf (rect-height rectangles i) (ash y-off 1)) - (incf x-off x-dir) - (incf y-off y-dir) - (when (or (<= x-off 0) (>= x-off center-x)) - (decf x-off (ash x-dir 1)) - (setf x-dir (- x-dir))) - (when (or (<= y-off 0) (>= y-off center-y)) - (decf y-off (ash y-dir 1)) - (setf y-dir (- y-dir)))) - (xlib:draw-rectangles window gcontext rectangles t) - (xlib:display-force-output display)))) - (xlib:free-gcontext gcontext))) - -(defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10)) - 10 10 101 201 - "Plaid, man." - (plaid *display* *window* iterations num-rectangles)) - - -;;;; Bball demo - -;;; -;;; Ported to CLX by Blaine Burks -;;; - -(defvar *ball-size-x* 38) -(defvar *ball-size-y* 34) - -(defmacro xor-ball (pixmap window gcontext x y) - `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* - ,window ,x ,y)) - -(defconstant bball-gravity 1) -(defconstant maximum-x-drift 7) - -(defvar *max-bball-x*) -(defvar *max-bball-y*) - -(defstruct ball - (x (random (- *max-bball-x* *ball-size-x*))) - (y (random (- *max-bball-y* *ball-size-y*))) - (dx (if (zerop (random 2)) (random maximum-x-drift) - (- (random maximum-x-drift)))) - (dy 0)) - -(defun get-bounce-image () - "Returns the pixmap to be bounced around the screen." - (xlib::bitmap-image #*000000000000000000000000000000000000 - #*000000000000000000000000000000000000 - #*000000000000000000001000000010000000 - #*000000000000000000000000000100000000 - #*000000000000000000000100001000000000 - #*000000000000000010000000010000000000 - #*000000000000000000100010000000000000 - #*000000000000000000001000000000000000 - #*000000000001111100000000000101010000 - #*000000000010000011000111000000000000 - #*000000000100000000111000000000000000 - #*000000000100000000000000000100000000 - #*000000000100000000001000100010000000 - #*000000111111100000010000000001000000 - #*000000111111100000100000100000100000 - #*000011111111111000000000000000000000 - #*001111111111111110000000100000000000 - #*001111111111111110000000000000000000 - #*011111111111111111000000000000000000 - #*011111111111111111000000000000000000 - #*111111111111110111100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111110111100000000000000000 - #*011111111111111111000000000000000000 - #*011111111111011111000000000000000000 - #*001111111111111110000000000000000000 - #*001111111111111110000000000000000000 - #*000011111111111000000000000000000000 - #*000000111111100000000000000000000000 - #*000000000000000000000000000000000000)) - - -(defun bounce-1-ball (pixmap window gcontext ball) - (let ((x (ball-x ball)) - (y (ball-y ball)) - (dx (ball-dx ball)) - (dy (ball-dy ball))) - (xor-ball pixmap window gcontext x y) - (setq x (+ x dx)) - (setq y (+ y dy)) - (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) - (setq x (- x dx) - dx (- dx))) - (if (> y (- *max-bball-y* *ball-size-y*)) - (setq y (- y dy) - dy (- dy))) - (setq dy (+ dy bball-gravity)) - (setf (ball-x ball) x) - (setf (ball-y ball) y) - (setf (ball-dx ball) dx) - (setf (ball-dy ball) dy) - (xor-ball pixmap window gcontext x y))) - -(defun bounce-balls (display window how-many duration) - (xlib:clear-area window) - (xlib:display-force-output display) - (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) - (let* ((balls (do ((i 0 (1+ i)) - (list () (cons (make-ball) list))) - ((= i how-many) list))) - (gcontext (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :function boole-xor - :exposures :off)) - (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 - :drawable window)) - (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap - :foreground *white-pixel* - :background *black-pixel*))) - (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) - :x 0 :y 0 :width 38 :height 34) - (xlib:free-gcontext pixmap-gc) - (dolist (ball balls) - (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) - (xlib:display-force-output display) - (dotimes (i duration) - (dolist (ball balls) - (bounce-1-ball bounce-pixmap window gcontext ball)) - (xlib:display-force-output display)) - (xlib:free-pixmap bounce-pixmap) - (xlib:free-gcontext gcontext)))) - -#+nil -(defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) - 34 34 700 500 - "Bouncing balls in space." - (bounce-balls *display* *window* how-many duration)) diff --git a/src/clx/demo/gl-test.lisp b/src/clx/demo/gl-test.lisp deleted file mode 100644 index b5904e261..000000000 --- a/src/clx/demo/gl-test.lisp +++ /dev/null @@ -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 - ))) diff --git a/src/clx/demo/hello.lisp b/src/clx/demo/hello.lisp deleted file mode 100644 index 1c3961d1f..000000000 --- a/src/clx/demo/hello.lisp +++ /dev/null @@ -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))))) diff --git a/src/clx/demo/mandel.lisp b/src/clx/demo/mandel.lisp deleted file mode 100644 index 5fe3dbc9c..000000000 --- a/src/clx/demo/mandel.lisp +++ /dev/null @@ -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 " [~a ~a]>~%" -;;; (zoom-type object) (start-x object) (start-y object) -;;; (stop-x object) (stop-y object))) - -(defun init-colours () - (unless *colmap* - (setf *colmap* (make-array 256 :element-type 'xlib:gcontext :initial-element *zoomcolmap*)) - (setf (aref *colmap* 0) (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:alloc-color - (xlib:screen-default-colormap *screen*) - (xlib:make-color :red 0 - :green 0 - :blue 0)))) - (loop for index from 1 to 255 - do (setf (aref *colmap* index) - (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:alloc-color - (xlib:screen-default-colormap *screen*) - (xlib:make-color :red (random 1.0) - :green (random 1.0) - :blue (random 1.0)))))))) -(defmacro modcol (col max) - `(if (= ,col ,max) 0 (1+ (mod ,col 255)))) - -(defun plot (win col x y max) - (declare (fixnum col x y max)) - (let ((col (modcol col max))) - (xlib:draw-point win (aref *colmap* col) x y) - (setf (aref (the (simple-array (integer 0 255) (512 512)) - (gethash win *backing-store*)) x y) col))) - -(defun display-help () - (unless *helpwin* - (setf *helpwin* (xlib:create-window - :parent (xlib:screen-root *screen*) - :x 512 - :y 512 - :width 310 - :height 180 - :event-mask (xlib:make-event-mask :exposure) - :backing-store :always - :background (xlib:screen-white-pixel *screen*))) - (xlib:map-window *helpwin*) - (xlib:display-force-output *display*)) - (unless (xlib:gcontext-font *textmap*) - (let ((fixed (xlib:list-fonts *display* "fixed")) - font) - (if fixed - (setf font (xlib:open-font *display* "fixed")) - (error "Could not open suitable font")) - (setf (xlib:gcontext-font *textmap*) (if (consp fixed) - (car fixed) - fixed)))) - (xlib:draw-rectangle *helpwin* *white* 0 0 (xlib:drawable-width *helpwin*) (xlib:drawable-height *helpwin*) t) - (xlib:draw-glyphs *helpwin* *textmap* 10 13 "Button 1: Zoom same") - (xlib:draw-glyphs *helpwin* *textmap* 10 33 "Button 2: Zoom new") - (xlib:draw-glyphs *helpwin* *textmap* 10 53 "Button 3: Zoom out, same") - (xlib:draw-glyphs *helpwin* *textmap* 10 93 "In general, click to zoom centred on mouse,") - (xlib:draw-glyphs *helpwin* *textmap* 10 113 "drag to zoom a region.") - (xlib:draw-glyphs *helpwin* *textmap* 10 153 "Q: quit") - (xlib:display-force-output *display*)) - -(defun repaint-window (win x-low y-low x-high y-high) - (declare (fixnum x-low y-low x-high y-high)) - (if (eq win *helpwin*) - (display-help) - (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) - (loop for y of-type fixnum from y-low to y-high - do - (loop for x of-type fixnum from x-low to x-high - do (xlib:draw-point win (aref *colmap* (aref bs x y)) x y)))))) - -(defun fill-square (win col x y s max) - (declare (fixnum col x y s max)) - (let ((col (modcol col max))) - (xlib:draw-rectangle win (aref *colmap* col) x y s s t) - (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) - (loop for px of-type fixnum from x to (1- (+ x s)) - do (loop for py of-type fixnum from y to (1- (+ y s)) - do (setf (aref bs px py) col)))))) - -(defun make-square (win x y side bx by dx dy &optional (maxiter 1024)) - (declare (xlib:window win) - (fixnum x y side maxiter) - (double-float bx by dx dy)) - (let ((sq (make-mandel-square - :x x :y y :s side - :base-r bx :base-i by - :dr dx :di dy - :maxiter maxiter - :win win))) - (queue-push *sysqueue* sq))) - -(defun mandel-win (win lx ly hx hy &optional (maxiter 1024)) - (declare (xlib:window win) - (double-float lx ly hx hy) - (fixnum maxiter)) - (let ((dx (coerce (/ (- hx lx) 512.0d0) 'double-float)) - (dy (coerce (/ (- hy ly) 512.0d0) 'double-float))) - (setf (gethash win *winmap*) - (make-mandel-square :x 0 :y 0 :s 512 - :base-r lx :base-i ly - :dr dx :di dy :maxiter maxiter)) - (make-square win 0 256 256 lx ly dx dy maxiter) - (make-square win 256 256 256 lx ly dx dy maxiter) - (make-square win 256 0 256 lx ly dx dy maxiter) - (make-square win 0 0 256 lx ly dx dy maxiter))) - -(defun new-window (lx ly hx hy &optional (maxiter 1024)) - (let ((win (xlib:create-window - :parent (xlib:screen-root *screen*) - :x (+ 100 (random 50)) :y (+ 100 (random 50)) - :width 512 :height 512 - :bit-gravity :center - :event-mask (xlib:make-event-mask - :button-motion :button-press :button-release - :key-press :exposure))) - (ar (make-array '(512 512) - :element-type '(integer 0 255) :initial-element 0)) - ) - (setf (gethash win *backing-store*) ar) - (xlib:map-window win) - (mandel-win win - (coerce lx 'double-float) (coerce ly 'double-float) - (coerce hx 'double-float) (coerce hy 'double-float) maxiter))) - -(defun fill-square-p (ix iy s bx by dx dy max win) - (declare (fixnum ix iy s max) - (double-float bx by dx dy)) - (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max))) - (and - (loop for px from ix below (+ ix s) - for x of-type double-float = (+ bx (* px dx)) - with y = (+ by (* iy dy)) - for i = (iter x y max) - do (plot win i px iy max) - while (= i norm) - finally (return t)) - (loop for py from iy below (+ s iy) - for y of-type double-float = (+ by (* py dy)) - with x = (+ bx (* ix dx)) - for i = (iter x y max) - do (plot win i ix py max) - while (= i norm) - finally (return t)) - (loop for px from (1- (+ s ix)) downto ix - for x of-type double-float = (+ bx (* px dx)) - with y = (+ by (* dy (1- (+ s iy)))) - for i = (iter x y max) - do (plot win i px iy max) - if (/= i norm) return nil - finally (return t)) - (loop for py from (1- (+ s iy)) downto iy - for y of-type double-float = (+ by (* py dy)) - with x = (+ bx (* dx (1- (+ s ix)))) - for i = (iter x y max) - do (plot win i ix py max) - if (/= i norm) return nil - finally (return t))))) - -(defmacro z (base delta int) - `(+ ,base (* ,delta ,int))) -(defun draw-square (square) - (declare (mandel-square square)) - (let ((dx (ms-dr square)) - (dy (ms-di square)) - (base-x (ms-base-r square)) - (base-y (ms-base-i square)) - (maxiter (ms-maxiter square)) - (win (ms-win square)) - (x (ms-x square)) - (y (ms-y square)) - (s (ms-s square)) - ) - (declare (double-float dx dy base-x base-y) - (fixnum x y s maxiter)) - (cond - ((= s 2) - (plot win - (iter (z base-x dx (1+ x)) (z base-y dy (1+ y)) maxiter) - (1+ x) (1+ y) maxiter) - (plot win - (iter (z base-x dx (1+ x)) (z base-y dy y) maxiter) - (1+ x) y maxiter) - (plot win - (iter (z base-x dx x) (z base-y dy (1+ y)) maxiter) - x (1+ y) maxiter) - (plot win - (iter (z base-x dx x) (z base-y dy y) maxiter) - x y maxiter)) - ((fill-square-p x y s base-x base-y dx dy maxiter win) - (fill-square win - (iter (z base-x dx x) (z base-y dy y) maxiter) - x y s maxiter)) - (t (let ((new-s (/ s 2))) - (make-square win - x y new-s - base-x base-y - dx dy - maxiter) - (make-square win - x (+ y new-s) new-s - base-x base-y - dx dy - maxiter) - (make-square win - (+ x new-s) y new-s - base-x base-y - dx dy - maxiter) - (make-square win - (+ x new-s) (+ y new-s) new-s - base-x base-y - dx dy - maxiter)))))) - -(defun create-zoom (win x y button) - (setf (gethash win *zoom-table*) - (make-instance 'zoomer - :x x :y y - :win win - :type (case button - (1 :zoom-same) - (2 :zoom-new) - (3 :zoom-out))))) - -(defun update-zoom (win x y code) - (declare (ignore code) - (fixnum x y)) - (let ((zoomer (gethash win *zoom-table*))) - (when zoomer - (let ((new-side (max 0 - (- (the fixnum x) (the fixnum (start-x zoomer))) - (- (the fixnum y) (the fixnum (start-y zoomer)))))) - (let ((old-side (max 0 - (- (the fixnum (stop-x zoomer)) - (the fixnum (start-x zoomer))) - (- (the fixnum (stop-y zoomer)) - (the fixnum (start-y zoomer)))))) - (xlib:draw-rectangle win *zoomcolmap* - (the fixnum (start-x zoomer)) - (the fixnum (start-y zoomer)) - old-side old-side)) - (setf (stop-x zoomer) (max (the fixnum (start-x zoomer)) - (the fixnum x) - )) - (setf (stop-y zoomer) (max (the fixnum (start-y zoomer)) - (the fixnum y) - )) - (xlib:draw-rectangle win *zoomcolmap* - (the fixnum (start-x zoomer)) - (the fixnum (start-y zoomer)) - new-side new-side) - (xlib:display-force-output *display*))))) - -(defun finish-zoom (win x y code) - (declare (ignore code)) - (let ((zoomer (gethash win *zoom-table*))) - (setf (stop-x zoomer) x) - (setf (stop-y zoomer) y))) - -(defun do-zoom (win) - (let ((zoomer (gethash win *zoom-table*))) - (declare (zoomer zoomer)) - (setf (gethash win *zoom-table*) nil) - (let ((dx (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer)))) - (dy (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))) - (sq (gethash win *winmap*))) - (let ((side (max dx dy)) - (x (the fixnum (start-x zoomer))) - (y (the fixnum (start-y zoomer))) - lx hx ly hy - ) - (if (< side 5) - (setf lx (+ (ms-base-r sq) - (* (- x 128) (ms-dr sq))) - ly (+ (ms-base-i sq) - (* (- y 128) (ms-di sq))) - hx (+ (ms-base-r sq) - (* (+ x 128) (ms-dr sq))) - hy (+ (ms-base-i sq) - (* (+ y 128) (ms-di sq)))) - (setf lx (+ (ms-base-r sq) - (* x (ms-dr sq))) - ly (+ (ms-base-i sq) - (* y (ms-dr sq))) - hx (+ (ms-base-r sq) - (* (+ side x) (ms-dr sq))) - hy (+ (ms-base-i sq) - (* (+ side y) (ms-dr sq))))) -;;; (format t "DEBUG: zoomer is ~a~%~%" zoomer) - (case (zoom-type zoomer) - (:zoom-new (new-window lx ly hx hy (ms-maxiter sq))) - (:zoom-same (empty-win *sysqueue* win) - (mandel-win win lx ly hx hy (ms-maxiter sq))) - (:zoom-out (empty-win *sysqueue* win) - (let ((br (ms-base-r sq)) - (bi (ms-base-i sq)) - (dr (ms-dr sq)) - (di (ms-di sq))) - (mandel-win win - (- br (* 512 dr)) (- bi (* 512 di)) - (+ (* 1024 dr) br) (+ (* 1024 di) bi) - (ms-maxiter sq)))) - - (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer)))))))) - -(defun quit-window (window) - (let ((temp (gethash window (win-queues *sysqueue*)))) - (when temp - (empty temp)))) - -(defun event-loop () - (init-colours) - (do ((quit nil) - (redisplay nil t)) - ((eq quit 'quit)) - (xlib:event-case (*display* :timeout 0) - (:button-press (window x y code) - (create-zoom window x y code) - t) - (:button-release (window x y code) - (finish-zoom window x y code) - (do-zoom window) - t) - (:motion-notify (window x y code) - (update-zoom window x y code) - t) - (:exposure (window x y width height count) - (let ((count count)) - (declare (ignore count) - (fixnum x y width height)) - (when redisplay - (repaint-window window x y (1- (+ x width)) (1- (+ y height))))) - t) - (:key-press (window code) - (case (xlib:keysym->character - *display* - (xlib:keycode->keysym *display* code (make-shift-foo))) - (#\q (quit-window window)) - (#\? (display-help)) - ((:left-shift :right-shift) - (push :shift *modstate*)) - ((:left-control :right-control) - (push :ctrl *modstate*)) - (:character-set-switch - (push :character-set-switch *modstate*))) - t) - (:key-release (window code) - (let ((window window)) - (declare (ignore window)) - (case (xlib:keysym->character - *display* - (xlib:keycode->keysym *display* code 0)) - (:character-set-switch - (setf *modstate* (delete :character-set-switch *modstate*))) - ((:left-control :right-control) - (setf *modstate* (delete :ctrl *modstate*))) - ((:left-shift :right-shift) - (setf *modstate* (delete :shift *modstate*))))) - t)) - (cond ((empty-p *sysqueue*) - nil) - (t (let ((square (dequeue *sysqueue*))) - (draw-square square)))))) diff --git a/src/clx/demo/menu.lisp b/src/clx/demo/menu.lisp deleted file mode 100644 index 3919c2622..000000000 --- a/src/clx/demo/menu.lisp +++ /dev/null @@ -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))))) - diff --git a/src/clx/demo/zoid.lisp b/src/clx/demo/zoid.lisp deleted file mode 100644 index 97e5b6fe2..000000000 --- a/src/clx/demo/zoid.lisp +++ /dev/null @@ -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)))) - diff --git a/src/clx/dep-allegro.lisp b/src/clx/dep-allegro.lisp deleted file mode 100644 index ce5d27ee8..000000000 --- a/src/clx/dep-allegro.lisp +++ /dev/null @@ -1,2210 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(proclaim '(declaration array-register)) - -;;; The size of the output buffer. Must be a multiple of 4. -(defparameter *output-buffer-size* 8192) - -;;; Number of seconds to wait for a reply to a server request -(defparameter *reply-timeout* nil) - -#-(or clx-overlapping-arrays (not clx-little-endian)) -(progn - (defconstant +word-0+ 0) - (defconstant +word-1+ 1) - - (defconstant +long-0+ 0) - (defconstant +long-1+ 1) - (defconstant +long-2+ 2) - (defconstant +long-3+ 3)) - -#-(or clx-overlapping-arrays clx-little-endian) -(progn - (defconstant +word-0+ 1) - (defconstant +word-1+ 0) - - (defconstant +long-0+ 3) - (defconstant +long-1+ 2) - (defconstant +long-2+ 1) - (defconstant +long-3+ 0)) - -;;; Set some compiler-options for often used code - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 - "Speed compiler option for buffer code.") - (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 - "Safety compiler option for buffer code.") - (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 - "Debug compiler option for buffer code>") - (defun declare-bufmac () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) - ;; It's my impression that in lucid there's some way to make a - ;; declaration called fast-entry or something that causes a function - ;; to not do some checking on args. Sadly, we have no lucid manuals - ;; here. If such a declaration is available, it would be a good - ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ - ;; is 0. - (defun declare-buffun () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) - -(declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) - -#-Genera -(progn - -(defun card8->int8 (x) - (declare (type card8 x)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - -(defun int8->card8 (x) - (declare (type int8 x)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - -(defun card16->int16 (x) - (declare (type card16 x)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - -(defun int16->card16 (x) - (declare (type int16 x)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - -(defun card32->int32 (x) - (declare (type card32 x)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - -(defun int32->card32 (x) - (declare (type int32 x)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (ldb (byte 32 0) x))) - -) - -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) - -#+(or excl lcl3.0 clx-overlapping-arrays) -(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 - aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) - -#+(and clx-overlapping-arrays (not Genera)) -(progn - -(defun aref-card16 (a i) - (aref a i)) - -(defun aset-card16 (v a i) - (setf (aref a i) v)) - -(defun aref-int16 (a i) - (card16->int16 (aref a i))) - -(defun aset-int16 (v a i) - (setf (aref a i) (int16->card16 v)) - v) - -(defun aref-card32 (a i) - (aref a i)) - -(defun aset-card32 (v a i) - (setf (aref a i) v)) - -(defun aref-int32 (a i) - (card32->int32 (aref a i))) - -(defun aset-int32 (v a i) - (setf (aref a i) (int32->card32 v)) - v) - -(defun aref-card29 (a i) - (aref a i)) - -(defun aset-card29 (v a i) - (setf (aref a i) v)) - -) - -#+excl -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-byte))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-byte) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-byte))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-byte) v)) - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-word))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-word) v)) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-word))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-word) v)) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long) v)) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-long))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-long) v)) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long) v)) - -) - -(defsetf aref-card8 (a i) (v) - `(aset-card8 ,v ,a ,i)) - -(defsetf aref-int8 (a i) (v) - `(aset-int8 ,v ,a ,i)) - -(defsetf aref-card16 (a i) (v) - `(aset-card16 ,v ,a ,i)) - -(defsetf aref-int16 (a i) (v) - `(aset-int16 ,v ,a ,i)) - -(defsetf aref-card32 (a i) (v) - `(aset-card32 ,v ,a ,i)) - -(defsetf aref-int32 (a i) (v) - `(aset-int32 ,v ,a ,i)) - -(defsetf aref-card29 (a i) (v) - `(aset-card29 ,v ,a ,i)) - -;;; Other random conversions - -(defun rgb-val->card16 (value) - ;; Short floats are good enough - (declare (type rgb-val value)) - (declare (clx-values card16)) - #.(declare-buffun) - ;; Convert VALUE from float to card16 - (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) - -(defun card16->rgb-val (value) - ;; Short floats are good enough - (declare (type card16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - ;; Convert VALUE from card16 to float - (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) - -(defun radians->int16 (value) - ;; Short floats are good enough - (declare (type angle value)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) - -(defun int16->radians (value) - ;; Short floats are good enough - (declare (type int16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) - - -#+(or cmu sbcl) (progn - -;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI -;;; is irrational, there can't be a precise rational representation. In -;;; particular, the different float approximations will always be /=. This -;;; causes problems with type checking, because people might compute an -;;; argument in any precision. What we do is discard all the excess precision -;;; in the value, and see if the protocol encoding falls in the desired range -;;; (64'ths of a degree.) -;;; -(deftype angle () '(satisfies anglep)) - -(defun anglep (x) - (and (typep x 'real) - (<= (* -360 64) (radians->int16 x) (* 360 64)))) - -) - - -;;----------------------------------------------------------------------------- -;; Character transformation -;;----------------------------------------------------------------------------- - - -;;; This stuff transforms chars to ascii codes in card8's and back. -;;; You might have to hack it a little to get it to work for your machine. - -(declaim (inline char->card8 card8->char)) - -(macrolet ((char-translators () - (let ((alist - `(#-lispm - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - ;; One the lispm, #\Newline is #\Return, but we'd really like - ;; #\Newline to translate to ascii code 10, so we swap the - ;; Ascii codes for #\Return and #\Linefeed. We also provide - ;; mappings from the counterparts of these control characters - ;; so that the character mapping from the lisp machine - ;; character set to ascii is invertible. - #+lispm - ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) - (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) - (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) - (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) - (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) - (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) - (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) - (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) - ;; The rest of the common lisp charater set with the normal - ;; ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - #-Genera - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - #-Minima - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - #-Minima - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) - (char-translators)) - -;;----------------------------------------------------------------------------- -;; Process Locking -;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. -;;----------------------------------------------------------------------------- - -;;; MAKE-PROCESS-LOCK: Creating a process lock. - -#+excl -(defun make-process-lock (name) - (mp:make-process-lock :name name)) - -;;; HOLDING-LOCK: Execute a body of code with a lock held. - -;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN -;;; passes its timeout to the holding-lock macro, so any timeout you want to -;;; work for event-listen you should do for holding-lock. - -;; If you're not sharing DISPLAY objects within a multi-processing -;; shared-memory environment, this is sufficient - -;;; HOLDING-LOCK for CMU Common Lisp. -;;; -;;; We are not multi-processing, but we use this macro to try to protect -;;; against re-entering request functions. This can happen if an interrupt -;;; occurs and the handler attempts to use X over the same display connection. -;;; This can happen if the GC hooks are used to notify the user over the same -;;; display connection. We inhibit GC notifications since display of them -;;; could cause recursive entry into CLX. -;;; - -;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. -;;; -#+excl -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) - (unwind-protect - (block .hl-doit. - (when (sys:scheduler-running-p) ; fast test for scheduler running - (setq .hl-lock. ,locator - .hl-curproc. mp::*current-process*) - (when (and .hl-curproc. ; nil if in process-wait fun - (not (eq (mp::process-lock-locker .hl-lock.) - .hl-curproc.))) - ;; Then we need to grab the lock. - ,(if timeout - `(if (not (mp::process-lock .hl-lock. .hl-curproc. - ,whostate ,timeout)) - (return-from .hl-doit. nil)) - `(mp::process-lock .hl-lock. .hl-curproc. - ,@(when whostate `(,whostate)))) - ;; There is an apparent race condition here. However, there is - ;; no actual race condition -- our implementation of mp:process- - ;; lock guarantees that the lock will still be held when it - ;; returns, and no interrupt can happen between that and the - ;; execution of the next form. -- jdi 2/27/91 - (setq .hl-obtained-lock. t))) - ,@body) - (if (and .hl-obtained-lock. - ;; Note -- next form added to allow error handler inside - ;; body to unlock the lock prematurely if it knows that - ;; the current process cannot possibly continue but will - ;; throw out (or is it throw up?). - (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) - (mp::process-unlock .hl-lock. .hl-curproc.))))) - -;;; WITHOUT-ABORTS - -;;; If you can inhibit asynchronous keyboard aborts inside the body of this -;;; macro, then it is a good idea to do this. This macro is wrapped around -;;; request writing and reply reading to ensure that requests are atomically -;;; written and replies are atomically read from the stream. - -#+excl -(defmacro without-aborts (&body body) - `(without-interrupts ,@body)) - -;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. -;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's -;;; value changes. - -#+excl -(defun process-block (whostate predicate &rest predicate-args) - (if (sys:scheduler-running-p) - (apply #'mp::process-wait whostate predicate predicate-args) - (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler.")))) - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -#+excl -(defun process-wakeup (process) - (let ((curproc mp::*current-process*)) - (when (and curproc process) - (unless (mp::process-p curproc) - (error "~s is not a process" curproc)) - (unless (mp::process-p process) - (error "~s is not a process" process)) - (if (> (mp::process-priority process) (mp::process-priority curproc)) - (mp::process-allow-schedule process))))) - - -;;; CURRENT-PROCESS: Return the current process object for input locking and -;;; for calling PROCESS-WAKEUP. - -(declaim (inline current-process)) - -;;; Default return NIL, which is acceptable even if there is a scheduler. - -#+excl -(defun current-process () - (and (sys:scheduler-running-p) - mp::*current-process*)) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. - -;;; CONDITIONAL-STORE: - -;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. -;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. -#-sbcl -(defmacro conditional-store (place old-value new-value) - `(without-interrupts - (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t)))) - -;;;---------------------------------------------------------------------------- -;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. -;;; -;;;---------------------------------------------------------------------------- - -#-Genera -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(unless (buffer-dead ,buffer) - ,@body)) - -#-Genera -(defmacro wrap-buf-input ((buffer) &body body) - (declare (ignore buffer)) - ;; Error recovery wrapper - `(progn ,@body)) - - -;;;---------------------------------------------------------------------------- -;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. -;;;---------------------------------------------------------------------------- - -;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X -;;; server - - -;; -;; Note that since we don't use the CL i/o facilities to do i/o, the display -;; input and output "stream" is really a file descriptor (fixnum). -;; -#+excl -(defun open-x-stream (host display protocol) - (declare (ignore protocol)) ;; assume TCP - (let ((stream (socket:make-socket :remote-host (string host) - :remote-port (+ *x-tcp-port* display) - :format :binary))) - (if (streamp stream) - stream - (error "Cannot connect to server: ~A:~D" host display)))) - - -;;; BUFFER-READ-DEFAULT - read data from the X stream - - -;; -;; Rewritten 10/89 to not use foreign function interface to do I/O. -;; -#+excl -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - - (let* ((howmany (- end start)) - (fd (display-input-stream display))) - (declare (type array-index howmany)) - (or (cond ((fd-char-avail-p fd) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (fd-read-bytes fd vector start howmany)))) - - -;;; WARNING: -;;; CLX performance will suffer if your lisp uses read-byte for -;;; receiving all data from the X Window System server. -;;; You are encouraged to write a specialized version of -;;; buffer-read-default that does block transfers. - - -;;; BUFFER-WRITE-DEFAULT - write data to the X stream - -#+excl -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (unless (null stream) - (write-sequence vector stream :start start :end end))) - ) - -;;; WARNING: -;;; CLX performance will be severely degraded if your lisp uses -;;; write-byte to send all data to the X Window System server. -;;; You are STRONGLY encouraged to write a specialized version -;;; of buffer-write-default that does block transfers. - -;;; buffer-force-output-default - force output to the X stream - -#+excl -(defun buffer-force-output-default (display) - ;; The default buffer force-output function for use with common-lisp streams - (declare (type display display)) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (force-output stream)))) - - -;;; BUFFER-CLOSE-DEFAULT - close the X stream - -#+excl -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (close stream :abort abort)))) - - -;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the -;;; buffer. This is called in read-input between requests, so that a process -;;; waiting for input is abortable when between requests. Should return -;;; :TIMEOUT if it times out, NIL otherwise. - -;;; The default implementation - - -;; -;; This is used so an 'eq' test may be used to find out whether or not we can -;; safely throw this process out of the CLX read loop. -;; -#+excl -(defparameter *read-whostate* "waiting for input from X server") - -;; -;; Note that this function returns nil on error if the scheduler is running, -;; t on error if not. This is ok since buffer-read will detect the error. -;; -#+excl -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((fd (display-input-stream display))) - (when (streamp fd) - (cond ((fd-char-avail-p fd) - nil) - - ;; Otherwise no bytes were available on the socket - ((and timeout (= timeout 0)) - ;; If there aren't enough and timeout == 0, timeout. - :timeout) - - ;; If the scheduler is running let it do timeouts. - ((sys:scheduler-running-p) - (if (not - (mp:wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p - :timeout timeout)) - (return-from buffer-input-wait-default :timeout)) - ) - - ;; Otherwise we have to handle timeouts by hand, and call select() - ;; to block until input is available. Note we don't really handle - ;; the interaction of interrupts and (numberp timeout) here. XX - (t - #+mswindows - (error "scheduler must be running to use CLX on MS Windows") - #-mswindows - (let ((res 0)) - (declare (fixnum res)) - (with-interrupt-checking-on - (loop - (setq res (fd-wait-for-input fd (if (null timeout) 0 - (truncate timeout)))) - (cond ((plusp res) ; success - (return nil)) - ((eq res 0) ; timeout - (return :timeout)) - ((eq res -1) ; error - (return t)) - ;; Otherwise we got an interrupt -- go around again. - ))))))))) - - -;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the -;;; buffer. This should never block, so it can be called from the scheduler. - -;;; The default implementation is to just use listen. -#+excl -#+(and excl clx-use-allegro-streams) -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (if (null stream) - t - (listen stream)))) - -#+(and excl (not clx-use-allegro-streams)) -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((fd (display-input-stream display))) - (declare (type fixnum fd)) - (if (= fd -1) - t - (fd-char-avail-p fd)))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent speed hacks -;;;---------------------------------------------------------------------------- - -;; -;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. -;; If your lisp doesn't have stack-lists, and you're worried about -;; consing garbage, you may want to re-write this to allocate and -;; initialize lists from a resource. -;; -#-lispm -(defmacro with-stack-list ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -#-lispm -(defmacro with-stack-list* ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list* ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -(declaim (inline buffer-replace)) - -#+excl -(defun buffer-replace (target-sequence source-sequence target-start - target-end &optional (source-start 0)) - (declare (type buffer-bytes target-sequence source-sequence) - (type array-index target-start target-end source-start) - (optimize (speed 3) (safety 0))) - - (let ((source-end (length source-sequence))) - (declare (type array-index source-end)) - - (excl:if* (and (eq target-sequence source-sequence) - (> target-start source-start)) - then (let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (do ((target-index (+ target-start nelts -1) (1- target-index)) - (source-index (+ source-start nelts -1) (1- source-index))) - ((= target-index (1- target-start)) target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) - else (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index target-end) (= source-index source-end)) - target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))))) - -#-lispm -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - (let ((local-state (gensym)) - (resets nil)) - (dolist (index indexes) - (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) - `(unwind-protect - (progn - ,@body) - (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state)))) - -;;;---------------------------------------------------------------------------- -;;; How much error detection should CLX do? -;;; Several levels are possible: -;;; -;;; 1. Do the equivalent of check-type on every argument. -;;; -;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format -;;; strings generated by check-type. -;;; -;;; 3. Do error checking only on arguments that are likely to have errors -;;; (like keyword names) -;;; -;;; 4. Do error checking only where not doing so may dammage the envirnment -;;; on a non-tagged machine (i.e. when storing into a structure that has -;;; been passed in) -;;; -;;; 5. No extra error detection code. On lispm's, ASET may barf trying to -;;; store a non-integer into a number array. -;;; -;;; How extensive should the error checking be? For example, if the server -;;; expects a CARD16, is is sufficient for CLX to check for integer, or -;;; should it also check for non-negative and less than 65536? -;;;---------------------------------------------------------------------------- - -;; The +TYPE-CHECK?+ constant controls how much error checking is done. -;; Possible values are: -;; NIL - Don't do any error checking -;; t - Do the equivalent of checktype on every argument -;; :minimal - Do error checking only where errors are likely - -;;; This controls macro expansion, and isn't changable at run-time You will -;;; probably want to set this to nil if you want good performance at -;;; production time. -(defconstant +type-check?+ - #+(or Genera Minima CMU sbcl) nil - #-(or Genera Minima CMU sbcl) t) - -;; TYPE? is used to allow the code to do error checking at a different level from -;; the declarations. It also does some optimizations for systems that don't have -;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. -;; include range checks. You can modify TYPE? to do less extensive checking -;; for these types if you desire. - -;; -;; ### This comment is a lie! TYPE? is really also used for run-time type -;; dispatching, not just type checking. -- Ram. - -(defmacro type? (object type) - #+(or cmu sbcl) - `(typep ,object ,type) - #-(or cmu sbcl) - (if (not (constantp type)) - `(typep ,object ,type) - (progn - (setq type (eval type)) - #+(or Genera explorer Minima) - (if +type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type)) - `(typep ,object ',type)) - #-(or Genera explorer Minima) - (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) - -;; X-TYPE-ERROR is the function called for type errors. -;; If you want lots of checking, but are concerned about code size, -;; this can be made into a macro that ignores some parameters. - -(defun x-type-error (object type &optional error-string) - (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) - - -;;----------------------------------------------------------------------------- -;; Error handlers -;; Hack up KMP error signaling using zetalisp until the real thing comes -;; along -;;----------------------------------------------------------------------------- - -(defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) - (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) - ;; The default display-error-handler. - ;; It signals the conditions listed in the DISPLAY file. - (if asynchronous - (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) - (apply #'x-error error-key :display display :error-key error-key key-vals))) - -#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp)) -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'cerror proceed-format-string condition keyargs)) - -;;; X-ERROR for CMU Common Lisp -;;; -;;; We detect a couple condition types for which we disable event handling in -;;; our system. This prevents going into the debugger or returning to a -;;; command prompt with CLX repeatedly seeing the same condition. This occurs -;;; because CMU Common Lisp provides for all events (that is, X, input on file -;;; descriptors, Mach messages, etc.) to come through one routine anyone can -;;; use to wait for input. -;;; -#+(and CMU (not mp)) -(defun x-error (condition &rest keyargs) - (let ((condx (apply #'make-condition condition keyargs))) - (when (eq condition 'closed-display) - (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) - (error condx))) - -#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(define-condition x-error (error) ()) - - - -;;----------------------------------------------------------------------------- -;; HOST hacking -;;----------------------------------------------------------------------------- - -#+(and allegro-version>= (version>= 5 0)) -(eval-when (compile eval load) - #+(version>= 6 0) - (progn - (require :sock) - #-(version>= 7 0) - (require :gray-compat)) - #-(version>= 6 0) - (require :sock)) - -#+(and allegro-version>= (version>= 5 0)) -(defun host-address (host &optional (family :internet)) - (ecase family - (:internet - (cons :internet - (multiple-value-list - (socket::ipaddr-to-dotted (socket::lookup-hostname host) - :values t)))))) - -#+(and allegro-version>= (not (version>= 5 0))) -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - (let ((hostent 0)) - (unwind-protect - (progn - (setf hostent (ipc::gethostbyname (string host))) - (when (zerop hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (ipc::hostent-addrtype hostent) 2) - (no-address-error)) - (assert (= (ipc::hostent-length hostent) 4)) - (let ((addr (ipc::hostent-addr hostent))) - (when (or (member comp::.target. - '(:hp :sgi4d :sony :dec3100) - :test #'eq) - (probe-file "/lib/ld.so")) - ;; BSD 4.3 based systems require an extra indirection - (setq addr (si:memref-int addr 0 0 :unsigned-long))) - (list :internet - (si:memref-int addr 0 0 :unsigned-byte) - (si:memref-int addr 1 0 :unsigned-byte) - (si:memref-int addr 2 0 :unsigned-byte) - (si:memref-int addr 3 0 :unsigned-byte)))))) - (ff:free-cstruct hostent))))) - - -;;----------------------------------------------------------------------------- -;; Whether to use closures for requests or not. -;;----------------------------------------------------------------------------- - -;;; If this macro expands to non-NIL, then request and locking code is -;;; compiled in a much more compact format, as the common code is shared, and -;;; the specific code is built into a closure that is funcalled by the shared -;;; code. If your compiler makes efficient use of closures then you probably -;;; want to make this expand to T, as it makes the code more compact. - -(defmacro use-closures () - #+(or lispm Minima) t - #-(or lispm Minima) nil) - -#-(or Genera Minima) -(defun clx-macroexpand (form env) - (macroexpand form env)) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; Utilities - -(defun getenv (name) - #+excl (sys:getenv name) - ) - -(defun get-host-name () - "Return the same hostname as gethostname(3) would" - ;; resources-pathname was using short-site-name for this purpose - #+excl (short-site-name) - ) - -(defun homedir-file-pathname (name) - (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) - (merge-pathnames (user-homedir-pathname) (pathname name)))) - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (homedir-file-pathname ".Xdefaults")) - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) - (homedir-file-pathname - (concatenate 'string ".Xdefaults-" (get-host-name))))) - -;;; AUTHORITY-PATHNAME - The pathname of the authority file. - -(defun authority-pathname () - (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) - (homedir-file-pathname ".Xauthority"))) - -;;; this particular defaulting behaviour is typical to most Unices, I think -#+unix -(defun get-default-display (&optional display-name) - "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY -if it is NIL. Display names have the format - - [protocol/] [hostname] : [:] displaynumber [.screennumber] - -There are two special cases in parsing, to match that done in the Xlib -C language bindings - - - If the hostname is ``unix'' or the empty string, any supplied - protocol is ignored and a connection is made using the :local - transport. - - - If a double colon separates hostname from displaynumber, the - protocol is assumed to be decnet. - -Returns a list of (host display-number screen protocol)." - (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) - (list host (or display 0) (or screen 0) protocol))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -(defun gc-cleanup () - (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) - (setq *event-free-list* nil) - (setq *pending-command-free-list* nil) - (when (boundp '*reply-buffer-free-lists*) - (fill *reply-buffer-free-lists* nil)) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil) - nil) - - - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - ) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - - -;;----------------------------------------------------------------------------- -;; DEFAULT-KEYSYM-TRANSLATE -;;----------------------------------------------------------------------------- - -;;; If object is a character, char-bits are set from state. -;;; -;;; [the following isn't implemented (should it be?)] -;;; If object is a list, it is an alist with entries: -;;; (base-char [modifiers] [mask-modifiers]) -;;; When MODIFIERS are specified, this character translation -;;; will only take effect when the specified modifiers are pressed. -;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. -;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. -;;; In ambiguous cases, the most specific translation is used. - -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (clx-values t) - (special left-meta-keysym right-meta-keysym - left-super-keysym right-super-keysym - left-hyper-keysym right-hyper-keysym)) - (when (characterp object) - (when (logbitp (position :control +state-mask-vector+) state) - (setf (char-bit object :control) 1)) - (when (or (state-keysymp display state left-meta-keysym) - (state-keysymp display state right-meta-keysym)) - (setf (char-bit object :meta) 1)) - (when (or (state-keysymp display state left-super-keysym) - (state-keysymp display state right-super-keysym)) - (setf (char-bit object :super) 1)) - (when (or (state-keysymp display state left-hyper-keysym) - (state-keysymp display state right-hyper-keysym)) - (setf (char-bit object :hyper) 1))) - object) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -;;; Types - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - '(unsigned-byte 4)) - -(deftype pixarray-8-element-type () - '(unsigned-byte 8)) - -(deftype pixarray-16-element-type () - '(unsigned-byte 16)) - -(deftype pixarray-24-element-type () - '(unsigned-byte 24)) - -(deftype pixarray-32-element-type () - #-(or Genera Minima) '(unsigned-byte 32) - #+(or Genera Minima) 'fixnum) - -(deftype pixarray-1 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-1-element-type (* *))) - -(deftype pixarray-4 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-4-element-type (* *))) - -(deftype pixarray-8 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-8-element-type (* *))) - -(deftype pixarray-16 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-16-element-type (* *))) - -(deftype pixarray-24 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-24-element-type (* *))) - -(deftype pixarray-32 () - '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) - -(deftype pixarray () - '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) - -(deftype bitmap () - 'pixarray-1) - -;;; WITH-UNDERLYING-SIMPLE-VECTOR - -#+excl -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - `(let ((,variable (cdr (excl::ah_data ,pixarray)))) - (declare (type (simple-array ,element-type (*)) ,variable)) - ,@body)) - -;;; These are used to read and write pixels from and to CARD8s. - -;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. - -(defmacro read-image-load-byte (size position integer) - (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) - `(the (unsigned-byte ,size) - (#-Genera ldb #+Genera sys:%logldb - (byte ,size ,position) - (the card8 ,integer)))) - -;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from -;;; the appropriate number of CARD8s. - -(defmacro read-image-assemble-bytes (&rest bytes) - (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it - `(#-Genera dpb #+Genera sys:%logdpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) - #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) - #+Genera it)) - -;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit -;;; pixel. - -(defmacro write-image-load-byte (position integer integer-size) - integer-size - (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) - `(the card8 - (#-Genera ldb #+Genera sys:%logldb - (byte 8 ,position) - #-Genera (the (unsigned-byte ,integer-size) ,integer) - #+Genera ,integer - ))) - -;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit -;;; pixels. - -(defmacro write-image-assemble-bytes (&rest bytes) - (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it `(#-Genera dpb #+Genera sys:%logdpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) - `(the card8 ,it))) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 - -#+(or Genera lcl3.0 excl) -(defconstant - *image-bit-ordering-table* - '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) - ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) - ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) - ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) - ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) - ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) - -#+(or Genera lcl3.0 excl) -(defun compute-image-byte-and-bit-ordering () - (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) - ;; First compute the ordering - (let ((ordering nil) - (a (make-array '(1 32) :element-type 'bit :initial-element 0))) - (dotimes (i 4) - (push (flet ((bitpos (a i n) - (declare (optimize (speed 3) (safety 0) (space 0))) - (declare (type (simple-array bit (* *)) a) - (type fixnum i n)) - (with-underlying-simple-vector (v (unsigned-byte 8) a) - (prog2 - (setf (aref v i) n) - (dotimes (i 32) - (unless (zerop (aref a 0 i)) - (return i))) - (setf (aref v i) 0))))) - (list (bitpos a i #b10000000) - (bitpos a i #b00000001))) - ordering)) - (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) - ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p - (let ((byte-and-bit-ordering - (second (assoc ordering *image-bit-ordering-table* - :test #'equal)))) - (unless byte-and-bit-ordering - (error "Couldn't determine image byte and bit ordering~@ - measured image ordering = ~A" - ordering)) - (values-list byte-and-bit-ordering)))) - -#+(or Genera lcl3.0 excl) -(multiple-value-setq - (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (compute-image-byte-and-bit-ordering)) - -;;; If you can write fast routines that can read and write pixarrays out of a -;;; buffer-bytes, do it! It makes the image code a lot faster. The -;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines -;;; return T if they can do it, NIL if they can't. - -;;; FIXME: though we have some #+sbcl -conditionalized routines in -;;; here, they would appear not to work, and so are commented out in -;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate -;;; whether the unoptimized routines are often used, and also whether -;;; speeding them up while maintaining correctness is possible. - -;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index (mod (the fixnum (- x)) 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (the fixnum (- (the fixnum (- width left-bits)) - right-bits))) - (middle-bytes (index-floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bytes) - (fixnum middle-bits)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-bits) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (array-row-major-index - array y (index+ left-bits middle-bits)))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref vector (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - t) - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) - 2))) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-nibbles) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - t) - -#+(or Genera lcl3.0 excl CMU sbcl) -(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - t) - -;;; COPY-BIT-RECT -- Internal -;;; -;;; This is the classic BITBLT operation, copying a rectangular subarray -;;; from one array to another (but source and destination must not overlap.) -;;; Widths are specified in bits. Neither array can have a non-zero -;;; displacement. We allow extra random bit-offset to be thrown into the X. -;;; -#+(or Genera lcl3.0 excl) -(defun fast-read-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (x-bits (index* x bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line x-bits)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod x-bits 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod x-bits +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p*) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (dst card8 pixarray) - (funcall - (symbol-function image-swap-function) bbuf dst - (index+ boffset - (index* y padded-bytes-per-line) - (index-floor x-bits 8)) - 0 (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line - (index-floor pixarray-padded-bits-per-line 8) - height image-swap-lsb-first-p))) - t)))) - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-read-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-read-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-read-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-read-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-read-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-read-pixarray-24)))) - (when function - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) - -;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (array-row-major-index - array y (index+ start-x middle-bits)))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (if (index> right-bits 1) - (aref vector (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref vector (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref vector (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref vector (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref vector (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref vector (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)) - (aref vector (index+ x 2)) - (aref vector (index+ x 3)) - (aref vector (index+ x 4)) - (aref vector (index+ x 5)) - (aref vector (index+ x 6)) - (aref vector (index+ x 7)))))))) - t) - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)))))))) - t) - -#+(or Genera lcl3.0 excl CMU sbcl) -(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref vector x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-write-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (src card8 pixarray) - (funcall - (symbol-function image-swap-function) - src bbuf (index-floor pixarray-start-bit-offset 8) boffset - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - padded-bytes-per-line height image-swap-lsb-first-p)) - t))))) - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-write-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-write-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-write-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-write-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-write-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-write-pixarray-24)))) - (when function - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))))) - -;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another - -(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) - (declare (type pixarray pixarray copy) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (progn pixarray copy x y width height bits-per-pixel nil) - (or - #+(or lispm CMU) - (let* ((pixarray-padded-pixels-per-line - #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1)) - (pixarray-padded-bits-per-line - (* pixarray-padded-pixels-per-line bits-per-pixel)) - (copy-padded-pixels-per-line - #+Genera (sys:array-row-span copy) - #-Genera (array-dimension copy 1)) - (copy-padded-bits-per-line - (* copy-padded-pixels-per-line bits-per-pixel))) - #-(or CMU) - (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod pixarray-padded-bits-per-line 32)) - (zerop (index-mod copy-padded-bits-per-line 32))) - (sys:bitblt boole-1 width height pixarray x y copy 0 0) - t) - #+(or CMU) - (when (index= (pixarray-element-size pixarray) - (pixarray-element-size copy) - bits-per-pixel) - (copy-bit-rect pixarray pixarray-padded-bits-per-line x y - copy copy-padded-bits-per-line 0 0 - height - (index* width bits-per-pixel)) - t)) - - #+(or lcl3.0 excl) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (copy-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index copy 1 0) - (array-row-major-index copy 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - copy-padded-bits-per-line pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod copy-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (with-underlying-simple-vector (src card8 pixarray) - (with-underlying-simple-vector (dst card8 copy) - (image-noswap - src dst - (index-floor pixarray-start-bit-offset 8) 0 - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - (index-floor copy-padded-bits-per-line 8) - height nil))) - t))) - #+(or lcl3.0 excl) - (macrolet - ((copy (type element-type) - `(let ((pixarray pixarray) - (copy copy)) - (declare (type ,type pixarray copy)) - #.(declare-buffun) - (with-underlying-simple-vector (src ,element-type pixarray) - (with-underlying-simple-vector (dst ,element-type copy) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-idx (array-row-major-index copy dst-y 0) - (index1+ dst-idx)) - (dst-end (index+ dst-idx width)) - (src-idx (array-row-major-index pixarray src-y x) - (index1+ src-idx))) - ((index>= dst-idx dst-end)) - (declare (type array-index dst-idx src-idx dst-end)) - (setf (aref dst dst-idx) - (the ,element-type (aref src src-idx)))))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))) - t))) diff --git a/src/clx/dep-openmcl.lisp b/src/clx/dep-openmcl.lisp deleted file mode 100644 index bda4e9b41..000000000 --- a/src/clx/dep-openmcl.lisp +++ /dev/null @@ -1,1123 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(proclaim '(declaration array-register)) - - -;;; The size of the output buffer. Must be a multiple of 4. -(defparameter *output-buffer-size* 8192) - -;;; Number of seconds to wait for a reply to a server request -(defparameter *reply-timeout* nil) - -(progn - (defconstant +word-0+ 1) - (defconstant +word-1+ 0) - - (defconstant +long-0+ 3) - (defconstant +long-1+ 2) - (defconstant +long-2+ 1) - (defconstant +long-3+ 0)) - -;;; Set some compiler-options for often used code - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 - "Speed compiler option for buffer code.") - (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 - "Safety compiler option for buffer code.") - (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 - "Debug compiler option for buffer code>") - (defun declare-bufmac () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) - ;; It's my impression that in lucid there's some way to make a - ;; declaration called fast-entry or something that causes a function - ;; to not do some checking on args. Sadly, we have no lucid manuals - ;; here. If such a declaration is available, it would be a good - ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ - ;; is 0. - (defun declare-buffun () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) - -(declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) - -(progn - -(defun card8->int8 (x) - (declare (type card8 x)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - -(defun int8->card8 (x) - (declare (type int8 x)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - -(defun card16->int16 (x) - (declare (type card16 x)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - -(defun int16->card16 (x) - (declare (type int16 x)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - -(defun card32->int32 (x) - (declare (type card32 x)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - -(defun int32->card32 (x) - (declare (type int32 x)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (ldb (byte 32 0) x))) - -) - -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) - -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (aref a i))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (card8->int8 (aref a i))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) (int8->card8 v))) - -) - -(progn - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 - (logior (the card16 - (ash (the card8 (aref a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 - (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 - (logior (the card32 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 - (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 - (logior (the card29 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -) - -(defsetf aref-card8 (a i) (v) - `(aset-card8 ,v ,a ,i)) - -(defsetf aref-int8 (a i) (v) - `(aset-int8 ,v ,a ,i)) - -(defsetf aref-card16 (a i) (v) - `(aset-card16 ,v ,a ,i)) - -(defsetf aref-int16 (a i) (v) - `(aset-int16 ,v ,a ,i)) - -(defsetf aref-card32 (a i) (v) - `(aset-card32 ,v ,a ,i)) - -(defsetf aref-int32 (a i) (v) - `(aset-int32 ,v ,a ,i)) - -(defsetf aref-card29 (a i) (v) - `(aset-card29 ,v ,a ,i)) - -;;; Other random conversions - -(defun rgb-val->card16 (value) - ;; Short floats are good enough - (declare (type rgb-val value)) - (declare (clx-values card16)) - #.(declare-buffun) - ;; Convert VALUE from float to card16 - (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) - -(defun card16->rgb-val (value) - ;; Short floats are good enough - (declare (type card16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - ;; Convert VALUE from card16 to float - (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) - -(defun radians->int16 (value) - ;; Short floats are good enough - (declare (type angle value)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) - -(defun int16->radians (value) - ;; Short floats are good enough - (declare (type int16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) - - -;;----------------------------------------------------------------------------- -;; Character transformation -;;----------------------------------------------------------------------------- - - -;;; This stuff transforms chars to ascii codes in card8's and back. -;;; You might have to hack it a little to get it to work for your machine. - -(declaim (inline char->card8 card8->char)) - -(macrolet ((char-translators () - (let ((alist - `( - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - - ;; The rest of the common lisp charater set with - ;; the normal ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) - (char-translators)) - -;;----------------------------------------------------------------------------- -;; Process Locking -;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. -;;----------------------------------------------------------------------------- - -;;; MAKE-PROCESS-LOCK: Creating a process lock. - -(defun make-process-lock (name) - (ccl:make-lock name)) - -;;; HOLDING-LOCK: Execute a body of code with a lock held. - -;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN -;;; passes its timeout to the holding-lock macro, so any timeout you want to -;;; work for event-listen you should do for holding-lock. - -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore timeout display)) - `(ccl:with-lock-grabbed (,locator ,whostate) - ,@body)) - -;;; WITHOUT-ABORTS - -;;; If you can inhibit asynchronous keyboard aborts inside the body of this -;;; macro, then it is a good idea to do this. This macro is wrapped around -;;; request writing and reply reading to ensure that requests are atomically -;;; written and replies are atomically read from the stream. - -(defmacro without-aborts (&body body) - `(ccl:without-interrupts ,@body)) - -;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. -;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's -;;; value changes. - -(defun process-block (whostate predicate &rest predicate-args) - (declare (dynamic-extern predicate-args)) - (apply #'ccl:process-wait whostate predicate predicate-args)) - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -(defun process-wakeup (process) - (declare (ignore process)) - nil) - -;;; CURRENT-PROCESS: Return the current process object for input locking and -;;; for calling PROCESS-WAKEUP. - -(declaim (inline current-process)) - -;;; Default return NIL, which is acceptable even if there is a scheduler. - -(defun current-process () - ccl::*current-process*) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. - -(defmacro without-interrupts (&body body) - `(ccl:without-interrupts ,@body)) - -;;; CONDITIONAL-STORE: - -;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. -;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. - -(defmacro conditional-store (place old-value new-value) - `(ccl::conditional-store ,place ,old-value ,new-value)) - -;;;---------------------------------------------------------------------------- -;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. -;;; -;;;---------------------------------------------------------------------------- - -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(unless (buffer-dead ,buffer) - ,@body)) - -(defmacro wrap-buf-input ((buffer) &body body) - (declare (ignore buffer)) - ;; Error recovery wrapper - `(progn ,@body)) - - -;;;---------------------------------------------------------------------------- -;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. -;;;---------------------------------------------------------------------------- - -;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X -;;; server - -(defun open-x-stream (host display protocol) - (declare (ignore protocol)) - (let ((local-socket-path (unix-socket-path-from-host host display))) - (if local-socket-path - (ccl::make-socket :connect :active - :address-family :file - :remote-filename local-socket-path) - (ccl::make-socket :connect :active - :remote-host host - :remote-port (+ 6000 display))))) - -;;; BUFFER-READ-DEFAULT - read data from the X stream - -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (progn - (ccl:stream-read-ivector stream vector start (- end start)) - nil)))) - -;;; BUFFER-WRITE-DEFAULT - write data to the X stream - -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (ccl:stream-write-ivector stream vector start (- end start))) - nil)) - -;;; buffer-force-output-default - force output to the X stream - -(defun buffer-force-output-default (display) - ;; The default buffer force-output function for use with common-lisp streams - (declare (type display display)) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (force-output stream)))) - -;;; BUFFER-CLOSE-DEFAULT - close the X stream - -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (close stream :abort abort)))) - -;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the -;;; buffer. This is called in read-input between requests, so that a process -;;; waiting for input is abortable when between requests. Should return -;;; :TIMEOUT if it times out, NIL otherwise. - -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null number) timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - (t - (let* ((fd (ccl::stream-device stream :input)) - (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*))))) - (if (ccl::process-input-wait fd ticks) - nil - :timeout)))))) - - -;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the -;;; buffer. This should never block, so it can be called from the scheduler. - -;;; The default implementation is to just use listen. - -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (if (null stream) - t - (listen stream)))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent speed hacks -;;;---------------------------------------------------------------------------- - -;; -;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. -;; If your lisp doesn't have stack-lists, and you're worried about -;; consing garbage, you may want to re-write this to allocate and -;; initialize lists from a resource. -;; - -(defmacro with-stack-list ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -(defmacro with-stack-list* ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list* ,@elements))) - (declare (type cons ,var) - (dynamic-extent ,var)) - ,@body)) - -(declaim (inline buffer-replace)) - -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - (let ((local-state (gensym)) - (resets nil)) - (dolist (index indexes) - (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) - `(unwind-protect - (progn - ,@body) - (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state)))) - -;;;---------------------------------------------------------------------------- -;;; How much error detection should CLX do? -;;; Several levels are possible: -;;; -;;; 1. Do the equivalent of check-type on every argument. -;;; -;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format -;;; strings generated by check-type. -;;; -;;; 3. Do error checking only on arguments that are likely to have errors -;;; (like keyword names) -;;; -;;; 4. Do error checking only where not doing so may dammage the envirnment -;;; on a non-tagged machine (i.e. when storing into a structure that has -;;; been passed in) -;;; -;;; 5. No extra error detection code. On lispm's, ASET may barf trying to -;;; store a non-integer into a number array. -;;; -;;; How extensive should the error checking be? For example, if the server -;;; expects a CARD16, is is sufficient for CLX to check for integer, or -;;; should it also check for non-negative and less than 65536? -;;;---------------------------------------------------------------------------- - -;; The +TYPE-CHECK?+ constant controls how much error checking is done. -;; Possible values are: -;; NIL - Don't do any error checking -;; t - Do the equivalent of checktype on every argument -;; :minimal - Do error checking only where errors are likely - -;;; This controls macro expansion, and isn't changable at run-time You will -;;; probably want to set this to nil if you want good performance at -;;; production time. -(defconstant +type-check?+ nil) - -;; TYPE? is used to allow the code to do error checking at a different level from -;; the declarations. It also does some optimizations for systems that don't have -;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. -;; include range checks. You can modify TYPE? to do less extensive checking -;; for these types if you desire. - -;; -;; ### This comment is a lie! TYPE? is really also used for run-time type -;; dispatching, not just type checking. -- Ram. - -(defmacro type? (object type) - (if (not (constantp type)) - `(typep ,object ,type) - (progn - (setq type (eval type)) - (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) - -;; X-TYPE-ERROR is the function called for type errors. -;; If you want lots of checking, but are concerned about code size, -;; this can be made into a macro that ignores some parameters. - -(defun x-type-error (object type &optional error-string) - (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) - - -;;----------------------------------------------------------------------------- -;; Error handlers -;; Hack up KMP error signaling using zetalisp until the real thing comes -;; along -;;----------------------------------------------------------------------------- - -(defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) - (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) - ;; The default display-error-handler. - ;; It signals the conditions listed in the DISPLAY file. - (if asynchronous - (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) - (apply #'x-error error-key :display display :error-key error-key key-vals))) - -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'cerror proceed-format-string condition keyargs)) - - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -(define-condition x-error (error) ()) - - -;;----------------------------------------------------------------------------- -;; HOST hacking -;;----------------------------------------------------------------------------- - -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (ecase family - ((:internet nil 0) - (let* ((addr (ccl::host-as-inet-host host))) - (cons :internet (list - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))))))) - - -;;----------------------------------------------------------------------------- -;; Whether to use closures for requests or not. -;;----------------------------------------------------------------------------- - -;;; If this macro expands to non-NIL, then request and locking code is -;;; compiled in a much more compact format, as the common code is shared, and -;;; the specific code is built into a closure that is funcalled by the shared -;;; code. If your compiler makes efficient use of closures then you probably -;;; want to make this expand to T, as it makes the code more compact. - -(defmacro use-closures () nil) - -(defun clx-macroexpand (form env) - (macroexpand form env)) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; Utilities - -(defun getenv (name) - (ccl::getenv name)) - -(defun get-host-name () - "Return the same hostname as gethostname(3) would" - (machine-instance)) - -(defun homedir-file-pathname (name) - (merge-pathnames (user-homedir-pathname) (pathname name))) - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (homedir-file-pathname ".Xdefaults")) - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) - (homedir-file-pathname - (concatenate 'string ".Xdefaults-" (get-host-name))))) - -;;; AUTHORITY-PATHNAME - The pathname of the authority file. - -(defun authority-pathname () - (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) - (homedir-file-pathname ".Xauthority"))) - -;;; this particular defaulting behaviour is typical to most Unices, I think - -(defun get-default-display (&optional display-name) - "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY -if it is NIL. Display names have the format - - [protocol/] [hostname] : [:] displaynumber [.screennumber] - -There are two special cases in parsing, to match that done in the Xlib -C language bindings - - - If the hostname is ``unix'' or the empty string, any supplied - protocol is ignored and a connection is made using the :local - transport. - - - If a double colon separates hostname from displaynumber, the - protocol is assumed to be decnet. - -Returns a list of (host display-number screen protocol)." - (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) - (list host (or display 0) (or screen 0) protocol))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -(defun gc-cleanup () - (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) - (setq *event-free-list* nil) - (setq *pending-command-free-list* nil) - (when (boundp '*reply-buffer-free-lists*) - (fill *reply-buffer-free-lists* nil)) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil) - nil) - - -;;----------------------------------------------------------------------------- -;; DEFAULT-KEYSYM-TRANSLATE -;;----------------------------------------------------------------------------- - -;;; If object is a character, char-bits are set from state. -;;; -;;; [the following isn't implemented (should it be?)] -;;; If object is a list, it is an alist with entries: -;;; (base-char [modifiers] [mask-modifiers]) -;;; When MODIFIERS are specified, this character translation -;;; will only take effect when the specified modifiers are pressed. -;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. -;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. -;;; In ambiguous cases, the most specific translation is used. - -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (ignore display state) - (clx-values t)) - object) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -;;; Types - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - '(unsigned-byte 4)) - -(deftype pixarray-8-element-type () - '(unsigned-byte 8)) - -(deftype pixarray-16-element-type () - '(unsigned-byte 16)) - -(deftype pixarray-24-element-type () - '(unsigned-byte 24)) - -(deftype pixarray-32-element-type () - '(unsigned-byte 32)) - -(deftype pixarray-1 () - '(array pixarray-1-element-type (* *))) - -(deftype pixarray-4 () - '(array pixarray-4-element-type (* *))) - -(deftype pixarray-8 () - '(array pixarray-8-element-type (* *))) - -(deftype pixarray-16 () - '(array pixarray-16-element-type (* *))) - -(deftype pixarray-24 () - '(array pixarray-24-element-type (* *))) - -(deftype pixarray-32 () - '(array pixarray-32-element-type (* *))) - -(deftype pixarray () - '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) - -(deftype bitmap () - 'pixarray-1) - -;;; WITH-UNDERLYING-SIMPLE-VECTOR - -(defmacro with-underlying-simple-vector ((variable element-type pixarray) - &body body) - (declare (ignore element-type)) - `(let* ((,variable (ccl::array-data-and-offset ,pixarray))) - ,@body)) - -;;; These are used to read and write pixels from and to CARD8s. - -;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. - -(defmacro read-image-load-byte (size position integer) - (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) - `(the (unsigned-byte ,size) - (ldb - (byte ,size ,position) - (the card8 ,integer)))) - -;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from -;;; the appropriate number of CARD8s. - -(defmacro read-image-assemble-bytes (&rest bytes) - (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it - `(dpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) - `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) - -;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit -;;; pixel. - -(defmacro write-image-load-byte (position integer integer-size) - integer-size - (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) - `(the card8 - (ldb - (byte 8 ,position) - (the (unsigned-byte ,integer-size) ,integer)))) - -;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit -;;; pixels. - -(defmacro write-image-assemble-bytes (&rest bytes) - (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it `(dpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) - `(the card8 ,it))) - - -;;; If you can write fast routines that can read and write pixarrays out of a -;;; buffer-bytes, do it! It makes the image code a lot faster. The -;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines -;;; return T if they can do it, NIL if they can't. - -;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (ignore bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel unit - byte-lsb-first-p bit-lsb-first-p)) - nil) - -;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (ignore bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel unit - byte-lsb-first-p bit-lsp-first-p)) - nil) - -;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another - -(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) - (declare (ignore pixarray copy x y width height bits-per-pixel)) - nil) diff --git a/src/clx/depdefs.lisp b/src/clx/depdefs.lisp deleted file mode 100644 index 18a6ff001..000000000 --- a/src/clx/depdefs.lisp +++ /dev/null @@ -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-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))) diff --git a/src/clx/dependent.lisp b/src/clx/dependent.lisp deleted file mode 100644 index 7e4166c07..000000000 --- a/src/clx/dependent.lisp +++ /dev/null @@ -1,4097 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(proclaim '(declaration array-register)) - -#+cmu -(setf (getf ext:*herald-items* :xlib) - `(" CLX X Library " ,*version*)) - - -;;; The size of the output buffer. Must be a multiple of 4. -(defparameter *output-buffer-size* 8192) - -#+explorer -(zwei:define-indentation event-case (1 1)) - -;;; Number of seconds to wait for a reply to a server request -(defparameter *reply-timeout* nil) - -#-(or clx-overlapping-arrays (not clx-little-endian)) -(progn - (defconstant +word-0+ 0) - (defconstant +word-1+ 1) - - (defconstant +long-0+ 0) - (defconstant +long-1+ 1) - (defconstant +long-2+ 2) - (defconstant +long-3+ 3)) - -#-(or clx-overlapping-arrays clx-little-endian) -(progn - (defconstant +word-0+ 1) - (defconstant +word-1+ 0) - - (defconstant +long-0+ 3) - (defconstant +long-1+ 2) - (defconstant +long-2+ 1) - (defconstant +long-3+ 0)) - -;;; Set some compiler-options for often used code - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 - "Speed compiler option for buffer code.") - (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 - "Safety compiler option for buffer code.") - (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 - "Debug compiler option for buffer code>") - (defun declare-bufmac () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) - ;; It's my impression that in lucid there's some way to make a - ;; declaration called fast-entry or something that causes a function - ;; to not do some checking on args. Sadly, we have no lucid manuals - ;; here. If such a declaration is available, it would be a good - ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ - ;; is 0. - (defun declare-buffun () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) - -(declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) - -#-Genera -(progn - -(defun card8->int8 (x) - (declare (type card8 x)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - -(defun int8->card8 (x) - (declare (type int8 x)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - -(defun card16->int16 (x) - (declare (type card16 x)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - -(defun int16->card16 (x) - (declare (type int16 x)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - -(defun card32->int32 (x) - (declare (type card32 x)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - -(defun int32->card32 (x) - (declare (type int32 x)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (ldb (byte 32 0) x))) - -) - -#+Genera -(progn - -(defun card8->int8 (x) - (declare lt:(side-effects simple reducible)) - (if (logbitp 7 x) (- x #x100) x)) - -(defun int8->card8 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 8 0) x)) - -(defun card16->int16 (x) - (declare lt:(side-effects simple reducible)) - (if (logbitp 15 x) (- x #x10000) x)) - -(defun int16->card16 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 16 0) x)) - -(defun card32->int32 (x) - (declare lt:(side-effects simple reducible)) - (sys:%logldb (byte 32 0) x)) - -(defun int32->card32 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 32 0) x)) - -) - -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) - -#-(or Genera lcl3.0 excl) -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (aref a i))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (card8->int8 (aref a i))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) (int8->card8 v))) - -) - -#+Genera -(progn - -(defun aref-card8 (a i) - (aref a i)) - -(defun aset-card8 (v a i) - (zl:aset v a i)) - -(defun aref-int8 (a i) - (card8->int8 (aref a i))) - -(defun aset-int8 (v a i) - (zl:aset (int8->card8 v) a i)) - -) - -#+(or excl lcl3.0 clx-overlapping-arrays) -(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 - aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) - -#+(and clx-overlapping-arrays Genera) -(progn - -(defun aref-card16 (a i) - (aref a i)) - -(defun aset-card16 (v a i) - (zl:aset v a i)) - -(defun aref-int16 (a i) - (card16->int16 (aref a i))) - -(defun aset-int16 (v a i) - (zl:aset (int16->card16 v) a i) - v) - -(defun aref-card32 (a i) - (int32->card32 (aref a i))) - -(defun aset-card32 (v a i) - (zl:aset (card32->int32 v) a i)) - -(defun aref-int32 (a i) (aref a i)) - -(defun aset-int32 (v a i) - (zl:aset v a i)) - -(defun aref-card29 (a i) - (aref a i)) - -(defun aset-card29 (v a i) - (zl:aset v a i)) - -) - -#+(and clx-overlapping-arrays (not Genera)) -(progn - -(defun aref-card16 (a i) - (aref a i)) - -(defun aset-card16 (v a i) - (setf (aref a i) v)) - -(defun aref-int16 (a i) - (card16->int16 (aref a i))) - -(defun aset-int16 (v a i) - (setf (aref a i) (int16->card16 v)) - v) - -(defun aref-card32 (a i) - (aref a i)) - -(defun aset-card32 (v a i) - (setf (aref a i) v)) - -(defun aref-int32 (a i) - (card32->int32 (aref a i))) - -(defun aset-int32 (v a i) - (setf (aref a i) (int32->card32 v)) - v) - -(defun aref-card29 (a i) - (aref a i)) - -(defun aset-card29 (v a i) - (setf (aref a i) v)) - -) - -#+excl -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-byte))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-byte) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-byte))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-byte) v)) - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-word))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-word) v)) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-word))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-word) v)) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long) v)) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-long))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-long) v)) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long) v)) - -) - -#+lcl3.0 -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card8)) - #.(declare-buffun) - (the card8 (lucid::%svref-8bit a i))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-8bit a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int8)) - #.(declare-buffun) - (the int8 (lucid::%svref-signed-8bit a i))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-8bit a i) v)) - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card16)) - #.(declare-buffun) - (the card16 (lucid::%svref-16bit a (index-ash i -1)))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-16bit a (index-ash i -1)) v)) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int16)) - #.(declare-buffun) - (the int16 (lucid::%svref-signed-16bit a (index-ash i -1)))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v)) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card32)) - #.(declare-buffun) - (the card32 (lucid::%svref-32bit a (index-ash i -2)))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-32bit a (index-ash i -2)) v)) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int32)) - #.(declare-buffun) - (the int32 (lucid::%svref-signed-32bit a (index-ash i -2)))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v)) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card29)) - #.(declare-buffun) - (the card29 (lucid::%svref-32bit a (index-ash i -2)))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-32bit a (index-ash i -2)) v)) - -) - - - -#-(or excl lcl3.0 clx-overlapping-arrays) -(progn - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 - (logior (the card16 - (ash (the card8 (aref a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 - (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 - (logior (the card32 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 - (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 - (logior (the card29 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -) - -(defsetf aref-card8 (a i) (v) - `(aset-card8 ,v ,a ,i)) - -(defsetf aref-int8 (a i) (v) - `(aset-int8 ,v ,a ,i)) - -(defsetf aref-card16 (a i) (v) - `(aset-card16 ,v ,a ,i)) - -(defsetf aref-int16 (a i) (v) - `(aset-int16 ,v ,a ,i)) - -(defsetf aref-card32 (a i) (v) - `(aset-card32 ,v ,a ,i)) - -(defsetf aref-int32 (a i) (v) - `(aset-int32 ,v ,a ,i)) - -(defsetf aref-card29 (a i) (v) - `(aset-card29 ,v ,a ,i)) - -;;; Other random conversions - -(defun rgb-val->card16 (value) - ;; Short floats are good enough - (declare (type rgb-val value)) - (declare (clx-values card16)) - #.(declare-buffun) - ;; Convert VALUE from float to card16 - (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) - -(defun card16->rgb-val (value) - ;; Short floats are good enough - (declare (type card16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - ;; Convert VALUE from card16 to float - (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) - -(defun radians->int16 (value) - ;; Short floats are good enough - (declare (type angle value)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) - -(defun int16->radians (value) - ;; Short floats are good enough - (declare (type int16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) - - -#+(or cmu sbcl clisp ecl) (progn - -;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI -;;; is irrational, there can't be a precise rational representation. In -;;; particular, the different float approximations will always be /=. This -;;; causes problems with type checking, because people might compute an -;;; argument in any precision. What we do is discard all the excess precision -;;; in the value, and see if the protocol encoding falls in the desired range -;;; (64'ths of a degree.) -;;; -(deftype angle () '(satisfies anglep)) - -(defun anglep (x) - (and (typep x 'real) - (<= (* -360 64) (radians->int16 x) (* 360 64)))) - -) - - -;;----------------------------------------------------------------------------- -;; Character transformation -;;----------------------------------------------------------------------------- - - -;;; This stuff transforms chars to ascii codes in card8's and back. -;;; You might have to hack it a little to get it to work for your machine. - -(declaim (inline char->card8 card8->char)) - -(macrolet ((char-translators () - (let ((alist - `(#-lispm - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - ;; One the lispm, #\Newline is #\Return, but we'd really like - ;; #\Newline to translate to ascii code 10, so we swap the - ;; Ascii codes for #\Return and #\Linefeed. We also provide - ;; mappings from the counterparts of these control characters - ;; so that the character mapping from the lisp machine - ;; character set to ascii is invertible. - #+lispm - ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) - (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) - (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) - (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) - (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) - (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) - (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) - (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) - ;; The rest of the common lisp charater set with the normal - ;; ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - #-Genera - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - #-Minima - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - #-Minima - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) - (char-translators)) - -;;----------------------------------------------------------------------------- -;; Process Locking -;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. -;;----------------------------------------------------------------------------- - -;;; MAKE-PROCESS-LOCK: Creating a process lock. - -#-(or LispM excl Minima sbcl (and cmu mp) (and ecl threads)) -(defun make-process-lock (name) - (declare (ignore name)) - nil) - -#+excl -(defun make-process-lock (name) - (mp:make-process-lock :name name)) - -#+(and LispM (not Genera)) -(defun make-process-lock (name) - (vector nil name)) - -#+Genera -(defun make-process-lock (name) - (process:make-lock name :flavor 'clx-lock)) - -#+Minima -(defun make-process-lock (name) - (minima:make-lock name :recursive t)) - -#+(and cmu mp) -(defun make-process-lock (name) - (mp:make-lock name)) - -#+sbcl -(defun make-process-lock (name) - (sb-thread:make-mutex :name name)) - -#+(and ecl threads) -(defun make-process-lock (name) - (mp:make-lock :name name :recursive t)) - -;;; HOLDING-LOCK: Execute a body of code with a lock held. - -;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN -;;; passes its timeout to the holding-lock macro, so any timeout you want to -;;; work for event-listen you should do for holding-lock. - -;; If you're not sharing DISPLAY objects within a multi-processing -;; shared-memory environment, this is sufficient -#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) (and ecl threads)) -(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) - (declare (ignore locator display whostate timeout)) - `(progn ,@body)) - -;;; HOLDING-LOCK for CMU Common Lisp. -;;; -;;; We are not multi-processing, but we use this macro to try to protect -;;; against re-entering request functions. This can happen if an interrupt -;;; occurs and the handler attempts to use X over the same display connection. -;;; This can happen if the GC hooks are used to notify the user over the same -;;; display connection. We inhibit GC notifications since display of them -;;; could cause recursive entry into CLX. -;;; -#+(and CMU (not mp)) -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - `(let #+cmu((ext:*gc-verbose* nil) - (ext:*gc-inhibit-hook* nil) - (ext:*before-gc-hooks* nil) - (ext:*after-gc-hooks* nil)) - #+sbcl() - ,locator ,display ,whostate ,timeout - (system:without-interrupts (progn ,@body)))) - -;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. -;;; -#+(and cmu mp) -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - (declare (ignore display)) - `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout))) - ,@body)) - -#+clisp -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - (declare (ignore lock display whostate timeout)) - `(progn - ,@body)) - -#+(and ecl threads) -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - (declare (ignore display)) - `(mp::with-lock (,lock) - ,@body)) - -#+sbcl -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - ;; This macro is used by WITH-DISPLAY, which claims to be callable - ;; recursively. So, had better use a recursive lock. - ;; - ;; FIXME: This is hideously ugly. If WITH-TIMEOUT handled NIL - ;; timeouts... - (declare (ignore display whostate)) - (if timeout - `(if ,timeout - (handler-case - (sb-ext:with-timeout ,timeout - (sb-thread:with-recursive-lock (,lock) - ,@body)) - (sb-ext:timeout () nil)) - (sb-thread:with-recursive-lock (,lock) - ,@body)) - `(sb-thread:with-recursive-lock (,lock) - ,@body))) - -#+Genera -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore whostate)) - `(process:with-lock (,locator :timeout ,timeout) - (let ((.debug-io. (buffer-debug-io ,display))) - (scl:let-if .debug-io. ((*debug-io* .debug-io.)) - ,@body)))) - -#+(and lispm (not Genera)) -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - ;; This macro is for use in a multi-process environment. - (let ((lock (gensym)) - (have-lock (gensym)) - (timeo (gensym))) - `(let* ((,lock (zl:locf (svref ,locator 0))) - (,have-lock (eq (car ,lock) sys:current-process)) - (,timeo ,timeout)) - (unwind-protect - (when (cond (,have-lock) - ((#+explorer si:%store-conditional - #-explorer sys:store-conditional - ,lock nil sys:current-process)) - ((null ,timeo) - (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) - ((sys:process-wait-with-timeout - ,(or whostate "CLX Lock") (round (* ,timeo 60.)) - #'(lambda (lock process) - (#+explorer si:%store-conditional - #-explorer sys:store-conditional - lock nil process)) - ,lock sys:current-process))) - ,@body) - (unless ,have-lock - (#+explorer si:%store-conditional - #-explorer sys:store-conditional - ,lock sys:current-process nil)))))) - -;; Lucid has a process locking mechanism as well under release 3.0 -#+lcl3.0 -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - (if timeout - ;; Hair to support timeout. - `(let ((.have-lock. (eq ,locator lcl:*current-process*)) - (.timeout. ,timeout)) - (unwind-protect - (when (cond (.have-lock.) - ((conditional-store ,locator nil lcl:*current-process*)) - ((null .timeout.) - (lcl:process-lock ,locator) - t) - ((lcl:process-wait-with-timeout ,whostate .timeout. - #'(lambda () - (conditional-store ,locator nil lcl:*current-process*)))) - ;; abort the PROCESS-UNLOCK if actually timing out - (t - (setf .have-lock. :abort) - nil)) - ,@body) - (unless .have-lock. - (lcl:process-unlock ,locator)))) - `(lcl:with-process-lock (,locator) - ,@body))) - - -#+excl -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) - (unwind-protect - (block .hl-doit. - (when mp::*scheduler-stack-group* ; fast test for scheduler running - (setq .hl-lock. ,locator - .hl-curproc. mp::*current-process*) - (when (and .hl-curproc. ; nil if in process-wait fun - (not (eq (mp::process-lock-locker .hl-lock.) - .hl-curproc.))) - ;; Then we need to grab the lock. - ,(if timeout - `(if (not (mp::process-lock .hl-lock. .hl-curproc. - ,whostate ,timeout)) - (return-from .hl-doit. nil)) - `(mp::process-lock .hl-lock. .hl-curproc. - ,@(when whostate `(,whostate)))) - ;; There is an apparent race condition here. However, there is - ;; no actual race condition -- our implementation of mp:process- - ;; lock guarantees that the lock will still be held when it - ;; returns, and no interrupt can happen between that and the - ;; execution of the next form. -- jdi 2/27/91 - (setq .hl-obtained-lock. t))) - ,@body) - (if (and .hl-obtained-lock. - ;; Note -- next form added to allow error handler inside - ;; body to unlock the lock prematurely if it knows that - ;; the current process cannot possibly continue but will - ;; throw out (or is it throw up?). - (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) - (mp::process-unlock .hl-lock. .hl-curproc.))))) - -#+Minima -(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) - `(holding-lock-1 #'(lambda () ,@body) ,locator ,display - ,@(and whostate `(:whostate ,whostate)) - ,@(and timeout `(:timeout ,timeout)))) - -#+Minima -(defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout) - (declare (dynamic-extent continuation)) - (declare (ignore display whostate timeout)) - (minima:with-lock (lock) - (funcall continuation))) - -;;; WITHOUT-ABORTS - -;;; If you can inhibit asynchronous keyboard aborts inside the body of this -;;; macro, then it is a good idea to do this. This macro is wrapped around -;;; request writing and reply reading to ensure that requests are atomically -;;; written and replies are atomically read from the stream. - -#-(or Genera excl lcl3.0) -(defmacro without-aborts (&body body) - `(progn ,@body)) - -#+Genera -(defmacro without-aborts (&body body) - `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") - ,@body)) - -#+excl -(defmacro without-aborts (&body body) - `(without-interrupts ,@body)) - -#+lcl3.0 -(defmacro without-aborts (&body body) - `(lcl:with-interruptions-inhibited ,@body)) - -;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. -;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's -;;; value changes. - -#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp) (and ecl threads)) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler."))) - -#+Genera -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) - (apply #'process:block-process whostate predicate predicate-args)) - -#+(and lispm (not Genera)) -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) - (apply #'global:process-wait whostate predicate predicate-args)) - -#+excl -(defun process-block (whostate predicate &rest predicate-args) - (if mp::*scheduler-stack-group* - (apply #'mp::process-wait whostate predicate predicate-args) - (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler.")))) - -#+lcl3.0 -(defun process-block (whostate predicate &rest predicate-args) - (declare (dynamic-extent predicate-args)) - (apply #'lcl:process-wait whostate predicate predicate-args)) - -#+Minima -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - (dynamic-extent predicate)) - (apply #'minima:process-wait whostate predicate predicate-args)) - -#+(and cmu mp) -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate)) - (mp:process-wait whostate #'(lambda () - (apply predicate predicate-args)))) - -#+(and sbcl sb-thread) -(progn - (declaim (inline yield)) - (defun yield () - (declare (optimize speed (safety 0))) - (sb-alien:alien-funcall - (sb-alien:extern-alien "sched_yield" (function sb-alien:int))) - (values))) - -#+(and sbcl sb-thread) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (declare (type function predicate)) - (loop - (when (apply predicate predicate-args) - (return)) - (yield))) - -#+(and ecl threads) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (declare (type function predicate)) - (loop - (when (apply predicate predicate-args) - (return)) - (mp:process-yield))) - -;;; FIXME: the below implementation for threaded PROCESS-BLOCK using -;;; queues and condition variables might seem better, but in fact it -;;; turns out to make performance extremely suboptimal, at least as -;;; measured by McCLIM on linux 2.4 kernels. -- CSR, 2003-11-10 -#+(or) -(defvar *process-conditions* (make-hash-table)) - -#+(or) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (declare (type function predicate)) - (let* ((pid (sb-thread:current-thread-id)) - (last (gethash pid *process-conditions*)) - (lock - (or (car last) - (sb-thread:make-mutex :name (format nil "lock ~A" pid)))) - (queue - (or (cdr last) - (sb-thread:make-waitqueue :name (format nil "queue ~A" pid))))) - (unless last - (setf (gethash pid *process-conditions*) (cons lock queue))) - (sb-thread:with-mutex (lock) - (loop - (when (apply predicate predicate-args) (return)) - (handler-case - (sb-ext:with-timeout .5 - (sb-thread:condition-wait queue lock)) - (sb-ext:timeout () - (format *trace-output* "thread ~A, process-block timed out~%" - (sb-thread:current-thread-id) ))))))) - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp) (and ecl threads)) -(defun process-wakeup (process) - (declare (ignore process)) - nil) - -#+excl -(defun process-wakeup (process) - (let ((curproc mp::*current-process*)) - (when (and curproc process) - (unless (mp::process-p curproc) - (error "~s is not a process" curproc)) - (unless (mp::process-p process) - (error "~s is not a process" process)) - (if (> (mp::process-priority process) (mp::process-priority curproc)) - (mp::process-allow-schedule process))))) - -#+Genera -(defun process-wakeup (process) - (process:wakeup process)) - -#+Minima -(defun process-wakeup (process) - (when process - (minima:process-wakeup process))) - -#+(and cmu mp) -(defun process-wakeup (process) - (declare (ignore process)) - (mp:process-yield)) - -#+(and sb-thread sbcl) -(defun process-wakeup (process) - (declare (ignore process)) - (yield)) - -#+(and ecl threads) -(defun process-wakeup (process) - (declare (ignore process)) - (mp:process-yield)) - -#+(or) -(defun process-wakeup (process) - (declare (ignore process)) - (destructuring-bind (lock . queue) - (gethash (sb-thread:current-thread-id) *process-conditions* - (cons nil nil)) - (declare (ignore lock)) - (when queue - (sb-thread:condition-notify queue)))) - - -;;; CURRENT-PROCESS: Return the current process object for input locking and -;;; for calling PROCESS-WAKEUP. - -(declaim (inline current-process)) - -;;; Default return NIL, which is acceptable even if there is a scheduler. - -#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp) (and ecl threads)) -(defun current-process () - nil) - -#+lispm -(defun current-process () - sys:current-process) - -#+excl -(defun current-process () - (and mp::*scheduler-stack-group* - mp::*current-process*)) - -#+lcl3.0 -(defun current-process () - lcl:*current-process*) - -#+Minima -(defun current-process () - (minima:current-process)) - -#+(or (and cmu mp) (and ecl threads)) -(defun current-process () - mp:*current-process*) - -#+sbcl -(defun current-process () - sb-thread:*current-thread*) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. - -#-(or lispm excl lcl3.0 Minima cmu) -(defmacro without-interrupts (&body body) - `(progn ,@body)) - -#+(and lispm (not Genera)) -(defmacro without-interrupts (&body body) - `(sys:without-interrupts ,@body)) - -#+Genera -(defmacro without-interrupts (&body body) - `(process:with-no-other-processes ,@body)) - -#+LCL3.0 -(defmacro without-interrupts (&body body) - `(lcl:with-scheduling-inhibited ,@body)) - -#+Minima -(defmacro without-interrupts (&body body) - `(minima:with-no-other-processes ,@body)) - -#+cmu -(defmacro without-interrupts (&body body) - `(system:without-interrupts ,@body)) - -#+ecl -(defmacro without-interrupts (&body body) - `(mp:without-interrupts ,@body)) - -#+sbcl -(defvar *without-interrupts-sic-lock* - (sb-thread:make-mutex :name "lock simulating *without-interrupts*")) -#+sbcl -(defmacro without-interrupts (&body body) - `(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*) - ,@body)) - -;;; CONDITIONAL-STORE: - -;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. -;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. -#-sbcl -(defmacro conditional-store (place old-value new-value) - `(without-interrupts - (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t)))) - -#+sbcl -(progn - (defvar *conditional-store-lock* - (sb-thread:make-mutex :name "conditional store")) - (defmacro conditional-store (place old-value new-value) - `(sb-thread:with-mutex (*conditional-store-lock*) - (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t))))) - -;;;---------------------------------------------------------------------------- -;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. -;;; -;;;---------------------------------------------------------------------------- - -#-Genera -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(unless (buffer-dead ,buffer) - ,@body)) - -#+Genera -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(let ((.buffer. ,buffer)) - (unless (buffer-dead .buffer.) - (scl:condition-bind - (((sys:network-error) - #'(lambda (error) - (scl:condition-case () - (funcall (buffer-close-function .buffer.) .buffer. :abort t) - (sys:network-error)) - (setf (buffer-dead .buffer.) error) - (setf (buffer-output-stream .buffer.) nil) - (setf (buffer-input-stream .buffer.) nil) - nil))) - ,@body)))) - -#-Genera -(defmacro wrap-buf-input ((buffer) &body body) - (declare (ignore buffer)) - ;; Error recovery wrapper - `(progn ,@body)) - -#+Genera -(defmacro wrap-buf-input ((buffer) &body body) - ;; Error recovery wrapper - `(let ((.buffer. ,buffer)) - (scl:condition-bind - (((sys:network-error) - #'(lambda (error) - (scl:condition-case () - (funcall (buffer-close-function .buffer.) .buffer. :abort t) - (sys:network-error)) - (setf (buffer-dead .buffer.) error) - (setf (buffer-output-stream .buffer.) nil) - (setf (buffer-input-stream .buffer.) nil) - nil))) - ,@body))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. -;;;---------------------------------------------------------------------------- - -;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X -;;; server - -#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp) -(defun open-x-stream (host display protocol) - host display protocol ;; unused - (error "OPEN-X-STREAM not implemented yet.")) - -#+clisp -(defun open-x-stream (host display protocol) - (declare (ignore protocol) - (type (integer 0) display)) - (let ((socket - ;; are we dealing with a localhost? - (when (or (string= host "") - (string= host "unix")) - ;; ok, try to connect to a AF_UNIX domain socket - (sys::make-socket-stream "" display)))) - (if socket - socket - ;; try to connect by hand - (let ((host (host-address host))) - (when host - ;; Fixme: get a descent ip standard in CLX: a vector! - (let ((ip (format nil - "~{~D~^.~}" - (rest host)))) - (socket:socket-connect (+ 6000 display) ip - :element-type '(unsigned-byte 8)))))))) - - -;;; Genera: - -;;; TCP and DNA are both layered products, so try to work with either one. - -#+Genera -(when (fboundp 'tcp:add-tcp-port-for-protocol) - (tcp:add-tcp-port-for-protocol :x-window-system 6000)) - -#+Genera -(when (fboundp 'dna:add-dna-contact-id-for-protocol) - (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0")) - -#+Genera -(net:define-protocol :x-window-system (:x-window-system :byte-stream) - (:invoke-with-stream ((stream :characters nil :ascii-translation nil)) - stream)) - -#+Genera -(eval-when (compile) - (compiler:function-defined 'tcp:open-tcp-stream) - (compiler:function-defined 'dna:open-dna-bidirectional-stream)) - -#+Genera -(defun open-x-stream (host display protocol) - (let ((host (net:parse-host host))) - (if (or protocol (plusp display)) - ;; The protocol was specified or the display isn't 0, so we - ;; can't use the Generic Network System. If the protocol was - ;; specified, then use that protocol, otherwise, blindly use - ;; TCP. - (ccase protocol - ((:tcp nil) - (tcp:open-tcp-stream - host (+ *x-tcp-port* display) nil - :direction :io - :characters nil - :ascii-translation nil)) - ((:dna) - (dna:open-dna-bidirectional-stream - host (format nil "X$X~D" display) - :characters nil - :ascii-translation nil))) - (let ((neti:*invoke-service-automatic-retry* t)) - (net:invoke-service-on-host :x-window-system host))))) - -#+explorer -(defun open-x-stream (host display protocol) - (declare (ignore protocol)) - (net:open-connection-on-medium - (net:parse-host host) ;Host - :byte-stream ;Medium - "X11" ;Logical contact name - :stream-type :character-stream - :direction :bidirectional - :timeout-after-open nil - :remote-port (+ *x-tcp-port* display))) - -#+explorer -(net:define-logical-contact-name - "X11" - `((:local "X11") - (:chaos "X11") - (:nsp-stream "X11") - (:tcp ,*x-tcp-port*))) - -#+lucid -(defun open-x-stream (host display protocol) - protocol ;; unused - (let ((fd (connect-to-server host display))) - (when (minusp fd) - (error "Failed to connect to server: ~A ~D" host display)) - (user::make-lisp-stream :input-handle fd - :output-handle fd - :element-type 'unsigned-byte - #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) - -#+(or kcl ibcl) -(defun open-x-stream (host display protocol) - protocol ;; unused - (let ((stream (open-socket-stream host display))) - (if (streamp stream) - stream - (error "Cannot connect to server: ~A:~D" host display)))) - -#+excl -;; -;; Note that since we don't use the CL i/o facilities to do i/o, the display -;; input and output "stream" is really a file descriptor (fixnum). -;; -(defun open-x-stream (host display protocol) - (declare (ignore protocol));; unused - (let ((fd (connect-to-server (string host) display))) - (when (minusp fd) - (error "Failed to connect to server: ~A ~D" host display)) - fd)) - -#+Minima -(defun open-x-stream (host display protocol) - (declare (ignore protocol));; unused - (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address - (cdr (host-address host))) - :foreign-port (+ *x-tcp-port* display))) - -#+(or sbcl ecl) -(defun open-x-stream (host display protocol) - (declare (ignore protocol) - (type (integer 0) display)) - (let ((local-socket-path (unix-socket-path-from-host host display))) - (socket-make-stream - (if local-socket-path - (let ((s (make-instance 'local-socket :type :stream))) - (socket-connect s local-socket-path) - s) - (let ((host (car (host-ent-addresses (get-host-by-name host))))) - (when host - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) - (socket-connect s host (+ 6000 display)) - s)))) - :element-type '(unsigned-byte 8) - :input t :output t :buffering :none))) - -;;; BUFFER-READ-DEFAULT - read data from the X stream - -#+(or Genera explorer) -(defun buffer-read-default (display vector start end timeout) - ;; returns non-NIL if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (or (cond ((null stream)) - ((funcall stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (multiple-value-bind (ignore eofp) - (funcall stream :string-in nil vector start end) - eofp)))) - - -#+excl -;; -;; Rewritten 10/89 to not use foreign function interface to do I/O. -;; -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - - (let* ((howmany (- end start)) - (fd (display-input-stream display))) - (declare (type array-index howmany) - (fixnum fd)) - (or (cond ((fd-char-avail-p fd) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (fd-read-bytes fd vector start howmany)))) - - -#+lcl3.0 -(defmacro with-underlying-stream ((variable stream display direction) &body body) - `(let ((,variable - (or (getf (display-plist ,display) ',direction) - (setf (getf (display-plist ,display) ',direction) - (lucid::underlying-stream - ,stream ,(if (eq direction 'input) :input :output)))))) - ,@body)) - -#+lcl3.0 -(defun buffer-read-default (display vector start end timeout) - ;;Note that LISTEN must still be done on "slow stream" or the I/O system - ;;gets confused. But reading should be done from "fast stream" for speed. - ;;We used to inhibit scheduling because there were races in Lucid's - ;;multitasking system. Empirical evidence suggests they may be gone now. - ;;Should you decide you need to inhibit scheduling, do it around the - ;;lcl:read-array. - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (with-underlying-stream (stream stream display input) - (eq (lcl:read-array stream vector start end nil :eof) :eof))))) - -#+Minima -(defun buffer-read-default (display vector start end timeout) - ;; returns non-NIL if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (eq :eof (minima:read-vector vector stream nil start end))))) - -;;; BUFFER-READ-DEFAULT for CMU Common Lisp. -;;; -;;; If timeout is 0, then we call LISTEN to see if there is any input. -;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without -;;; first calling BUFFER-INPUT-WAIT-DEFAULT. -;;; -#+(or CMU sbcl) -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null fixnum) timeout)) - #.(declare-buffun) - (cond ((and (eql timeout 0) - (not (listen (display-input-stream display)))) - :timeout) - (t - (#+cmu system:read-n-bytes - #+sbcl sb-sys:read-n-bytes - (display-input-stream display) - vector start (- end start)) - nil))) - -#+(or ecl clisp) -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null fixnum) timeout)) - #.(declare-buffun) - (cond ((and (eql timeout 0) - (not (listen (display-input-stream display)))) - :timeout) - (t - (read-sequence vector - (display-input-stream display) - :start start - :end end) - nil))) - -;;; WARNING: -;;; CLX performance will suffer if your lisp uses read-byte for -;;; receiving all data from the X Window System server. -;;; You are encouraged to write a specialized version of -;;; buffer-read-default that does block transfers. -#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp) -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (do* ((index start (index1+ index))) - ((index>= index end) nil) - (declare (type array-index index)) - (let ((c (read-byte stream nil nil))) - (declare (type (or null card8) c)) - (if (null c) - (return t) - (setf (aref vector index) (the card8 c)))))))) - -;;; BUFFER-WRITE-DEFAULT - write data to the X stream - -#+(or Genera explorer) -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (write-string vector stream :start start :end end)))) - -#+excl -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (excl::filesys-write-bytes (display-output-stream display) vector start - (- end start))) - -#+lcl3.0 -(defun buffer-write-default (vector display start end) - ;;We used to inhibit scheduling because there were races in Lucid's - ;;multitasking system. Empirical evidence suggests they may be gone now. - ;;Should you decide you need to inhibit scheduling, do it around the - ;;lcl:write-array. - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (with-underlying-stream (stream stream display output) - (lcl:write-array stream vector start end))))) - -#+Minima -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (minima:write-vector vector stream start end)))) - -#+CMU -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (system:output-raw-bytes (display-output-stream display) vector start end) - nil) - -#+(or sbcl ecl clisp) -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (write-sequence vector (display-output-stream display) :start start :end end) - nil) - -;;; WARNING: -;;; CLX performance will be severely degraded if your lisp uses -;;; write-byte to send all data to the X Window System server. -;;; You are STRONGLY encouraged to write a specialized version -;;; of buffer-write-default that does block transfers. - -#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp ecl) -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (with-vector (vector buffer-bytes) - (do ((index start (index1+ index))) - ((index>= index end)) - (declare (type array-index index)) - (write-byte (aref vector index) stream)))))) - -;;; buffer-force-output-default - force output to the X stream - -#+excl -(defun buffer-force-output-default (display) - ;; buffer-write-default does the actual writing. - (declare (ignore display))) - -#-(or excl) -(defun buffer-force-output-default (display) - ;; The default buffer force-output function for use with common-lisp streams - (declare (type display display)) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (force-output stream)))) - -;;; BUFFER-CLOSE-DEFAULT - close the X stream - -#+excl -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display) - (ignore abort)) - #.(declare-buffun) - (excl::filesys-checking-close (display-output-stream display))) - -#-(or excl) -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (close stream :abort abort)))) - -;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the -;;; buffer. This is called in read-input between requests, so that a process -;;; waiting for input is abortable when between requests. Should return -;;; :TIMEOUT if it times out, NIL otherwise. - -;;; The default implementation - -;; Poll for input every *buffer-read-polling-time* SECONDS. -#-(or Genera explorer excl lcl3.0 CMU sbcl) -(defparameter *buffer-read-polling-time* 0.5) - -#-(or Genera explorer excl lcl3.0 CMU sbcl clisp) -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (listen stream) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (listen stream) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) - -#+(or CMU sbcl clisp) -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null number) timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - (t - (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) - :input timeout) - #+mp (mp:process-wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) - #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) - (ext:socket-status stream (and timeout sec) - (round usec 1d-6))) - #-(or sbcl mp clisp) (system:wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) - nil - :timeout))))) - -#+Genera -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((scl:send stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((null timeout) (si:stream-input-block stream "CLX Input")) - (t - (scl:condition-bind ((neti:protocol-timeout - #'(lambda (error) - (when (eq stream (scl:send error :stream)) - (return-from buffer-input-wait-default :timeout))))) - (neti:with-stream-timeout (stream :input timeout) - (si:stream-input-block stream "CLX Input"))))) - nil)) - -#+explorer -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((zl:send stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((null timeout) - (si:process-wait "CLX Input" stream :listen)) - (t - (unless (si:process-wait-with-timeout - "CLX Input" (round (* timeout 60.)) stream :listen) - (return-from buffer-input-wait-default :timeout)))) - nil)) - -#+excl -;; -;; This is used so an 'eq' test may be used to find out whether or not we can -;; safely throw this process out of the CLX read loop. -;; -(defparameter *read-whostate* "waiting for input from X server") - -;; -;; Note that this function returns nil on error if the scheduler is running, -;; t on error if not. This is ok since buffer-read will detect the error. -;; -#+excl -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((fd (display-input-stream display))) - (declare (fixnum fd)) - (when (>= fd 0) - (cond ((fd-char-avail-p fd) - nil) - - ;; Otherwise no bytes were available on the socket - ((and timeout (= timeout 0)) - ;; If there aren't enough and timeout == 0, timeout. - :timeout) - - ;; If the scheduler is running let it do timeouts. - (mp::*scheduler-stack-group* - #+allegro - (if (not - (mp:wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p - :timeout timeout)) - (return-from buffer-input-wait-default :timeout)) - #-allegro - (mp::wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p)) - - ;; Otherwise we have to handle timeouts by hand, and call select() - ;; to block until input is available. Note we don't really handle - ;; the interaction of interrupts and (numberp timeout) here. XX - (t - (let ((res 0)) - (declare (fixnum res)) - (with-interrupt-checking-on - (loop - (setq res (fd-wait-for-input fd (if (null timeout) 0 - (truncate timeout)))) - (cond ((plusp res) ; success - (return nil)) - ((eq res 0) ; timeout - (return :timeout)) - ((eq res -1) ; error - (return t)) - ;; Otherwise we got an interrupt -- go around again. - ))))))))) - - -#+lcl3.0 -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout) - (clx-values timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((with-underlying-stream (stream stream display input) - (lucid::waiting-for-input-from-stream stream - (lucid::with-io-unlocked - (if (null timeout) - (lcl:process-wait "CLX Input" #'listen stream) - (lcl:process-wait-with-timeout - "CLX Input" timeout #'listen stream))))) - nil) - (:timeout)))) - - -;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the -;;; buffer. This should never block, so it can be called from the scheduler. - -;;; The default implementation is to just use listen. -#-(or excl) -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (if (null stream) - t - (listen stream)))) - -#+excl -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((fd (display-input-stream display))) - (declare (type fixnum fd)) - (if (= fd -1) - t - (fd-char-avail-p fd)))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent speed hacks -;;;---------------------------------------------------------------------------- - -;; -;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. -;; If your lisp doesn't have stack-lists, and you're worried about -;; consing garbage, you may want to re-write this to allocate and -;; initialize lists from a resource. -;; -#-lispm -(defmacro with-stack-list ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -#-lispm -(defmacro with-stack-list* ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list* ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -(declaim (inline buffer-replace)) - -#+lispm -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type vector buf1 buf2) - (type array-index start1 end1 start2)) - (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) - -#+excl -(defun buffer-replace (target-sequence source-sequence target-start - target-end &optional (source-start 0)) - (declare (type buffer-bytes target-sequence source-sequence) - (type array-index target-start target-end source-start) - (optimize (speed 3) (safety 0))) - - (let ((source-end (length source-sequence))) - (declare (type array-index source-end)) - - (excl:if* (and (eq target-sequence source-sequence) - (> target-start source-start)) - then (let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (do ((target-index (+ target-start nelts -1) (1- target-index)) - (source-index (+ source-start nelts -1) (1- source-index))) - ((= target-index (1- target-start)) target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) - else (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index target-end) (= source-index source-end)) - target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))))) - -#+cmu -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - #.(declare-buffun) - (kernel:bit-bash-copy - buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) - buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) - (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits))) - -#+lucid -;;;The compiler is *supposed* to optimize calls to replace, but in actual -;;;fact it does not. -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - #.(declare-buffun) - (let ((end2 (lucid::%simple-8bit-vector-length buf2))) - (declare (type array-index end2)) - (lucid::simple-8bit-vector-replace-internal - buf1 buf2 start1 end1 start2 end2))) - -#+(and clx-overlapping-arrays (not (or lispm excl))) -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type vector buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -#-(or lispm lucid excl CMU clx-overlapping-arrays) -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -#+ti -(defun with-location-bindings (sys:"e bindings &rest body) - (do ((bindings bindings (cdr bindings))) - ((null bindings) - (sys:eval-body-as-progn body)) - (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) - (sys:*eval (cadar bindings))))) - -#+ti -(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) - (let ((bindings (cadr form)) - (body (cddr form))) - `(let () - ,@(loop for (accessor value) in bindings - collect `(si:bind (si:locf ,accessor) ,value)) - ,@body))) - -#+ti -(defun (:property with-location-bindings compiler::cw-handler) (exp) - (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) - (body (compiler::cw-clause (cddr exp)))) - (and compiler::cw-return-expansion-flag - (list* (first exp) bindlist body)))) - -#+(and lispm (not ti)) -(defmacro with-location-bindings (bindings &body body) - `(sys:letf* ,bindings ,@body)) - -#+lispm -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - ;; don't use svref on LHS because Symbolics didn't define locf for it - (let* ((local-state (gensym)) - (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway - (dolist (index indexes) - (push `((aref ,local-state ,index) (svref ,saved-state ,index)) - bindings)) - `(let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - (unwind-protect - (with-location-bindings ,bindings - ,@body) - (setf (svref ,local-state ,ts-index) 0) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state))))) - -#-lispm -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - (let ((local-state (gensym)) - (resets nil)) - (dolist (index indexes) - (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) - `(unwind-protect - (progn - ,@body) - (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state)))) - -;;;---------------------------------------------------------------------------- -;;; How much error detection should CLX do? -;;; Several levels are possible: -;;; -;;; 1. Do the equivalent of check-type on every argument. -;;; -;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format -;;; strings generated by check-type. -;;; -;;; 3. Do error checking only on arguments that are likely to have errors -;;; (like keyword names) -;;; -;;; 4. Do error checking only where not doing so may dammage the envirnment -;;; on a non-tagged machine (i.e. when storing into a structure that has -;;; been passed in) -;;; -;;; 5. No extra error detection code. On lispm's, ASET may barf trying to -;;; store a non-integer into a number array. -;;; -;;; How extensive should the error checking be? For example, if the server -;;; expects a CARD16, is is sufficient for CLX to check for integer, or -;;; should it also check for non-negative and less than 65536? -;;;---------------------------------------------------------------------------- - -;; The +TYPE-CHECK?+ constant controls how much error checking is done. -;; Possible values are: -;; NIL - Don't do any error checking -;; t - Do the equivalent of checktype on every argument -;; :minimal - Do error checking only where errors are likely - -;;; This controls macro expansion, and isn't changable at run-time You will -;;; probably want to set this to nil if you want good performance at -;;; production time. -(defconstant +type-check?+ - #+(or Genera Minima CMU sbcl) nil - #-(or Genera Minima CMU sbcl) t) - -;; TYPE? is used to allow the code to do error checking at a different level from -;; the declarations. It also does some optimizations for systems that don't have -;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. -;; include range checks. You can modify TYPE? to do less extensive checking -;; for these types if you desire. - -;; -;; ### This comment is a lie! TYPE? is really also used for run-time type -;; dispatching, not just type checking. -- Ram. - -(defmacro type? (object type) - #+(or cmu sbcl clisp) - `(typep ,object ,type) - #-(or cmu sbcl clisp) - (if (not (constantp type)) - `(typep ,object ,type) - (progn - (setq type (eval type)) - #+(or Genera explorer Minima) - (if +type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type)) - `(typep ,object ',type)) - #-(or Genera explorer Minima) - (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) - -;; X-TYPE-ERROR is the function called for type errors. -;; If you want lots of checking, but are concerned about code size, -;; this can be made into a macro that ignores some parameters. - -(defun x-type-error (object type &optional error-string) - (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) - - -;;----------------------------------------------------------------------------- -;; Error handlers -;; Hack up KMP error signaling using zetalisp until the real thing comes -;; along -;;----------------------------------------------------------------------------- - -(defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) - (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) - ;; The default display-error-handler. - ;; It signals the conditions listed in the DISPLAY file. - (if asynchronous - (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) - (apply #'x-error error-key :display display :error-key error-key key-vals))) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (apply #'sys:signal condition keyargs)) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (sys:signal (apply #'zl:make-condition condition keyargs) - :proceed-types proceed-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition keyargs)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp)) -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'cerror proceed-format-string condition keyargs)) - -;;; X-ERROR for CMU Common Lisp -;;; -;;; We detect a couple condition types for which we disable event handling in -;;; our system. This prevents going into the debugger or returning to a -;;; command prompt with CLX repeatedly seeing the same condition. This occurs -;;; because CMU Common Lisp provides for all events (that is, X, input on file -;;; descriptors, Mach messages, etc.) to come through one routine anyone can -;;; use to wait for input. -;;; -#+(and CMU (not mp)) -(defun x-error (condition &rest keyargs) - (let ((condx (apply #'make-condition condition keyargs))) - (when (eq condition 'closed-display) - (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) - (error condx))) - -#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+lcl3.0 -(defmacro define-condition (name parent-types &optional slots &rest args) - `(lcl:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and CMU (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(common-lisp:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and lispm (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &body options) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil)) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - `(within-definition (,name define-condition) - (zl:defflavor ,name ,slot-names ,parent-types - :initable-instance-variables - #-Genera - (:accessor-prefix ,conc-name) - #+Genera - (:conc-name ,conc-name) - #-Genera - (:outside-accessible-instance-variables ,@slot-names) - #+Genera - (:readable-instance-variables ,@slot-names)) - ,(when reporter ;; when no reporter, parent's is inherited - `(zl:defmethod #-Genera (,name :report) - #+Genera (dbg:report ,name) (stream) - ,(if (stringp reporter) - `(write-string ,reporter stream) - `(,reporter global:self stream)) - global:self)) - (zl:compile-flavor-methods ,name) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ',name))) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(zl:defflavor x-error () (global:error)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defflavor x-error - ((dbg:proceed-types '(:continue)) ; - continue-format-string) - (sys:error) - (:initable-instance-variables continue-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (scl:make-instance x-error) (&rest ignore) - (when (not (sys:variable-boundp continue-format-string)) - (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (dbg:proceed x-error :continue) () - :continue) - -#+(and Genera (not clx-ansi-common-lisp)) -(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) - (format stream continue-format-string)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(define-condition x-error (error) ()) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defstruct x-error - report-function) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defmacro define-condition (name parent-types &body options) - ;; Define a structure that when printed displays an error message - (flet ((reporter-for-condition (name) - (xintern "." name '-reporter.))) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil) - (condition (gensym)) - (stream (gensym)) - (report-function (reporter-for-condition name))) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - (unless reporter - (setq report-function (reporter-for-condition (first parent-types)))) - `(within-definition (,name define-condition) - (defstruct (,name (:conc-name ,(intern conc-name)) - (:print-function condition-print) - (:include ,(first parent-types) - (report-function ',report-function))) - ,@slot-names) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ,(when reporter - `(defun ,report-function (,condition ,stream) - ,(if (stringp reporter) - `(write-string ,reporter ,stream) - `(,reporter ,condition ,stream)) - ,condition)) - ',name)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun condition-print (condition stream depth) - (declare (type x-error condition) - (type stream stream) - (ignore depth)) - (if *print-escape* - (print-unreadable-object (condition stream :type t)) - (funcall (x-error-report-function condition) condition stream)) - condition) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun make-condition (type &rest slot-initializations) - (declare (dynamic-extent slot-initializations)) - (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) - (symbol-package type)))) - (apply make-function slot-initializations))) - -#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(define-condition type-error (x-error) - ((datum :reader type-error-datum :initarg :datum) - (expected-type :reader type-error-expected-type :initarg :expected-type)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (type-error-expected-type condition))))) - - -;;----------------------------------------------------------------------------- -;; HOST hacking -;;----------------------------------------------------------------------------- - -#-(or explorer Genera Minima Allegro CMU sbcl ecl clisp) -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - host family - (error "HOST-ADDRESS not implemented yet.")) - -#+clisp -(defun host-address (host &optional (family :internet)) - "Return a list whose car is the family keyword (:internet :DECnet :Chaos) - and cdr is a list of network address bytes." - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - - (let ((hostent (posix::resolve-host-ipaddr (string host)))) - (when (not (posix::hostent-addr-list hostent)) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (posix::hostent-addrtype hostent) 2) - (no-address-error)) - (let ((addr (first (posix::hostent-addr-list hostent)))) - (etypecase addr - (integer - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - (string - (let ((parts (read-from-string - (nsubstitute #\Space #\. (ext:string-concat - "(" addr ")"))))) - (check-type parts (cons (unsigned-byte 8) - (cons (unsigned-byte 8) - (cons (unsigned-byte 8) - (cons (unsigned-byte 8) - NULL))))) - (cons :internet parts)))))))))) - - -#+explorer -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (ecase family - ((:internet nil 0) - (let ((addr (ip:get-ip-address host))) - (unless addr (error "~s isn't an internet host name" host)) - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr)))) - ((:chaos 2) - (let ((addr (first (chaos:chaos-addresses host)))) - (unless addr (error "~s isn't a chaos host name" host)) - (list :chaos - (ldb (byte 8 0) addr) - (ldb (byte 8 8) addr)))))) - -#+Genera -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (setf host (string host)) - (let ((net-type (ecase family - ((:internet nil 0) :internet) - ((:DECnet 1) :dna) - ((:chaos 2) :chaos)))) - (dolist (addr - (sys:send (net:parse-host host) :network-addresses) - (error "~S isn't a valid ~(~A~) host name" host family)) - (let ((network (car addr)) - (address (cadr addr))) - (when (sys:send network :network-typep net-type) - (return (ecase family - ((:internet nil 0) - (multiple-value-bind (a b c d) (tcp:explode-internet-address address) - (list :internet a b c d))) - ((:DECnet 1) - (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address))) - ((:chaos 2) - (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) - -#+Minima -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (etypecase family - ((:internet nil 0) - (list* :internet - (multiple-value-list - (minima:ip-address-components (minima:parse-ip-address (string host)))))))) - -#+Allegro -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - (let ((hostent 0)) - (unwind-protect - (progn - (setf hostent (ipc::gethostbyname (string host))) - (when (zerop hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (ipc::hostent-addrtype hostent) 2) - (no-address-error)) - (assert (= (ipc::hostent-length hostent) 4)) - (let ((addr (ipc::hostent-addr hostent))) - (when (or (member comp::.target. - '(:hp :sgi4d :sony :dec3100) - :test #'eq) - (probe-file "/lib/ld.so")) - ;; BSD 4.3 based systems require an extra indirection - (setq addr (si:memref-int addr 0 0 :unsigned-long))) - (list :internet - (si:memref-int addr 0 0 :unsigned-byte) - (si:memref-int addr 1 0 :unsigned-byte) - (si:memref-int addr 2 0 :unsigned-byte) - (si:memref-int addr 3 0 :unsigned-byte)))))) - (ff:free-cstruct hostent))))) - -;#+sbcl -;(require :sockets) - -#+CMU -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - (let ((hostent #+rwi-sockets(ext:lookup-host-entry (string host)) - #+mna-sockets(net.sbcl.sockets:look-up-host-entry - (string host)) - #+db-sockets(sockets:get-host-by-name (string host)))) - (when (not hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - #+rwi-sockets(unless (= (ext::host-entry-addr-type hostent) 2) - (no-address-error)) - #+mna-sockets(unless (= (net.sbcl.sockets::host-entry-addr-type hostent) 2) - (no-address-error)) - ;; the following form is for use with SBCL and Daniel - ;; Barlow's socket package - #+db-sockets(unless (sockets:host-ent-address hostent) - (no-address-error)) - (append (list :internet) - #+rwi-sockets - (let ((addr (first (ext::host-entry-addr-list hostent)))) - (list (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - #+mna-sockets - (let ((addr (first (net.sbcl.sockets::host-entry-addr-list hostent)))) - (list (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - ;; the following form is for use with SBCL and Daniel - ;; Barlow's socket package - #+db-sockets(coerce (sockets:host-ent-address hostent) - 'list))))))) - -#+sbcl -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (let ((hostent (get-host-by-name (string host)))) - (ecase family - ((:internet nil 0) - (cons :internet (coerce (host-ent-address hostent) 'list)))))) - -#+ecl -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host))) - (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host)))))) - (unless addr - (no-host-error)) - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))))) - -#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let* ((family (first host-object)) - (address (ecase family - (:internet - (dpb (second host-object) - (byte 8 24) - (dpb (third host-object) - (byte 8 16) - (dpb (fourth host-object) - (byte 8 8) - (fifth host-object))))) - (:chaos - (dpb (third host-object) (byte 8 8) (second host-object)))))) - (when (eq family :internet) (setq family :ip)) - (let ((host (si:get-host-from-address address family))) - (values (and host (funcall host :name)) family)))) - -;;; This isn't required, but it helps make sense of the results from access-hosts -#+Genera -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let ((family (first host-object))) - (values (sys:send (net:get-host-from-address - (ecase family - (:internet - (apply #'tcp:build-internet-address (rest host-object))) - ((:chaos :DECnet) - (dpb (third host-object) (byte 8 8) (second host-object)))) - (net:local-network-of-type (if (eq family :DECnet) - :DNA - family))) - :name) - family))) - -;;; This isn't required, but it helps make sense of the results from access-hosts -#+Minima -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let ((family (first host-object))) - (values (ecase family - (:internet - (minima:ip-address-string - (apply #'minima:make-ip-address (rest host-object))))) - family))) - - -;;----------------------------------------------------------------------------- -;; Whether to use closures for requests or not. -;;----------------------------------------------------------------------------- - -;;; If this macro expands to non-NIL, then request and locking code is -;;; compiled in a much more compact format, as the common code is shared, and -;;; the specific code is built into a closure that is funcalled by the shared -;;; code. If your compiler makes efficient use of closures then you probably -;;; want to make this expand to T, as it makes the code more compact. - -(defmacro use-closures () - #+(or lispm Minima) t - #-(or lispm Minima) nil) - -#+(or Genera Minima) -(defun clx-macroexpand (form env) - (declare (ignore env)) - form) - -#-(or Genera Minima) -(defun clx-macroexpand (form env) - (macroexpand form env)) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; Utilities - -(defun getenv (name) - #+excl (sys:getenv name) - #+lcl3.0 (lcl:environment-variable name) - #+CMU (cdr (assoc name ext:*environment-list* :test #'string=)) - #+sbcl (sb-ext:posix-getenv name) - #+ecl (si:getenv name) - #+clisp (ext:getenv name) - #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil)) - -(defun get-host-name () - "Return the same hostname as gethostname(3) would" - ;; machine-instance probably works on a lot of lisps, but clisp is not - ;; one of them - #+(or cmu sbcl ecl) (machine-instance) - ;; resources-pathname was using short-site-name for this purpose - #+excl (short-site-name) - #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s))) - #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented")) - -(defun homedir-file-pathname (name) - (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) - (merge-pathnames (user-homedir-pathname) (pathname name)))) - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (homedir-file-pathname ".Xdefaults")) - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) - (homedir-file-pathname - (concatenate 'string ".Xdefaults-" (get-host-name))))) - -;;; AUTHORITY-PATHNAME - The pathname of the authority file. - -(defun authority-pathname () - (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) - (homedir-file-pathname ".Xauthority"))) - -#+ecl -(eval-when (:load-toplevel :execute :compile-toplevel) - (pushnew :unix *features*)) - -;;; this particular defaulting behaviour is typical to most Unices, I think -#+unix -(defun get-default-display (&optional display-name) - "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY -if it is NIL. Display names have the format - - [protocol/] [hostname] : [:] displaynumber [.screennumber] - -There are two special cases in parsing, to match that done in the Xlib -C language bindings - - - If the hostname is ``unix'' or the empty string, any supplied - protocol is ignored and a connection is made using the :local - transport. - - - If a double colon separates hostname from displaynumber, the - protocol is assumed to be decnet. - -Returns a list of (host display-number screen protocol)." - (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) - (list host (or display 0) (or screen 0) protocol))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -(defun gc-cleanup () - (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) - (setq *event-free-list* nil) - (setq *pending-command-free-list* nil) - (when (boundp '*reply-buffer-free-lists*) - (fill *reply-buffer-free-lists* nil)) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil) - nil) - -#+Genera -(si:define-gc-cleanup clx-cleanup ("CLX Cleanup") - (gc-cleanup)) - - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera CMU sbcl ecl) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - #+ticl (ticl:*print-structure* t) - #+lucid (lucid::*print-structure* t)) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera CMU sbcl ecl) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - - -;;----------------------------------------------------------------------------- -;; DEFAULT-KEYSYM-TRANSLATE -;;----------------------------------------------------------------------------- - -;;; If object is a character, char-bits are set from state. -;;; -;;; [the following isn't implemented (should it be?)] -;;; If object is a list, it is an alist with entries: -;;; (base-char [modifiers] [mask-modifiers]) -;;; When MODIFIERS are specified, this character translation -;;; will only take effect when the specified modifiers are pressed. -;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. -;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. -;;; In ambiguous cases, the most specific translation is used. - -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (clx-values t) - (special left-meta-keysym right-meta-keysym - left-super-keysym right-super-keysym - left-hyper-keysym right-hyper-keysym)) - (when (characterp object) - (when (logbitp (position :control +state-mask-vector+) state) - (setf (char-bit object :control) 1)) - (when (or (state-keysymp display state left-meta-keysym) - (state-keysymp display state right-meta-keysym)) - (setf (char-bit object :meta) 1)) - (when (or (state-keysymp display state left-super-keysym) - (state-keysymp display state right-super-keysym)) - (setf (char-bit object :super) 1)) - (when (or (state-keysymp display state left-hyper-keysym) - (state-keysymp display state right-hyper-keysym)) - (setf (char-bit object :hyper) 1))) - object) - -#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp) -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (ignore display state) - (clx-values t)) - object) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -;;; Types - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - '(unsigned-byte 4)) - -(deftype pixarray-8-element-type () - '(unsigned-byte 8)) - -(deftype pixarray-16-element-type () - '(unsigned-byte 16)) - -(deftype pixarray-24-element-type () - '(unsigned-byte 24)) - -(deftype pixarray-32-element-type () - #-(or Genera Minima) '(unsigned-byte 32) - #+(or Genera Minima) 'fixnum) - -(deftype pixarray-1 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-1-element-type (* *))) - -(deftype pixarray-4 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-4-element-type (* *))) - -(deftype pixarray-8 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-8-element-type (* *))) - -(deftype pixarray-16 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-16-element-type (* *))) - -(deftype pixarray-24 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-24-element-type (* *))) - -(deftype pixarray-32 () - '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) - -(deftype pixarray () - '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) - -(deftype bitmap () - 'pixarray-1) - -;;; WITH-UNDERLYING-SIMPLE-VECTOR - -#+Genera -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - (let ((bits-per-element - (sys:array-bits-per-element - (symbol-value (sys:type-array-element-type element-type))))) - `(scl:stack-let ((,variable - (make-array - (index-ceiling - (index* (array-total-size ,pixarray) - (sys:array-element-size ,pixarray)) - ,bits-per-element) - :element-type ',element-type - :displaced-to ,pixarray))) - (declare (type (vector ,element-type) ,variable)) - ,@body))) - -#+lcl3.0 -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - `(let ((,variable (sys:underlying-simple-vector ,pixarray))) - (declare (type (simple-array ,element-type (*)) ,variable)) - ,@body)) - -#+excl -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - `(let ((,variable (cdr (excl::ah_data ,pixarray)))) - (declare (type (simple-array ,element-type (*)) ,variable)) - ,@body)) - -#+(or CMU sbcl) -;;; We do *NOT* support viewing an array as having a different element type. -;;; Element-type is ignored. -;;; -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - (declare (ignore element-type)) - `(#+cmu kernel::with-array-data #+sbcl sb-kernel:with-array-data - ((,variable ,pixarray) (start) (end)) - (declare (ignore start end)) - ,@body)) - -;;; These are used to read and write pixels from and to CARD8s. - -;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. - -(defmacro read-image-load-byte (size position integer) - (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) - `(the (unsigned-byte ,size) - (#-Genera ldb #+Genera sys:%logldb - (byte ,size ,position) - (the card8 ,integer)))) - -;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from -;;; the appropriate number of CARD8s. - -(defmacro read-image-assemble-bytes (&rest bytes) - (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it - `(#-Genera dpb #+Genera sys:%logdpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) - #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) - #+Genera it)) - -;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit -;;; pixel. - -(defmacro write-image-load-byte (position integer integer-size) - integer-size - (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) - `(the card8 - (#-Genera ldb #+Genera sys:%logldb - (byte 8 ,position) - #-Genera (the (unsigned-byte ,integer-size) ,integer) - #+Genera ,integer - ))) - -;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit -;;; pixels. - -(defmacro write-image-assemble-bytes (&rest bytes) - (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it `(#-Genera dpb #+Genera sys:%logdpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) - `(the card8 ,it))) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 - -#+(or Genera lcl3.0 excl) -(defconstant - *image-bit-ordering-table* - '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) - ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) - ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) - ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) - ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) - ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) - -#+(or Genera lcl3.0 excl) -(defun compute-image-byte-and-bit-ordering () - (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) - ;; First compute the ordering - (let ((ordering nil) - (a (make-array '(1 32) :element-type 'bit :initial-element 0))) - (dotimes (i 4) - (push (flet ((bitpos (a i n) - (declare (optimize (speed 3) (safety 0) (space 0))) - (declare (type (simple-array bit (* *)) a) - (type fixnum i n)) - (with-underlying-simple-vector (v (unsigned-byte 8) a) - (prog2 - (setf (aref v i) n) - (dotimes (i 32) - (unless (zerop (aref a 0 i)) - (return i))) - (setf (aref v i) 0))))) - (list (bitpos a i #b10000000) - (bitpos a i #b00000001))) - ordering)) - (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) - ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p - (let ((byte-and-bit-ordering - (second (assoc ordering *image-bit-ordering-table* - :test #'equal)))) - (unless byte-and-bit-ordering - (error "Couldn't determine image byte and bit ordering~@ - measured image ordering = ~A" - ordering)) - (values-list byte-and-bit-ordering)))) - -#+(or Genera lcl3.0 excl) -(multiple-value-setq - (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (compute-image-byte-and-bit-ordering)) - -;;; If you can write fast routines that can read and write pixarrays out of a -;;; buffer-bytes, do it! It makes the image code a lot faster. The -;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines -;;; return T if they can do it, NIL if they can't. - -;;; FIXME: though we have some #+sbcl -conditionalized routines in -;;; here, they would appear not to work, and so are commented out in -;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate -;;; whether the unoptimized routines are often used, and also whether -;;; speeding them up while maintaining correctness is possible. - -;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index (mod (the fixnum (- x)) 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (the fixnum (- (the fixnum (- width left-bits)) - right-bits))) - (middle-bytes (index-floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bytes) - (fixnum middle-bits)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-bits) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (array-row-major-index - array y (index+ left-bits middle-bits)))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref vector (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - t) - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) - 2))) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-nibbles) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - t) - -#+(or Genera lcl3.0 excl CMU sbcl) -(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - t) - -#+lispm -(defun fast-read-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (#+Genera sys:stack-let* #-Genera let* - ((dimensions (list (+ y height) - (floor (* padded-bytes-per-line 8) bits-per-pixel))) - (a (make-array - dimensions - :element-type (array-element-type pixarray) - :displaced-to bbuf - :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) - (sys:bitblt boole-1 width height a x y pixarray 0 0)) - t) - -#+(or CMU sbcl) -(defun pixarray-element-size (pixarray) - (let ((eltype (array-element-type pixarray))) - (cond ((eq eltype 'bit) 1) - ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) - (second eltype)) - (t - (error "Invalid pixarray: ~S." pixarray))))) - -#+CMU -;;; COPY-BIT-RECT -- Internal -;;; -;;; This is the classic BITBLT operation, copying a rectangular subarray -;;; from one array to another (but source and destination must not overlap.) -;;; Widths are specified in bits. Neither array can have a non-zero -;;; displacement. We allow extra random bit-offset to be thrown into the X. -;;; -(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy - height width) - (declare (type array-index source-width sx sy dest-width dx dy height width)) - #.(declare-buffun) - (kernel::with-array-data ((sdata source) - (sstart) - (send)) - (declare (ignore send)) - (kernel::with-array-data ((ddata dest) - (dstart) - (dend)) - (declare (ignore dend)) - (assert (and (zerop sstart) (zerop dstart))) - (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) - sx (index* sy source-width)) - (index+ src-idx source-width)) - (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) - dx (index* dy dest-width)) - (index+ dest-idx dest-width)) - (count height (1- count))) - ((zerop count)) - (declare (type array-index src-idx dest-idx count)) - (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) - - -#+sbcl -(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy - height width) - (declare (type array-index source-width sx sy dest-width dx dy height width)) - #.(declare-buffun) - (sb-kernel:with-array-data ((sdata source) (sstart) (send)) - (declare (ignore send)) - (sb-kernel:with-array-data ((ddata dest) (dstart) (dend)) - (declare (ignore dend)) - (assert (and (zerop sstart) (zerop dstart))) - (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - sx (index* sy source-width)) - (index+ src-idx source-width)) - (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - dx (index* dy dest-width)) - (index+ dest-idx dest-width)) - (count height (1- count))) - ((zerop count)) - (declare (type array-index src-idx dest-idx count)) - (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width))))) - -#+(or CMU sbcl) -(defun fast-read-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (declare (type (array * 2) pixarray)) - #.(declare-buffun) - (copy-bit-rect bbuf - (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 - pixarray - (index* (array-dimension pixarray 1) bits-per-pixel) - x y - height - (index* width bits-per-pixel)) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-read-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (x-bits (index* x bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line x-bits)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod x-bits 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod x-bits +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p*) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (dst card8 pixarray) - (funcall - (symbol-function image-swap-function) bbuf dst - (index+ boffset - (index* y padded-bytes-per-line) - (index-floor x-bits 8)) - 0 (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line - (index-floor pixarray-padded-bits-per-line 8) - height image-swap-lsb-first-p))) - t)))) - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-read-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-read-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-read-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-read-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-read-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-read-pixarray-24)))) - (when function - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) - -;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (array-row-major-index - array y (index+ start-x middle-bits)))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (if (index> right-bits 1) - (aref vector (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref vector (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref vector (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref vector (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref vector (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref vector (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)) - (aref vector (index+ x 2)) - (aref vector (index+ x 3)) - (aref vector (index+ x 4)) - (aref vector (index+ x 5)) - (aref vector (index+ x 6)) - (aref vector (index+ x 7)))))))) - t) - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)))))))) - t) - -#+(or Genera lcl3.0 excl CMU sbcl) -(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref vector x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - t) - -#+lispm -(defun fast-write-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (#+Genera sys:stack-let* #-Genera let* - ((dimensions (list (+ y height) - (floor (* padded-bytes-per-line 8) bits-per-pixel))) - (a (make-array - dimensions - :element-type (array-element-type pixarray) - :displaced-to bbuf - :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) - (sys:bitblt boole-1 width height pixarray x y a 0 0)) - t) - -#+(or CMU sbcl) -(defun fast-write-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - #.(declare-buffun) - (copy-bit-rect pixarray - (index* (array-dimension pixarray 1) bits-per-pixel) - x y - bbuf - (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 - height - (index* width bits-per-pixel)) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-write-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (src card8 pixarray) - (funcall - (symbol-function image-swap-function) - src bbuf (index-floor pixarray-start-bit-offset 8) boffset - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - padded-bytes-per-line height image-swap-lsb-first-p)) - t))))) - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-write-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-write-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-write-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-write-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-write-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-write-pixarray-24)))) - (when function - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))))) - -;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another - -(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) - (declare (type pixarray pixarray copy) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (progn pixarray copy x y width height bits-per-pixel nil) - (or - #+(or lispm CMU) - (let* ((pixarray-padded-pixels-per-line - #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1)) - (pixarray-padded-bits-per-line - (* pixarray-padded-pixels-per-line bits-per-pixel)) - (copy-padded-pixels-per-line - #+Genera (sys:array-row-span copy) - #-Genera (array-dimension copy 1)) - (copy-padded-bits-per-line - (* copy-padded-pixels-per-line bits-per-pixel))) - #-(or CMU) - (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod pixarray-padded-bits-per-line 32)) - (zerop (index-mod copy-padded-bits-per-line 32))) - (sys:bitblt boole-1 width height pixarray x y copy 0 0) - t) - #+(or CMU) - (when (index= (pixarray-element-size pixarray) - (pixarray-element-size copy) - bits-per-pixel) - (copy-bit-rect pixarray pixarray-padded-bits-per-line x y - copy copy-padded-bits-per-line 0 0 - height - (index* width bits-per-pixel)) - t)) - - #+(or lcl3.0 excl) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (copy-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index copy 1 0) - (array-row-major-index copy 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - copy-padded-bits-per-line pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod copy-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (with-underlying-simple-vector (src card8 pixarray) - (with-underlying-simple-vector (dst card8 copy) - (image-noswap - src dst - (index-floor pixarray-start-bit-offset 8) 0 - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - (index-floor copy-padded-bits-per-line 8) - height nil))) - t))) - #+(or lcl3.0 excl) - (macrolet - ((copy (type element-type) - `(let ((pixarray pixarray) - (copy copy)) - (declare (type ,type pixarray copy)) - #.(declare-buffun) - (with-underlying-simple-vector (src ,element-type pixarray) - (with-underlying-simple-vector (dst ,element-type copy) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-idx (array-row-major-index copy dst-y 0) - (index1+ dst-idx)) - (dst-end (index+ dst-idx width)) - (src-idx (array-row-major-index pixarray src-y x) - (index1+ src-idx))) - ((index>= dst-idx dst-end)) - (declare (type array-index dst-idx src-idx dst-end)) - (setf (aref dst dst-idx) - (the ,element-type (aref src src-idx)))))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))) - t))) diff --git a/src/clx/display.lisp b/src/clx/display.lisp deleted file mode 100644 index 9d02f718e..000000000 --- a/src/clx/display.lisp +++ /dev/null @@ -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")) diff --git a/src/clx/dpms.lisp b/src/clx/dpms.lisp deleted file mode 100644 index 5ce09cc8b..000000000 --- a/src/clx/dpms.lisp +++ /dev/null @@ -1,168 +0,0 @@ - -;;;; Original Author: Matthew Kennedy -;;;; -;;;; 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: diff --git a/src/clx/exclMakefile b/src/clx/exclMakefile deleted file mode 100644 index bd0c93671..000000000 --- a/src/clx/exclMakefile +++ /dev/null @@ -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) diff --git a/src/clx/exclREADME b/src/clx/exclREADME deleted file mode 100644 index c99e388e0..000000000 --- a/src/clx/exclREADME +++ /dev/null @@ -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: - - (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: - - (load "clx") - -to load in CLX. You may want to dump a lisp at this point since CLX is a large -package and can take some time to load into Lisp. You probably also want to -set the :generation-spread to 1 while loading CLX. Please see your Allegro CL -User Guide for more information on :generation-spread. - - - Sophisticated users may wish to peruse the Makefile and defsystem.cl -and note how things are set up. For example we hardwire the compiler -interrupt check switch on, so that CL can still be interrupted while it -is reading from the X11 socket. Please see chapter 7 of the CL User's -guide for more information on compiler switches and their effects. - - -Please report Franz specific CLX bugs to: - - ucbvax!franz!bugs - or - bugs@Franz.COM diff --git a/src/clx/exclcmac.lisp b/src/clx/exclcmac.lisp deleted file mode 100644 index 67f63ddd9..000000000 --- a/src/clx/exclcmac.lisp +++ /dev/null @@ -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))))))) - - diff --git a/src/clx/excldefsys.lisp b/src/clx/excldefsys.lisp deleted file mode 100644 index 628bdb50a..000000000 --- a/src/clx/excldefsys.lisp +++ /dev/null @@ -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") - )) diff --git a/src/clx/excldep.c b/src/clx/excldep.c deleted file mode 100644 index 91da5e427..000000000 --- a/src/clx/excldep.c +++ /dev/null @@ -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 -#include -#include -#include - -#define ERROR -1 -#define INTERRUPT -2 -#define TIMEOUT 0 -#define SUCCESS 1 - -#ifdef FD_SETSIZE -#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ -#else -#define NUMBER_OF_FDS 32 -#endif - -/* Length of array needed to hold all file descriptor bits */ -#define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int))) - -extern int errno; - -/* - * This function waits for input to become available on 'fd'. If timeout is - * 0, wait forever. Otherwise wait 'timeout' seconds. If input becomes - * available before the timer expires, return SUCCESS. If the timer expires - * return TIMEOUT. If an error occurs, return ERROR. If an interrupt occurs - * while waiting, return INTERRUPT. - */ -int fd_wait_for_input(fd, timeout) - register int fd; - register int timeout; -{ - struct timeval timer; - register int i; - int checkfds[CHECKLEN]; - - if (fd < 0 || fd >= NUMBER_OF_FDS) { - fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); - fflush(stderr); - } - - for (i = 0; i < CHECKLEN; i++) - checkfds[i] = 0; - checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); - - if (timeout) { - timer.tv_sec = timeout; - timer.tv_usec = 0; - i = select(32, checkfds, (int *)0, (int *)0, &timer); - } else - i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); - - if (i < 0) - /* error condition */ - if (errno == EINTR) - return (INTERRUPT); - else - return (ERROR); - else if (i == 0) - return (TIMEOUT); - else - return (SUCCESS); -} diff --git a/src/clx/excldep.lisp b/src/clx/excldep.lisp deleted file mode 100644 index 445a2244d..000000000 --- a/src/clx/excldep.lisp +++ /dev/null @@ -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)))) diff --git a/src/clx/fonts.lisp b/src/clx/fonts.lisp deleted file mode 100644 index b8dd832a7..000000000 --- a/src/clx/fonts.lisp +++ /dev/null @@ -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- (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- (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- (font) -; (declare (type font font) -; (clx-values integer))) - -;; Note: char16- 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) diff --git a/src/clx/gcontext.lisp b/src/clx/gcontext.lisp deleted file mode 100644 index ea96aa867..000000000 --- a/src/clx/gcontext.lisp +++ /dev/null @@ -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 ), there is an accessor: - -;(defun gcontext- (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 ))) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type (or null ) ), there is a setf for the corresponding accessor: - -;(defsetf gcontext- (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- dst) (gcontext- 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*))) diff --git a/src/clx/generalock.lisp b/src/clx/generalock.lisp deleted file mode 100644 index 6ff14d61a..000000000 --- a/src/clx/generalock.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- - -;;; Copyright (C) 1990 Symbolics, Inc. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Symbolics, Inc. provides this software "as is" without -;;; express or implied warranty. - -(defflavor xlib::clx-lock () (simple-recursive-normal-lock) - (:init-keywords :flavor)) - -(defwhopper (lock-internal xlib::clx-lock) (lock-argument) - (catch 'timeout - (continue-whopper lock-argument))) - -(defmethod (lock-block-internal xlib::clx-lock) (lock-argument) - (declare (dbg:locking-function describe-process-lock-for-debugger self)) - (when (null waiter-queue) - (setf waiter-queue (make-scheduler-queue :name name)) - (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) - (let ((process (lock-argument-process lock-argument))) - (unwind-protect - (progn - (lock-map-over-conflicting-owners - self lock-argument - #'(lambda (other-lock-arg) - (add-promotion process lock-argument - (lock-argument-process other-lock-arg) other-lock-arg))) - (unless (timer-pending-p timer) - (when (and (safe-to-use-timers %real-current-process) - (not dbg:*debugger-might-have-system-problems*)) - (reset-timer-relative-timer-units timer *lock-timer-interval*))) - (assert (store-conditional (locf latch) process nil)) - (sys:with-aborts-enabled (lock-latch) - (let ((timeout (lock-argument-getf lock-argument :timeout nil))) - (cond ((null timeout) - (promotion-block waiter-queue name #'lock-lockable self lock-argument)) - ((and (plusp timeout) - (using-resource (timer process-block-timers) - ;; Yeah, we know about the internal representation - ;; of timers here. - (setf (car (timer-args timer)) %real-current-process) - (with-scheduler-locked - (reset-timer-relative timer timeout) - (flet ((lock-lockable-or-timeout (timer lock lock-argument) - (or (not (timer-pending-p timer)) - (lock-lockable lock lock-argument)))) - (let ((priority (process-process-priority *current-process*))) - (if (ldb-test %%scheduler-priority-preemption-field priority) - (promotion-block waiter-queue name - #'lock-lockable-or-timeout - timer self lock-argument) - ;; Change to preemptive priority so that when - ;; unlock-internal wakes us up so we can have the lock, - ;; we will really wake up right away - (with-process-priority - (dpb 1 %%scheduler-priority-preemption-field - priority) - (promotion-block waiter-queue name - #'lock-lockable-or-timeout - timer self lock-argument))))) - (lock-lockable self lock-argument))))) - (t (throw 'timeout nil)))))) - (unless (store-conditional (locf latch) nil process) - (lock-latch-wait-internal self)) - (remove-promotions process lock-argument)))) - -(compile-flavor-methods xlib::clx-lock) diff --git a/src/clx/gl.lisp b/src/clx/gl.lisp deleted file mode 100644 index 9a4d31178..000000000 --- a/src/clx/gl.lisp +++ /dev/null @@ -1,3692 +0,0 @@ -(defpackage :gl - (:use :common-lisp :xlib) - (:import-from :glx - "*CURRENT-CONTEXT*" - "CONTEXT" - "CONTEXT-P" - "CONTEXT-DISPLAY" - "CONTEXT-TAG" - "CONTEXT-RBUF" - "CONTEXT-INDEX" - ) - (:import-from :xlib - "DATA" - "WITH-BUFFER-REQUEST" - "WITH-BUFFER-REQUEST-AND-REPLY" - "CARD32-GET" - "SEQUENCE-GET" - - "WITH-DISPLAY" - "DISPLAY-FORCE-OUTPUT" - - "INT8" "INT16" "INT32" "INTEGER" - "CARD8" "CARD16" "CARD32" - - "ASET-CARD8" - "ASET-CARD16" - "ASET-CARD32" - "ASET-INT8" - "ASET-INT16" - "ASET-INT32" - - "DECLARE-BUFFUN" - - ;; Types - "ARRAY-INDEX" - "BUFFER-BYTES" - ) - - (:export "GET-STRING" - - ;; Rendering commands (alphabetical order) - - "ACCUM" - "ACTIVE-TEXTURE-ARB" - "ALPHA-FUNC" - "BEGIN" - "BIND-TEXTURE" - "BLEND-COLOR" - "BLEND-EQUOTION" - "BLEND-FUNC" - "CALL-LIST" - "CLEAR" - "CLEAR-ACCUM" - "CLEAR-COLOR" - "CLEAR-DEPTH" - "CLEAR-INDEX" - "CLEAR-STENCIL" - "CLIP-PLANE" - "COLOR-3B" - "COLOR-3D" - "COLOR-3F" - "COLOR-3I" - "COLOR-3S" - "COLOR-3UB" - "COLOR-3UI" - "COLOR-3US" - "COLOR-4B" - "COLOR-4D" - "COLOR-4F" - "COLOR-4I" - "COLOR-4S" - "COLOR-4UB" - "COLOR-4UI" - "COLOR-4US" - "COLOR-MASK" - "COLOR-MATERIAL" - "CONVOLUTION-PARAMETER-F" - "CONVOLUTION-PARAMETER-I" - "COPY-COLOR-SUB-TABLE" - "COPY-COLOR-TABLE" - "COPY-CONVOLUTION-FILTER-ID" - "COPY-CONVOLUTION-FILTER-2D" - "COPY-PIXELS" - "COPY-TEX-IMAGE-1D" - "COPY-TEX-IMAGE-2D" - "COPY-TEX-SUB-IMAGE-1D" - "COPY-TEX-SUB-IMAGE-2D" - "COPY-TEX-SUB-IMAGE-3D" - "CULL-FACE" - "DEPTH-FUNC" - "DEPTH-MASK" - "DEPTH-RANGE" - "DRAW-BUFFER" - "EDGE-FLAG-V" - "END" - "EVAL-COORD-1D" - "EVAL-COORD-1F" - "EVAL-COORD-2D" - "EVAL-COORD-2F" - "EVAL-MESH-1" - "EVAL-MESH-2" - "EVAL-POINT-1" - "EVAL-POINT-2" - "FOG-F" - "FOG-I" - "FRONT-FACE" - "FRUSTUM" - "HINT" - "HISTOGRAM" - "INDEX-MASK" - "INDEX-D" - "INDEX-F" - "INDEX-I" - "INDEX-S" - "INDEX-UB" - "INIT-NAMES" - "LIGHT-MODEL-F" - "LIGHT-MODEL-I" - "LIGHT-F" - "LIGHT-FV" - "LIGHT-I" - "LIGHT-IV" - "LINE-STIPPLE" - "LINE-WIDTH" - "LIST-BASE" - "LOAD-IDENTITY" - "LOAD-NAME" - "LOGIC-OP" - "MAP-GRID-1D" - "MAP-GRID-1F" - "MAP-GRID-2D" - "MAP-GRID-2F" - "MATERIAL-F" - "MATERIAL-FV" - "MATERIAL-I" - "MATERIAL-IV" - "MATRIX-MODE" - "MINMAX" - "MULTI-TEX-COORD-1D-ARB" - "MULTI-TEX-COORD-1F-ARB" - "MULTI-TEX-COORD-1I-ARB" - "MULTI-TEX-COORD-1S-ARB" - "MULTI-TEX-COORD-2D-ARB" - "MULTI-TEX-COORD-2F-ARB" - "MULTI-TEX-COORD-2I-ARB" - "MULTI-TEX-COORD-2S-ARB" - "MULTI-TEX-COORD-3D-ARB" - "MULTI-TEX-COORD-3F-ARB" - "MULTI-TEX-COORD-3I-ARB" - "MULTI-TEX-COORD-3S-ARB" - "MULTI-TEX-COORD-4D-ARB" - "MULTI-TEX-COORD-4F-ARB" - "MULTI-TEX-COORD-4I-ARB" - "MULTI-TEX-COORD-4S-ARB" - "NORMAL-3B" - "NORMAL-3D" - "NORMAL-3F" - "NORMAL-3I" - "NORMAL-3S" - "ORTHO" - "PASS-THROUGH" - "PIXEL-TRANSFER-F" - "PIXEL-TRANSFER-I" - "PIXEL-ZOOM" - "POINT-SIZE" - "POLYGON-MODE" - "POLYGON-OFFSET" - "POP-ATTRIB" - "POP-MATRIX" - "POP-NAME" - "PUSH-ATTRIB" - "PUSH-MATRIX" - "PUSH-NAME" - "RASTER-POS-2D" - "RASTER-POS-2F" - "RASTER-POS-2I" - "RASTER-POS-2S" - "RASTER-POS-3D" - "RASTER-POS-3F" - "RASTER-POS-3I" - "RASTER-POS-3S" - "RASTER-POS-4D" - "RASTER-POS-4F" - "RASTER-POS-4I" - "RASTER-POS-4S" - "READ-BUFFER" - "RECT-D" - "RECT-F" - "RECT-I" - "RECT-S" - "RESET-HISTOGRAM" - "RESET-MINMAX" - "ROTATE-D" - "ROTATE-F" - "SCALE-D" - "SCALE-F" - "SCISSOR" - "SHADE-MODEL" - "STENCIL-FUNC" - "STENCIL-MASK" - "STENCIL-OP" - "TEX-ENV-F" - "TEX-ENV-I" - "TEX-GEN-D" - "TEX-GEN-F" - "TEX-GEN-I" - "TEX-PARAMETER-F" - "TEX-PARAMETER-I" - "TRANSLATE-D" - "TRANSLATE-F" - "VERTEX-2D" - "VERTEX-2F" - "VERTEX-2I" - "VERTEX-2S" - "VERTEX-3D" - "VERTEX-3F" - "VERTEX-3I" - "VERTEX-3S" - "VERTEX-4D" - "VERTEX-4F" - "VERTEX-4I" - "VERTEX-4S" - "VIEWPORT" - - ;; * Where did this come from? - ;;"NO-FLOATS" - - ;; Non-rendering commands - "NEW-LIST" - "END-LIST" - "GEN-LISTS" - "ENABLE" - "DISABLE" - "FLUSH" - "FINISH" - - ;; Constants - - ;; Boolean - - "+FALSE+" - "+TRUE+" - - ;; Types - - "+BYTE+" - "+UNSIGNED-BYTE+" - "+SHORT+" - "+UNSIGNED-SHORT+" - "+INT+" - "+UNSIGNED-INT+" - "+FLOAT+" - "+DOUBLE+" - "+2-BYTES+" - "+3-BYTES+" - "+4-BYTES+" - - ;; Primitives - - "+POINTS+" - "+LINES+" - "+LINE-LOOP+" - "+LINE-STRIP+" - "+TRIANGLES+" - "+TRIANGLE-STRIP+" - "+triangle-fan+" - "+QUADS+" - "+QUAD-STRIP+" - "+POLYGON+" - - ;; Arrays - - "+VERTEX-ARRAY+" - "+NORMAL-ARRAY+" - "+COLOR-ARRAY+" - "+INDEX-ARRAY+" - "+TEXTURE-COORD-ARRAY+" - "+EDGE-FLAG-ARRAY+" - "+VERTEX-ARRAY-SIZE+" - "+VERTEX-ARRAY-TYPE+" - "+VERTEX-ARRAY-STRIDE+" - "+NORMAL-ARRAY-TYPE+" - "+NORMAL-ARRAY-STRIDE+" - "+COLOR-ARRAY-SIZE+" - "+COLOR-ARRAY-TYPE+" - "+COLOR-ARRAY-STRIDE+" - "+INDEX-ARRAY-TYPE+" - "+INDEX-ARRAY-STRIDE+" - "+TEXTURE-COORD-ARRAY-SIZE+" - "+TEXTURE-COORD-ARRAY-TYPE+" - "+TEXTURE-COORD-ARRAY-STRIDE+" - "+EDGE-FLAG-ARRAY-STRIDE+" - "+VERTEX-ARRAY-POINTER+" - "+NORMAL-ARRAY-POINTER+" - "+COLOR-ARRAY-POINTER+" - "+INDEX-ARRAY-POINTER+" - "+TEXTURE-COORD-ARRAY-POINTER+" - "+EDGE-FLAG-ARRAY-POINTER+" - - ;; Array formats - - "+V2F+" - "+V3F+" - "+C4UB-V2F+" - "+C4UB-V3F+" - "+C3F-V3F+" - "+N3F-V3F+" - "+C4F-N3F-V3F+" - "+T2F-V3F+" - "+T4F-V4F+" - "+T2F-C4UB-V3F+" - "+T2F-C3F-V3F+" - "+T2F-N3F-V3F+" - "+T2F-C4F-N3F-V3F+" - "+T4F-C4F-N3F-V4F+" - - ;; Matrices - - "+MATRIX-MODE+" - "+MODELVIEW+" - "+PROJECTION+" - "+TEXTURE+" - - ;; Points - - "+POINT-SMOOTH+" - "+POINT-SIZE+" - "+POINT-SIZE-GRANULARITY+" - "+POINT-SIZE-RANGE+" - - ;; Lines - - "+LINE-SMOOTH+" - "+LINE-STIPPLE+" - "+LINE-STIPPLE-PATTERN+" - "+LINE-STIPPLE-REPEAT+" - "+LINE-WIDTH+" - "+LINE-WIDTH-GRANULARITY+" - "+LINE-WIDTH-RANGE+" - - ;; Polygons - - "+POINT+" - "+LINE+" - "+FILL+" - "+CW+" - "+CCW+" - "+FRONT+" - "+BACK+" - "+POLYGON-MODE+" - "+POLYGON-SMOOTH+" - "+POLYGON-STIPPLE+" - "+EDGE-FLAG+" - "+CULL-FACE+" - "+CULL-FACE-MODE+" - "+FRONT-FACE+" - "+POLYGON-OFFSET-FACTOR+" - "+POLYGON-OFFSET-UNITS+" - "+POLYGON-OFFSET-POINT+" - "+POLYGON-OFFSET-LINE+" - "+POLYGON-OFFSET-FILL+" - - ;; Display Lists - - "+COMPILE+" - "+COMPILE-AND-EXECUTE+" - "+LIST-BASE+" - "+LIST-INDEX+" - "+LIST-MODE+" - - ;; Depth Buffer - - "+NEVER+" - "+LESS+" - "+EQUAL+" - "+LEQUAL+" - "+GREATER+" - "+NOTEQUAL+" - "+GEQUAL+" - "+ALWAYS+" - "+DEPTH-TEST+" - "+DEPTH-BITS+" - "+DEPTH-CLEAR-VALUE+" - "+DEPTH-FUNC+" - "+DEPTH-RANGE+" - "+DEPTH-WRITEMASK+" - "+DEPTH-COMPONENT+" - - ;; Lighting - - "+LIGHTING+" - "+LIGHT0+" - "+LIGHT1+" - "+LIGHT2+" - "+LIGHT3+" - "+LIGHT4+" - "+LIGHT5+" - "+LIGHT6+" - "+LIGHT7+" - "+SPOT-EXPONENT+" - "+SPOT-CUTOFF+" - "+CONSTANT-ATTENUATION+" - "+LINEAR-ATTENUATION+" - "+QUADRATIC-ATTENUATION+" - "+AMBIENT+" - "+DIFFUSE+" - "+SPECULAR+" - "+SHININESS+" - "+EMISSION+" - "+POSITION+" - "+SPOT-DIRECTION+" - "+AMBIENT-AND-DIFFUSE+" - "+COLOR-INDEXES+" - "+LIGHT-MODEL-TWO-SIDE+" - "+LIGHT-MODEL-LOCAL-VIEWER+" - "+LIGHT-MODEL-AMBIENT+" - "+FRONT-AND-BACK+" - "+SHADE-MODEL+" - "+FLAT+" - "+SMOOTH+" - "+COLOR-MATERIAL+" - "+COLOR-MATERIAL-FACE+" - "+COLOR-MATERIAL-PARAMETER+" - "+NORMALIZE+" - - ;; Clipping planes - - "+CLIP-PLANE0+" - "+CLIP-PLANE1+" - "+CLIP-PLANE2+" - "+CLIP-PLANE3+" - "+CLIP-PLANE4+" - "+CLIP-PLANE5+" - - ;; Accumulation buffer - - "+ACCUM-RED-BITS+" - "+ACCUM-GREEN-BITS+" - "+ACCUM-BLUE-BITS+" - "+ACCUM-ALPHA-BITS+" - "+ACCUM-CLEAR-VALUE+" - "+ACCUM+" - "+ADD+" - "+LOAD+" - "+MULT+" - "+RETURN+" - - ;; Alpha Testing - - "+ALPHA-TEST+" - "+ALPHA-TEST-REF+" - "+ALPHA-TEST-FUNC+" - - ;; Blending - - "+BLEND+" - "+BLEND-SRC+" - "+BLEND-DST+" - "+ZERO+" - "+ONE+" - "+SRC-COLOR+" - "+ONE-MINUS-SRC-COLOR+" - "+DST-COLOR+" - "+ONE-MINUS-DST-COLOR+" - "+SRC-ALPHA+" - "+ONE-MINUS-SRC-ALPHA+" - "+DST-ALPHA+" - "+ONE-MINUS-DST-ALPHA+" - "+SRC-ALPHA-SATURATE+" - "+CONSTANT-COLOR+" - "+ONE-MINUS-CONSTANT-COLOR+" - "+CONSTANT-ALPHA+" - "+ONE-MINUS-CONSTANT-ALPHA+" - - ;; Render mode - - "+FEEDBACK+" - "+RENDER+" - "+SELECT+" - - ;; Feedback - - "+2D+" - "+3D+" - "+3D-COLOR+" - "+3D-COLOR-TEXTURE+" - "+4D-COLOR-TEXTURE+" - "+POINT-TOKEN+" - "+LINE-TOKEN+" - "+LINE-RESET-TOKEN+" - "+POLYGON-TOKEN+" - "+BITMAP-TOKEN+" - "+DRAW-PIXEL-TOKEN+" - "+COPY-PIXEL-TOKEN+" - "+PASS-THROUGH-TOKEN+" - "+FEEDBACK-BUFFER-POINTER+" - "+FEEDBACK-BUFFER-SIZE+" - "+FEEDBACK-BUFFER-TYPE+" - - ;; Selection - - "+SELECTION-BUFFER-POINTER+" - "+SELECTION-BUFFER-SIZE+" - - ;; Fog - - "+FOG+" - "+FOG-MODE+" - "+FOG-DENSITY+" - "+FOG-COLOR+" - "+FOG-INDEX+" - "+FOG-START+" - "+FOG-END+" - "+LINEAR+" - "+EXP+" - "+EXP2+" - - ;; Logic operations - - "+LOGIC-OP+" - "+INDEX-LOGIC-OP+" - "+COLOR-LOGIC-OP+" - "+LOGIC-OP-MODE+" - "+CLEAR+" - "+SET+" - "+COPY+" - "+COPY-INVERTED+" - "+NOOP+" - "+INVERT+" - "+AND+" - "+NAND+" - "+OR+" - "+NOR+" - "+XOR+" - "+EQUIV+" - "+AND-REVERSE+" - "+AND-INVERTED+" - "+OR-REVERSE+" - "+OR-INVERTED+" - - ;; Stencil - - "+STENCIL-TEST+" - "+STENCIL-WRITEMASK+" - "+STENCIL-BITS+" - "+STENCIL-FUNC+" - "+STENCIL-VALUE-MASK+" - "+STENCIL-REF+" - "+STENCIL-FAIL+" - "+STENCIL-PASS-DEPTH-PASS+" - "+STENCIL-PASS-DEPTH-FAIL+" - "+STENCIL-CLEAR-VALUE+" - "+STENCIL-INDEX+" - "+KEEP+" - "+REPLACE+" - "+INCR+" - "+DECR+" - - ;; Buffers, Pixel Drawing/Reading - - "+NONE+" - "+LEFT+" - "+RIGHT+" - "+FRONT-LEFT+" - "+FRONT-RIGHT+" - "+BACK-LEFT+" - "+BACK-RIGHT+" - "+AUX0+" - "+AUX1+" - "+AUX2+" - "+AUX3+" - "+COLOR-INDEX+" - "+RED+" - "+GREEN+" - "+BLUE+" - "+ALPHA+" - "+LUMINANCE+" - "+LUMINANCE-ALPHA+" - "+ALPHA-BITS+" - "+RED-BITS+" - "+GREEN-BITS+" - "+BLUE-BITS+" - "+INDEX-BITS+" - "+SUBPIXEL-BITS+" - "+AUX-BUFFERS+" - "+READ-BUFFER+" - "+DRAW-BUFFER+" - "+DOUBLEBUFFER+" - "+STEREO+" - "+BITMAP+" - "+COLOR+" - "+DEPTH+" - "+STENCIL+" - "+DITHER+" - "+RGB+" - "+RGBA+" - - ;; Implementation Limits - - "+MAX-LIST-NESTING+" - "+MAX-ATTRIB-STACK-DEPTH+" - "+MAX-MODELVIEW-STACK-DEPTH+" - "+MAX-NAME-STACK-DEPTH+" - "+MAX-PROJECTION-STACK-DEPTH+" - "+MAX-TEXTURE-STACK-DEPTH+" - "+MAX-EVAL-ORDER+" - "+MAX-LIGHTS+" - "+MAX-CLIP-PLANES+" - "+MAX-TEXTURE-SIZE+" - "+MAX-PIXEL-MAP-TABLE+" - "+MAX-VIEWPORT-DIMS+" - "+MAX-CLIENT-ATTRIB-STACK-DEPTH+" - - ;; Gets - - "+ATTRIB-STACK-DEPTH+" - "+CLIENT-ATTRIB-STACK-DEPTH+" - "+COLOR-CLEAR-VALUE+" - "+COLOR-WRITEMASK+" - "+CURRENT-INDEX+" - "+CURRENT-COLOR+" - "+CURRENT-NORMAL+" - "+CURRENT-RASTER-COLOR+" - "+CURRENT-RASTER-DISTANCE+" - "+current-raster-index+" - "+CURRENT-RASTER-POSITION+" - "+CURRENT-RASTER-TEXTURE-COORDS+" - "+CURRENT-RASTER-POSITION-VALID+" - "+CURRENT-TEXTURE-COORDS+" - "+INDEX-CLEAR-VALUE+" - "+INDEX-MODE+" - "+INDEX-WRITEMASK+" - "+MODELVIEW-MATRIX+" - "+MODELVIEW-STACK-DEPTH+" - "+NAME-STACK-DEPTH+" - "+PROJECTION-MATRIX+" - "+PROJECTION-STACK-DEPTH+" - "+RENDER-MODE+" - "+RGBA-MODE+" - "+TEXTURE-MATRIX+" - "+TEXTURE-STACK-DEPTH+" - "+VIEWPORT+" - - ;; GL Evaluators - - "+AUTO-NORMAL+" - "+MAP1-COLOR-4+" - "+MAP1-GRID-DOMAIN+" - "+MAP1-GRID-SEGMENTS+" - "+MAP1-INDEX+" - "+MAP1-NORMAL+" - "+MAP1-TEXTURE-COORD-1+" - "+MAP1-TEXTURE-COORD-2+" - "+MAP1-TEXTURE-COORD-3+" - "+MAP1-TEXTURE-COORD-4+" - "+MAP1-VERTEX-3+" - "+MAP1-VERTEX-4+" - "+MAP2-COLOR-4+" - "+MAP2-GRID-DOMAIN+" - "+MAP2-GRID-SEGMENTS+" - "+MAP2-INDEX+" - "+MAP2-NORMAL+" - "+MAP2-TEXTURE-COORD-1+" - "+MAP2-TEXTURE-COORD-2+" - "+MAP2-TEXTURE-COORD-3+" - "+MAP2-TEXTURE-COORD-4+" - "+MAP2-VERTEX-3+" - "+MAP2-VERTEX-4+" - "+COEFF+" - "+DOMAIN+" - "+ORDER+" - - ;; Hints - - "+FOG-HINT+" - "+LINE-SMOOTH-HINT+" - "+PERSPECTIVE-CORRECTION-HINT+" - "+POINT-SMOOTH-HINT+" - "+POLYGON-SMOOTH-HINT+" - "+DONT-CARE+" - "+FASTEST+" - "+NICEST+" - - ;; Scissor box - - "+SCISSOR-TEST+" - "+SCISSOR-BOX+" - - ;; Pixel Mode / Transfer - - "+MAP-COLOR+" - "+MAP-STENCIL+" - "+INDEX-SHIFT+" - "+INDEX-OFFSET+" - "+RED-SCALE+" - "+RED-BIAS+" - "+GREEN-SCALE+" - "+GREEN-BIAS+" - "+BLUE-SCALE+" - "+BLUE-BIAS+" - "+ALPHA-SCALE+" - "+ALPHA-BIAS+" - "+DEPTH-SCALE+" - "+DEPTH-BIAS+" - "+PIXEL-MAP-S-TO-S-SIZE+" - "+PIXEL-MAP-I-TO-I-SIZE+" - "+PIXEL-MAP-I-TO-R-SIZE+" - "+PIXEL-MAP-I-TO-G-SIZE+" - "+PIXEL-MAP-I-TO-B-SIZE+" - "+PIXEL-MAP-I-TO-A-SIZE+" - "+PIXEL-MAP-R-TO-R-SIZE+" - "+PIXEL-MAP-G-TO-G-SIZE+" - "+PIXEL-MAP-B-TO-B-SIZE+" - "+PIXEL-MAP-A-TO-A-SIZE+" - "+PIXEL-MAP-S-TO-S+" - "+PIXEL-MAP-I-TO-I+" - "+PIXEL-MAP-I-TO-R+" - "+PIXEL-MAP-I-TO-G+" - "+PIXEL-MAP-I-TO-B+" - "+PIXEL-MAP-I-TO-A+" - "+PIXEL-MAP-R-TO-R+" - "+PIXEL-MAP-G-TO-G+" - "+PIXEL-MAP-B-TO-B+" - "+PIXEL-MAP-A-TO-A+" - "+PACK-ALIGNMENT+" - "+PACK-LSB-FIRST+" - "+PACK-ROW-LENGTH+" - "+PACK-SKIP-PIXELS+" - "+PACK-SKIP-ROWS+" - "+PACK-SWAP-BYTES+" - "+UNPACK-ALIGNMENT+" - "+UNPACK-LSB-FIRST+" - "+UNPACK-ROW-LENGTH+" - "+UNPACK-SKIP-PIXELS+" - "+UNPACK-SKIP-ROWS+" - "+UNPACK-SWAP-BYTES+" - "+ZOOM-X+" - "+ZOOM-Y+" - - ;; Texture Mapping - - "+TEXTURE-ENV+" - "+TEXTURE-ENV-MODE+" - "+TEXTURE-1D+" - "+TEXTURE-2D+" - "+TEXTURE-WRAP-S+" - "+TEXTURE-WRAP-T+" - "+TEXTURE-MAG-FILTER+" - "+TEXTURE-MIN-FILTER+" - "+TEXTURE-ENV-COLOR+" - "+TEXTURE-GEN-S+" - "+TEXTURE-GEN-T+" - "+TEXTURE-GEN-MODE+" - "+TEXTURE-BORDER-COLOR+" - "+TEXTURE-WIDTH+" - "+TEXTURE-HEIGHT+" - "+TEXTURE-BORDER+" - "+TEXTURE-COMPONENTS+" - "+TEXTURE-RED-SIZE+" - "+TEXTURE-GREEN-SIZE+" - "+TEXTURE-BLUE-SIZE+" - "+TEXTURE-ALPHA-SIZE+" - "+TEXTURE-LUMINANCE-SIZE+" - "+TEXTURE-INTENSITY-SIZE+" - "+NEAREST-MIPMAP-NEAREST+" - "+NEAREST-MIPMAP-LINEAR+" - "+LINEAR-MIPMAP-NEAREST+" - "+LINEAR-MIPMAP-LINEAR+" - "+OBJECT-LINEAR+" - "+OBJECT-PLANE+" - "+EYE-LINEAR+" - "+EYE-PLANE+" - "+SPHERE-MAP+" - "+DECAL+" - "+MODULATE+" - "+NEAREST+" - "+REPEAT+" - "+CLAMP+" - "+S+" - "+T+" - "+R+" - "+Q+" - "+TEXTURE-GEN-R+" - "+TEXTURE-GEN-Q+" - - ;; GL 1.1 Texturing - - "+PROXY-TEXTURE-1D+" - "+PROXY-TEXTURE-2D+" - "+TEXTURE-PRIORITY+" - "+TEXTURE-RESIDENT+" - "+TEXTURE-BINDING-1D+" - "+TEXTURE-BINDING-2D+" - "+TEXTURE-INTERNAL-FORMAT+" - "+PACK-SKIP-IMAGES+" - "+PACK-IMAGE-HEIGHT+" - "+UNPACK-SKIP-IMAGES+" - "+UNPACK-IMAGE-HEIGHT+" - "+TEXTURE-3D+" - "+PROXY-TEXTURE-3D+" - "+TEXTURE-DEPTH+" - "+TEXTURE-WRAP-R+" - "+MAX-3D-TEXTURE-SIZE+" - "+TEXTURE-BINDING-3D+" - - ;; Internal texture formats (GL 1.1) - "+ALPHA4+" - "+ALPHA8+" - "+ALPHA12+" - "+ALPHA16+" - "+LUMINANCE4+" - "+LUMINANCE8+" - "+LUMINANCE12+" - "+LUMINANCE16+" - "+LUMINANCE4-ALPHA4+" - "+LUMINANCE6-ALPHA2+" - "+LUMINANCE8-ALPHA8+" - "+LUMINANCE12-ALPHA4+" - "+LUMINANCE12-ALPHA12+" - "+LUMINANCE16-ALPHA16+" - "+INTENSITY+" - "+INTENSITY4+" - "+INTENSITY8+" - "+INTENSITY12+" - "+INTENSITY16+" - "+R3-G3-B2+" - "+RGB4+" - "+RGB5+" - "+RGB8+" - "+RGB10+" - "+RGB12+" - "+RGB16+" - "+RGBA2+" - "+RGBA4+" - "+RGB5-A1+" - "+RGBA8+" - "+rgb10-a2+" - "+RGBA12+" - "+RGBA16+" - - ;; Utility - - "+VENDOR+" - "+RENDERER+" - "+VERSION+" - "+EXTENSIONS+" - - ;; Errors - - "+NO-ERROR+" - "+INVALID-VALUE+" - "+INVALID-ENUM+" - "+INVALID-OPERATION+" - "+STACK-OVERFLOW+" - "+STACK-UNDERFLOW+" - "+OUT-OF-MEMORY+" - - ;; OpenGL 1.2 - - "+RESCALE-NORMAL+" - "+CLAMP-TO-EDGE+" - "+MAX-ELEMENTS-VERTICES+" - "+MAX-ELEMENTS-INDICES+" - "+BGR+" - "+BGRA+" - "+UNSIGNED-BYTE-3-3-2+" - "+UNSIGNED-BYTE-2-3-3-REV+" - "+UNSIGNED-SHORT-5-6-5+" - "+UNSIGNED-SHORT-5-6-5-REV+" - "+UNSIGNED-SHORT-4-4-4-4+" - "+UNSIGNED-SHORT-4-4-4-4-REV+" - "+UNSIGNED-SHORT-5-5-5-1+" - "+UNSIGNED-SHORT-1-5-5-5-REV+" - "+UNSIGNED-INT-8-8-8-8+" - "+UNSIGNED-INT-8-8-8-8-REV+" - "+UNSIGNED-INT-10-10-10-2+" - "+UNSIGNED-INT-2-10-10-10-REV+" - "+LIGHT-MODEL-COLOR-CONTROL+" - "+SINGLE-COLOR+" - "+SEPARATE-SPECULAR-COLOR+" - "+TEXTURE-MIN-LOD+" - "+TEXTURE-MAX-LOD+" - "+TEXTURE-BASE-LEVEL+" - "+TEXTURE-MAX-LEVEL+" - "+SMOOTH-POINT-SIZE-RANGE+" - "+SMOOTH-POINT-SIZE-GRANULARITY+" - "+SMOOTH-LINE-WIDTH-RANGE+" - "+SMOOTH-LINE-WIDTH-GRANULARITY+" - "+ALIASED-POINT-SIZE-RANGE+" - "+ALIASED-LINE-WIDTH-RANGE+" - - ;; OpenGL 1.2 Imaging subset - ;; GL_EXT_color_table - "+COLOR-TABLE+" - "+POST-CONVOLUTION-COLOR-TABLE+" - "+POST-COLOR-MATRIX-COLOR-TABLE+" - "+PROXY-COLOR-TABLE+" - "+PROXY-POST-CONVOLUTION-COLOR-TABLE+" - "+PROXY-POST-COLOR-MATRIX-COLOR-TABLE+" - "+COLOR-TABLE-SCALE+" - "+COLOR-TABLE-BIAS+" - "+COLOR-TABLE-FORMAT+" - "+COLOR-TABLE-WIDTH+" - "+COLOR-TABLE-RED-SIZE+" - "+COLOR-TABLE-GREEN-SIZE+" - "+COLOR-TABLE-BLUE-SIZE+" - "+COLOR-TABLE-ALPHA-SIZE+" - "+COLOR-TABLE-LUMINANCE-SIZE+" - "+COLOR-TABLE-INTENSITY-SIZE+" - ;; GL_EXT_convolution and GL_HP_convolution - "+CONVOLUTION-1D+" - "+CONVOLUTION-2D+" - "+SEPARABLE-2D+" - "+CONVOLUTION-BORDER-MODE+" - "+CONVOLUTION-FILTER-SCALE+" - "+CONVOLUTION-FILTER-BIAS+" - "+REDUCE+" - "+CONVOLUTION-FORMAT+" - "+CONVOLUTION-WIDTH+" - "+CONVOLUTION-HEIGHT+" - "+MAX-CONVOLUTION-WIDTH+" - "+MAX-CONVOLUTION-HEIGHT+" - "+POST-CONVOLUTION-RED-SCALE+" - "+POST-CONVOLUTION-GREEN-SCALE+" - "+POST-CONVOLUTION-BLUE-SCALE+" - "+POST-CONVOLUTION-ALPHA-SCALE+" - "+POST-CONVOLUTION-RED-BIAS+" - "+POST-CONVOLUTION-GREEN-BIAS+" - "+POST-CONVOLUTION-BLUE-BIAS+" - "+POST-CONVOLUTION-ALPHA-BIAS+" - "+CONSTANT-BORDER+" - "+REPLICATE-BORDER+" - "+CONVOLUTION-BORDER-COLOR+" - ;; GL_SGI_color_matrix - "+COLOR-MATRIX+" - "+COLOR-MATRIX-STACK-DEPTH+" - "+MAX-COLOR-MATRIX-STACK-DEPTH+" - "+POST-COLOR-MATRIX-RED-SCALE+" - "+POST-COLOR-MATRIX-GREEN-SCALE+" - "+POST-COLOR-MATRIX-BLUE-SCALE+" - "+POST-COLOR-MATRIX-ALPHA-SCALE+" - "+POST-COLOR-MATRIX-RED-BIAS+" - "+POST-COLOR-MATRIX-GREEN-BIAS+" - "+POST-COLOR-MATRIX-BLUE-BIAS+" - "+POST-COLOR-MATRIX-ALPHA-BIAS+" - ;; GL_EXT_histogram - "+HISTOGRAM+" - "+PROXY-HISTOGRAM+" - "+HISTOGRAM-WIDTH+" - "+HISTOGRAM-FORMAT+" - "+HISTOGRAM-RED-SIZE+" - "+HISTOGRAM-GREEN-SIZE+" - "+HISTOGRAM-BLUE-SIZE+" - "+HISTOGRAM-ALPHA-SIZE+" - "+HISTOGRAM-LUMINANCE-SIZE+" - "+HISTOGRAM-SINK+" - "+MINMAX+" - "+MINMAX-FORMAT+" - "+MINMAX-SINK+" - "+TABLE-TOO-LARGE+" - ;; GL_EXT_blend_color, GL_EXT_blend_minmax - "+BLEND-EQUATION+" - "+MIN+" - "+MAX+" - "+FUNC-ADD+" - "+FUNC-SUBTRACT+" - "+FUNC-REVERSE-SUBTRACT+" - - ;; glPush/PopAttrib bits - - "+CURRENT-BIT+" - "+POINT-BIT+" - "+LINE-BIT+" - "+POLYGON-BIT+" - "+POLYGON-STIPPLE-BIT+" - "+PIXEL-MODE-BIT+" - "+LIGHTING-BIT+" - "+FOG-BIT+" - "+DEPTH-BUFFER-BIT+" - "+ACCUM-BUFFER-BIT+" - "+STENCIL-BUFFER-BIT+" - "+VIEWPORT-BIT+" - "+TRANSFORM-BIT+" - "+ENABLE-BIT+" - "+COLOR-BUFFER-BIT+" - "+HINT-BIT+" - "+EVAL-BIT+" - "+LIST-BIT+" - "+TEXTURE-BIT+" - "+SCISSOR-BIT+" - "+ALL-ATTRIB-BITS+" - "+CLIENT-PIXEL-STORE-BIT+" - "+CLIENT-VERTEX-ARRAY-BIT+" - "+CLIENT-ALL-ATTRIB-BITS+" - - ;; ARB Multitexturing extension - - "+ARB-MULTITEXTURE+" - "+TEXTURE0-ARB+" - "+TEXTURE1-ARB+" - "+TEXTURE2-ARB+" - "+TEXTURE3-ARB+" - "+TEXTURE4-ARB+" - "+TEXTURE5-ARB+" - "+TEXTURE6-ARB+" - "+TEXTURE7-ARB+" - "+TEXTURE8-ARB+" - "+TEXTURE9-ARB+" - "+TEXTURE10-ARB+" - "+TEXTURE11-ARB+" - "+TEXTURE12-ARB+" - "+TEXTURE13-ARB+" - "+TEXTURE14-ARB+" - "+TEXTURE15-ARB+" - "+TEXTURE16-ARB+" - "+TEXTURE17-ARB+" - "+TEXTURE18-ARB+" - "+TEXTURE19-ARB+" - "+TEXTURE20-ARB+" - "+TEXTURE21-ARB+" - "+TEXTURE22-ARB+" - "+TEXTURE23-ARB+" - "+TEXTURE24-ARB+" - "+TEXTURE25-ARB+" - "+TEXTURE26-ARB+" - "+TEXTURE27-ARB+" - "+TEXTURE28-ARB+" - "+TEXTURE29-ARB+" - "+TEXTURE30-ARB+" - "+TEXTURE31-ARB+" - "+ACTIVE-TEXTURE-ARB+" - "+CLIENT-ACTIVE-TEXTURE-ARB+" - "+MAX-TEXTURE-UNITS-ARB+" - -;;; Misc extensions - - "+EXT-ABGR+" - "+ABGR-EXT+" - "+EXT-BLEND-COLOR+" - "+CONSTANT-COLOR-EXT+" - "+ONE-MINUS-CONSTANT-COLOR-EXT+" - "+CONSTANT-ALPHA-EXT+" - "+ONE-MINUS-CONSTANT-ALPHA-EXT+" - "+blend-color-ext+" - "+EXT-POLYGON-OFFSET+" - "+POLYGON-OFFSET-EXT+" - "+POLYGON-OFFSET-FACTOR-EXT+" - "+POLYGON-OFFSET-BIAS-EXT+" - "+EXT-TEXTURE3D+" - "+PACK-SKIP-IMAGES-EXT+" - "+PACK-IMAGE-HEIGHT-EXT+" - "+UNPACK-SKIP-IMAGES-EXT+" - "+UNPACK-IMAGE-HEIGHT-EXT+" - "+TEXTURE-3D-EXT+" - "+PROXY-TEXTURE-3D-EXT+" - "+TEXTURE-DEPTH-EXT+" - "+TEXTURE-WRAP-R-EXT+" - "+MAX-3D-TEXTURE-SIZE-EXT+" - "+TEXTURE-3D-BINDING-EXT+" - "+EXT-TEXTURE-OBJECT+" - "+TEXTURE-PRIORITY-EXT+" - "+TEXTURE-RESIDENT-EXT+" - "+TEXTURE-1D-BINDING-EXT+" - "+TEXTURE-2D-BINDING-EXT+" - "+EXT-RESCALE-NORMAL+" - "+RESCALE-NORMAL-EXT+" - "+EXT-VERTEX-ARRAY+" - "+VERTEX-ARRAY-EXT+" - "+NORMAL-ARRAY-EXT+" - "+COLOR-ARRAY-EXT+" - "+INDEX-ARRAY-EXT+" - "+TEXTURE-COORD-ARRAY-EXT+" - "+EDGE-FLAG-ARRAY-EXT+" - "+VERTEX-ARRAY-SIZE-EXT+" - "+VERTEX-ARRAY-TYPE-EXT+" - "+VERTEX-ARRAY-STRIDE-EXT+" - "+VERTEX-ARRAY-COUNT-EXT+" - "+NORMAL-ARRAY-TYPE-EXT+" - "+NORMAL-ARRAY-STRIDE-EXT+" - "+NORMAL-ARRAY-COUNT-EXT+" - "+COLOR-ARRAY-SIZE-EXT+" - "+COLOR-ARRAY-TYPE-EXT+" - "+COLOR-ARRAY-STRIDE-EXT+" - "+COLOR-ARRAY-COUNT-EXT+" - "+INDEX-ARRAY-TYPE-EXT+" - "+INDEX-ARRAY-STRIDE-EXT+" - "+INDEX-ARRAY-COUNT-EXT+" - "+TEXTURE-COORD-ARRAY-SIZE-EXT+" - "+TEXTURE-COORD-ARRAY-TYPE-EXT+" - "+TEXTURE-COORD-ARRAY-STRIDE-EXT+" - "+TEXTURE-COORD-ARRAY-COUNT-EXT+" - "+EDGE-FLAG-ARRAY-STRIDE-EXT+" - "+EDGE-FLAG-ARRAY-COUNT-EXT+" - "+VERTEX-ARRAY-POINTER-EXT+" - "+NORMAL-ARRAY-POINTER-EXT+" - "+COLOR-ARRAY-POINTER-EXT+" - "+INDEX-ARRAY-POINTER-EXT+" - "+TEXTURE-COORD-ARRAY-POINTER-EXT+" - "+EDGE-FLAG-ARRAY-POINTER-EXT+" - "+SGIS-TEXTURE-EDGE-CLAMP+" - "+CLAMP-TO-EDGE-SGIS+" - "+EXT-BLEND-MINMAX+" - "+FUNC-ADD-EXT+" - "+MIN-EXT+" - "+MAX-EXT+" - "+BLEND-EQUATION-EXT+" - "+EXT-BLEND-SUBTRACT+" - "+FUNC-SUBTRACT-EXT+" - "+FUNC-REVERSE-SUBTRACT-EXT+" - "+EXT-BLEND-LOGIC-OP+" - "+EXT-POINT-PARAMETERS+" - "+POINT-SIZE-MIN-EXT+" - "+POINT-SIZE-MAX-EXT+" - "+POINT-FADE-THRESHOLD-SIZE-EXT+" - "+DISTANCE-ATTENUATION-EXT+" - "+EXT-PALETTED-TEXTURE+" - "+TABLE-TOO-LARGE-EXT+" - "+COLOR-TABLE-FORMAT-EXT+" - "+COLOR-TABLE-WIDTH-EXT+" - "+COLOR-TABLE-RED-SIZE-EXT+" - "+COLOR-TABLE-GREEN-SIZE-EXT+" - "+COLOR-TABLE-BLUE-SIZE-EXT+" - "+COLOR-TABLE-ALPHA-SIZE-EXT+" - "+COLOR-TABLE-LUMINANCE-SIZE-EXT+" - "+COLOR-TABLE-INTENSITY-SIZE-EXT+" - "+TEXTURE-INDEX-SIZE-EXT+" - "+COLOR-INDEX1-EXT+" - "+COLOR-INDEX2-EXT+" - "+COLOR-INDEX4-EXT+" - "+COLOR-INDEX8-EXT+" - "+COLOR-INDEX12-EXT+" - "+COLOR-INDEX16-EXT+" - "+EXT-CLIP-VOLUME-HINT+" - "+CLIP-VOLUME-CLIPPING-HINT-EXT+" - "+EXT-COMPILED-VERTEX-ARRAY+" - "+ARRAY-ELEMENT-LOCK-FIRST-EXT+" - "+ARRAY-ELEMENT-LOCK-COUNT-EXT+" - "+HP-OCCLUSION-TEST+" - "+OCCLUSION-TEST-HP+" - "+OCCLUSION-TEST-RESULT-HP+" - "+EXT-SHARED-TEXTURE-PALETTE+" - "+SHARED-TEXTURE-PALETTE-EXT+" - "+EXT-STENCIL-WRAP+" - "+INCR-WRAP-EXT+" - "+DECR-WRAP-EXT+" - "+NV-TEXGEN-REFLECTION+" - "+NORMAL-MAP-NV+" - "+REFLECTION-MAP-NV+" - "+EXT-TEXTURE-ENV-ADD+" - "+MESA-WINDOW-POS+" - "+MESA-RESIZE-BUFFERS+" - - )) - - -(in-package :gl) - - - -;;; Opcodes. - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant +get-string+ 129) -(defconstant +new-list+ 101) -(defconstant +end-list+ 102) -(defconstant +gen-lists+ 104) -(defconstant +finish+ 108) -(defconstant +disable+ 138) -(defconstant +enable+ 139) -(defconstant +flush+ 142) - - - -;;; Constants. -;;; Shamelessly taken from CL-SDL. - -;; Boolean - -(defconstant +false+ #x0) -(defconstant +true+ #x1) - -;; Types - -(defconstant +byte+ #x1400) -(defconstant +unsigned-byte+ #x1401) -(defconstant +short+ #x1402) -(defconstant +unsigned-short+ #x1403) -(defconstant +int+ #x1404) -(defconstant +unsigned-int+ #x1405) -(defconstant +float+ #x1406) -(defconstant +double+ #x140a) -(defconstant +2-bytes+ #x1407) -(defconstant +3-bytes+ #x1408) -(defconstant +4-bytes+ #x1409) - -;; Primitives - -(defconstant +points+ #x0000) -(defconstant +lines+ #x0001) -(defconstant +line-loop+ #x0002) -(defconstant +line-strip+ #x0003) -(defconstant +triangles+ #x0004) -(defconstant +triangle-strip+ #x0005) -(defconstant +triangle-fan+ #x0006) -(defconstant +quads+ #x0007) -(defconstant +quad-strip+ #x0008) -(defconstant +polygon+ #x0009) - -;; Arrays - -(defconstant +vertex-array+ #x8074) -(defconstant +normal-array+ #x8075) -(defconstant +color-array+ #x8076) -(defconstant +index-array+ #x8077) -(defconstant +texture-coord-array+ #x8078) -(defconstant +edge-flag-array+ #x8079) -(defconstant +vertex-array-size+ #x807a) -(defconstant +vertex-array-type+ #x807b) -(defconstant +vertex-array-stride+ #x807c) -(defconstant +normal-array-type+ #x807e) -(defconstant +normal-array-stride+ #x807f) -(defconstant +color-array-size+ #x8081) -(defconstant +color-array-type+ #x8082) -(defconstant +color-array-stride+ #x8083) -(defconstant +index-array-type+ #x8085) -(defconstant +index-array-stride+ #x8086) -(defconstant +texture-coord-array-size+ #x8088) -(defconstant +texture-coord-array-type+ #x8089) -(defconstant +texture-coord-array-stride+ #x808a) -(defconstant +edge-flag-array-stride+ #x808c) -(defconstant +vertex-array-pointer+ #x808e) -(defconstant +normal-array-pointer+ #x808f) -(defconstant +color-array-pointer+ #x8090) -(defconstant +index-array-pointer+ #x8091) -(defconstant +texture-coord-array-pointer+ #x8092) -(defconstant +edge-flag-array-pointer+ #x8093) - -;; Array formats - -(defconstant +v2f+ #x2a20) -(defconstant +v3f+ #x2a21) -(defconstant +c4ub-v2f+ #x2a22) -(defconstant +c4ub-v3f+ #x2a23) -(defconstant +c3f-v3f+ #x2a24) -(defconstant +n3f-v3f+ #x2a25) -(defconstant +c4f-n3f-v3f+ #x2a26) -(defconstant +t2f-v3f+ #x2a27) -(defconstant +t4f-v4f+ #x2a28) -(defconstant +t2f-c4ub-v3f+ #x2a29) -(defconstant +t2f-c3f-v3f+ #x2a2a) -(defconstant +t2f-n3f-v3f+ #x2a2b) -(defconstant +t2f-c4f-n3f-v3f+ #x2a2c) -(defconstant +t4f-c4f-n3f-v4f+ #x2a2d) - -;; Matrices - -(defconstant +matrix-mode+ #x0ba0) -(defconstant +modelview+ #x1700) -(defconstant +projection+ #x1701) -(defconstant +texture+ #x1702) - -;; Points - -(defconstant +point-smooth+ #x0b10) -(defconstant +point-size+ #x0b11) -(defconstant +point-size-granularity+ #x0b13) -(defconstant +point-size-range+ #x0b12) - -;; Lines - -(defconstant +line-smooth+ #x0b20) -(defconstant +line-stipple+ #x0b24) -(defconstant +line-stipple-pattern+ #x0b25) -(defconstant +line-stipple-repeat+ #x0b26) -(defconstant +line-width+ #x0b21) -(defconstant +line-width-granularity+ #x0b23) -(defconstant +line-width-range+ #x0b22) - -;; Polygons - -(defconstant +point+ #x1b00) -(defconstant +line+ #x1b01) -(defconstant +fill+ #x1b02) -(defconstant +cw+ #x0900) -(defconstant +ccw+ #x0901) -(defconstant +front+ #x0404) -(defconstant +back+ #x0405) -(defconstant +polygon-mode+ #x0b40) -(defconstant +polygon-smooth+ #x0b41) -(defconstant +polygon-stipple+ #x0b42) -(defconstant +edge-flag+ #x0b43) -(defconstant +cull-face+ #x0b44) -(defconstant +cull-face-mode+ #x0b45) -(defconstant +front-face+ #x0b46) -(defconstant +polygon-offset-factor+ #x8038) -(defconstant +polygon-offset-units+ #x2a00) -(defconstant +polygon-offset-point+ #x2a01) -(defconstant +polygon-offset-line+ #x2a02) -(defconstant +polygon-offset-fill+ #x8037) - -;; Display Lists - -(defconstant +compile+ #x1300) -(defconstant +compile-and-execute+ #x1301) -(defconstant +list-base+ #x0b32) -(defconstant +list-index+ #x0b33) -(defconstant +list-mode+ #x0b30) - -;; Depth Buffer - -(defconstant +never+ #x0200) -(defconstant +less+ #x0201) -(defconstant +equal+ #x0202) -(defconstant +lequal+ #x0203) -(defconstant +greater+ #x0204) -(defconstant +notequal+ #x0205) -(defconstant +gequal+ #x0206) -(defconstant +always+ #x0207) -(defconstant +depth-test+ #x0b71) -(defconstant +depth-bits+ #x0d56) -(defconstant +depth-clear-value+ #x0b73) -(defconstant +depth-func+ #x0b74) -(defconstant +depth-range+ #x0b70) -(defconstant +depth-writemask+ #x0b72) -(defconstant +depth-component+ #x1902) - -;; Lighting - -(defconstant +lighting+ #x0b50) -(defconstant +light0+ #x4000) -(defconstant +light1+ #x4001) -(defconstant +light2+ #x4002) -(defconstant +light3+ #x4003) -(defconstant +light4+ #x4004) -(defconstant +light5+ #x4005) -(defconstant +light6+ #x4006) -(defconstant +light7+ #x4007) -(defconstant +spot-exponent+ #x1205) -(defconstant +spot-cutoff+ #x1206) -(defconstant +constant-attenuation+ #x1207) -(defconstant +linear-attenuation+ #x1208) -(defconstant +quadratic-attenuation+ #x1209) -(defconstant +ambient+ #x1200) -(defconstant +diffuse+ #x1201) -(defconstant +specular+ #x1202) -(defconstant +shininess+ #x1601) -(defconstant +emission+ #x1600) -(defconstant +position+ #x1203) -(defconstant +spot-direction+ #x1204) -(defconstant +ambient-and-diffuse+ #x1602) -(defconstant +color-indexes+ #x1603) -(defconstant +light-model-two-side+ #x0b52) -(defconstant +light-model-local-viewer+ #x0b51) -(defconstant +light-model-ambient+ #x0b53) -(defconstant +front-and-back+ #x0408) -(defconstant +shade-model+ #x0b54) -(defconstant +flat+ #x1d00) -(defconstant +smooth+ #x1d01) -(defconstant +color-material+ #x0b57) -(defconstant +color-material-face+ #x0b55) -(defconstant +color-material-parameter+ #x0b56) -(defconstant +normalize+ #x0ba1) - -;; Clipping planes - -(defconstant +clip-plane0+ #x3000) -(defconstant +clip-plane1+ #x3001) -(defconstant +clip-plane2+ #x3002) -(defconstant +clip-plane3+ #x3003) -(defconstant +clip-plane4+ #x3004) -(defconstant +clip-plane5+ #x3005) - -;; Accumulation buffer - -(defconstant +accum-red-bits+ #x0d58) -(defconstant +accum-green-bits+ #x0d59) -(defconstant +accum-blue-bits+ #x0d5a) -(defconstant +accum-alpha-bits+ #x0d5b) -(defconstant +accum-clear-value+ #x0b80) -(defconstant +accum+ #x0100) -(defconstant +add+ #x0104) -(defconstant +load+ #x0101) -(defconstant +mult+ #x0103) -(defconstant +return+ #x0102) - -;; Alpha Testing - -(defconstant +alpha-test+ #x0bc0) -(defconstant +alpha-test-ref+ #x0bc2) -(defconstant +alpha-test-func+ #x0bc1) - -;; Blending - -(defconstant +blend+ #x0be2) -(defconstant +blend-src+ #x0be1) -(defconstant +blend-dst+ #x0be0) -(defconstant +zero+ #x0) -(defconstant +one+ #x1) -(defconstant +src-color+ #x0300) -(defconstant +one-minus-src-color+ #x0301) -(defconstant +dst-color+ #x0306) -(defconstant +one-minus-dst-color+ #x0307) -(defconstant +src-alpha+ #x0302) -(defconstant +one-minus-src-alpha+ #x0303) -(defconstant +dst-alpha+ #x0304) -(defconstant +one-minus-dst-alpha+ #x0305) -(defconstant +src-alpha-saturate+ #x0308) -(defconstant +constant-color+ #x8001) -(defconstant +one-minus-constant-color+ #x8002) -(defconstant +constant-alpha+ #x8003) -(defconstant +one-minus-constant-alpha+ #x8004) - -;; Render mode - -(defconstant +feedback+ #x1c01) -(defconstant +render+ #x1c00) -(defconstant +select+ #x1c02) - -;; Feedback - -(defconstant +2d+ #x0600) -(defconstant +3d+ #x0601) -(defconstant +3d-color+ #x0602) -(defconstant +3d-color-texture+ #x0603) -(defconstant +4d-color-texture+ #x0604) -(defconstant +point-token+ #x0701) -(defconstant +line-token+ #x0702) -(defconstant +line-reset-token+ #x0707) -(defconstant +polygon-token+ #x0703) -(defconstant +bitmap-token+ #x0704) -(defconstant +draw-pixel-token+ #x0705) -(defconstant +copy-pixel-token+ #x0706) -(defconstant +pass-through-token+ #x0700) -(defconstant +feedback-buffer-pointer+ #x0df0) -(defconstant +feedback-buffer-size+ #x0df1) -(defconstant +feedback-buffer-type+ #x0df2) - -;; Selection - -(defconstant +selection-buffer-pointer+ #x0df3) -(defconstant +selection-buffer-size+ #x0df4) - -;; Fog - -(defconstant +fog+ #x0b60) -(defconstant +fog-mode+ #x0b65) -(defconstant +fog-density+ #x0b62) -(defconstant +fog-color+ #x0b66) -(defconstant +fog-index+ #x0b61) -(defconstant +fog-start+ #x0b63) -(defconstant +fog-end+ #x0b64) -(defconstant +linear+ #x2601) -(defconstant +exp+ #x0800) -(defconstant +exp2+ #x0801) - -;; Logic operations - -(defconstant +logic-op+ #x0bf1) -(defconstant +index-logic-op+ #x0bf1) -(defconstant +color-logic-op+ #x0bf2) -(defconstant +logic-op-mode+ #x0bf0) -(defconstant +clear+ #x1500) -(defconstant +set+ #x150f) -(defconstant +copy+ #x1503) -(defconstant +copy-inverted+ #x150c) -(defconstant +noop+ #x1505) -(defconstant +invert+ #x150a) -(defconstant +and+ #x1501) -(defconstant +nand+ #x150e) -(defconstant +or+ #x1507) -(defconstant +nor+ #x1508) -(defconstant +xor+ #x1506) -(defconstant +equiv+ #x1509) -(defconstant +and-reverse+ #x1502) -(defconstant +and-inverted+ #x1504) -(defconstant +or-reverse+ #x150b) -(defconstant +or-inverted+ #x150d) - -;; Stencil - -(defconstant +stencil-test+ #x0b90) -(defconstant +stencil-writemask+ #x0b98) -(defconstant +stencil-bits+ #x0d57) -(defconstant +stencil-func+ #x0b92) -(defconstant +stencil-value-mask+ #x0b93) -(defconstant +stencil-ref+ #x0b97) -(defconstant +stencil-fail+ #x0b94) -(defconstant +stencil-pass-depth-pass+ #x0b96) -(defconstant +stencil-pass-depth-fail+ #x0b95) -(defconstant +stencil-clear-value+ #x0b91) -(defconstant +stencil-index+ #x1901) -(defconstant +keep+ #x1e00) -(defconstant +replace+ #x1e01) -(defconstant +incr+ #x1e02) -(defconstant +decr+ #x1e03) - -;; Buffers, Pixel Drawing/Reading - -(defconstant +none+ #x0) -(defconstant +left+ #x0406) -(defconstant +right+ #x0407) -(defconstant +front-left+ #x0400) -(defconstant +front-right+ #x0401) -(defconstant +back-left+ #x0402) -(defconstant +back-right+ #x0403) -(defconstant +aux0+ #x0409) -(defconstant +aux1+ #x040a) -(defconstant +aux2+ #x040b) -(defconstant +aux3+ #x040c) -(defconstant +color-index+ #x1900) -(defconstant +red+ #x1903) -(defconstant +green+ #x1904) -(defconstant +blue+ #x1905) -(defconstant +alpha+ #x1906) -(defconstant +luminance+ #x1909) -(defconstant +luminance-alpha+ #x190a) -(defconstant +alpha-bits+ #x0d55) -(defconstant +red-bits+ #x0d52) -(defconstant +green-bits+ #x0d53) -(defconstant +blue-bits+ #x0d54) -(defconstant +index-bits+ #x0d51) -(defconstant +subpixel-bits+ #x0d50) -(defconstant +aux-buffers+ #x0c00) -(defconstant +read-buffer+ #x0c02) -(defconstant +draw-buffer+ #x0c01) -(defconstant +doublebuffer+ #x0c32) -(defconstant +stereo+ #x0c33) -(defconstant +bitmap+ #x1a00) -(defconstant +color+ #x1800) -(defconstant +depth+ #x1801) -(defconstant +stencil+ #x1802) -(defconstant +dither+ #x0bd0) -(defconstant +rgb+ #x1907) -(defconstant +rgba+ #x1908) - -;; Implementation Limits - -(defconstant +max-list-nesting+ #x0b31) -(defconstant +max-attrib-stack-depth+ #x0d35) -(defconstant +max-modelview-stack-depth+ #x0d36) -(defconstant +max-name-stack-depth+ #x0d37) -(defconstant +max-projection-stack-depth+ #x0d38) -(defconstant +max-texture-stack-depth+ #x0d39) -(defconstant +max-eval-order+ #x0d30) -(defconstant +max-lights+ #x0d31) -(defconstant +max-clip-planes+ #x0d32) -(defconstant +max-texture-size+ #x0d33) -(defconstant +max-pixel-map-table+ #x0d34) -(defconstant +max-viewport-dims+ #x0d3a) -(defconstant +max-client-attrib-stack-depth+ #x0d3b) - -;; Gets - -(defconstant +attrib-stack-depth+ #x0bb0) -(defconstant +client-attrib-stack-depth+ #x0bb1) -(defconstant +color-clear-value+ #x0c22) -(defconstant +color-writemask+ #x0c23) -(defconstant +current-index+ #x0b01) -(defconstant +current-color+ #x0b00) -(defconstant +current-normal+ #x0b02) -(defconstant +current-raster-color+ #x0b04) -(defconstant +current-raster-distance+ #x0b09) -(defconstant +current-raster-index+ #x0b05) -(defconstant +current-raster-position+ #x0b07) -(defconstant +current-raster-texture-coords+ #x0b06) -(defconstant +current-raster-position-valid+ #x0b08) -(defconstant +current-texture-coords+ #x0b03) -(defconstant +index-clear-value+ #x0c20) -(defconstant +index-mode+ #x0c30) -(defconstant +index-writemask+ #x0c21) -(defconstant +modelview-matrix+ #x0ba6) -(defconstant +modelview-stack-depth+ #x0ba3) -(defconstant +name-stack-depth+ #x0d70) -(defconstant +projection-matrix+ #x0ba7) -(defconstant +projection-stack-depth+ #x0ba4) -(defconstant +render-mode+ #x0c40) -(defconstant +rgba-mode+ #x0c31) -(defconstant +texture-matrix+ #x0ba8) -(defconstant +texture-stack-depth+ #x0ba5) -(defconstant +viewport+ #x0ba2) - -;; GL Evaluators - -(defconstant +auto-normal+ #x0d80) -(defconstant +map1-color-4+ #x0d90) -(defconstant +map1-grid-domain+ #x0dd0) -(defconstant +map1-grid-segments+ #x0dd1) -(defconstant +map1-index+ #x0d91) -(defconstant +map1-normal+ #x0d92) -(defconstant +map1-texture-coord-1+ #x0d93) -(defconstant +map1-texture-coord-2+ #x0d94) -(defconstant +map1-texture-coord-3+ #x0d95) -(defconstant +map1-texture-coord-4+ #x0d96) -(defconstant +map1-vertex-3+ #x0d97) -(defconstant +map1-vertex-4+ #x0d98) -(defconstant +map2-color-4+ #x0db0) -(defconstant +map2-grid-domain+ #x0dd2) -(defconstant +map2-grid-segments+ #x0dd3) -(defconstant +map2-index+ #x0db1) -(defconstant +map2-normal+ #x0db2) -(defconstant +map2-texture-coord-1+ #x0db3) -(defconstant +map2-texture-coord-2+ #x0db4) -(defconstant +map2-texture-coord-3+ #x0db5) -(defconstant +map2-texture-coord-4+ #x0db6) -(defconstant +map2-vertex-3+ #x0db7) -(defconstant +map2-vertex-4+ #x0db8) -(defconstant +coeff+ #x0a00) -(defconstant +domain+ #x0a02) -(defconstant +order+ #x0a01) - -;; Hints - -(defconstant +fog-hint+ #x0c54) -(defconstant +line-smooth-hint+ #x0c52) -(defconstant +perspective-correction-hint+ #x0c50) -(defconstant +point-smooth-hint+ #x0c51) -(defconstant +polygon-smooth-hint+ #x0c53) -(defconstant +dont-care+ #x1100) -(defconstant +fastest+ #x1101) -(defconstant +nicest+ #x1102) - -;; Scissor box - -(defconstant +scissor-test+ #x0c11) -(defconstant +scissor-box+ #x0c10) - -;; Pixel Mode / Transfer - -(defconstant +map-color+ #x0d10) -(defconstant +map-stencil+ #x0d11) -(defconstant +index-shift+ #x0d12) -(defconstant +index-offset+ #x0d13) -(defconstant +red-scale+ #x0d14) -(defconstant +red-bias+ #x0d15) -(defconstant +green-scale+ #x0d18) -(defconstant +green-bias+ #x0d19) -(defconstant +blue-scale+ #x0d1a) -(defconstant +blue-bias+ #x0d1b) -(defconstant +alpha-scale+ #x0d1c) -(defconstant +alpha-bias+ #x0d1d) -(defconstant +depth-scale+ #x0d1e) -(defconstant +depth-bias+ #x0d1f) -(defconstant +pixel-map-s-to-s-size+ #x0cb1) -(defconstant +pixel-map-i-to-i-size+ #x0cb0) -(defconstant +pixel-map-i-to-r-size+ #x0cb2) -(defconstant +pixel-map-i-to-g-size+ #x0cb3) -(defconstant +pixel-map-i-to-b-size+ #x0cb4) -(defconstant +pixel-map-i-to-a-size+ #x0cb5) -(defconstant +pixel-map-r-to-r-size+ #x0cb6) -(defconstant +pixel-map-g-to-g-size+ #x0cb7) -(defconstant +pixel-map-b-to-b-size+ #x0cb8) -(defconstant +pixel-map-a-to-a-size+ #x0cb9) -(defconstant +pixel-map-s-to-s+ #x0c71) -(defconstant +pixel-map-i-to-i+ #x0c70) -(defconstant +pixel-map-i-to-r+ #x0c72) -(defconstant +pixel-map-i-to-g+ #x0c73) -(defconstant +pixel-map-i-to-b+ #x0c74) -(defconstant +pixel-map-i-to-a+ #x0c75) -(defconstant +pixel-map-r-to-r+ #x0c76) -(defconstant +pixel-map-g-to-g+ #x0c77) -(defconstant +pixel-map-b-to-b+ #x0c78) -(defconstant +pixel-map-a-to-a+ #x0c79) -(defconstant +pack-alignment+ #x0d05) -(defconstant +pack-lsb-first+ #x0d01) -(defconstant +pack-row-length+ #x0d02) -(defconstant +pack-skip-pixels+ #x0d04) -(defconstant +pack-skip-rows+ #x0d03) -(defconstant +pack-swap-bytes+ #x0d00) -(defconstant +unpack-alignment+ #x0cf5) -(defconstant +unpack-lsb-first+ #x0cf1) -(defconstant +unpack-row-length+ #x0cf2) -(defconstant +unpack-skip-pixels+ #x0cf4) -(defconstant +unpack-skip-rows+ #x0cf3) -(defconstant +unpack-swap-bytes+ #x0cf0) -(defconstant +zoom-x+ #x0d16) -(defconstant +zoom-y+ #x0d17) - -;; Texture Mapping - -(defconstant +texture-env+ #x2300) -(defconstant +texture-env-mode+ #x2200) -(defconstant +texture-1d+ #x0de0) -(defconstant +texture-2d+ #x0de1) -(defconstant +texture-wrap-s+ #x2802) -(defconstant +texture-wrap-t+ #x2803) -(defconstant +texture-mag-filter+ #x2800) -(defconstant +texture-min-filter+ #x2801) -(defconstant +texture-env-color+ #x2201) -(defconstant +texture-gen-s+ #x0c60) -(defconstant +texture-gen-t+ #x0c61) -(defconstant +texture-gen-mode+ #x2500) -(defconstant +texture-border-color+ #x1004) -(defconstant +texture-width+ #x1000) -(defconstant +texture-height+ #x1001) -(defconstant +texture-border+ #x1005) -(defconstant +texture-components+ #x1003) -(defconstant +texture-red-size+ #x805c) -(defconstant +texture-green-size+ #x805d) -(defconstant +texture-blue-size+ #x805e) -(defconstant +texture-alpha-size+ #x805f) -(defconstant +texture-luminance-size+ #x8060) -(defconstant +texture-intensity-size+ #x8061) -(defconstant +nearest-mipmap-nearest+ #x2700) -(defconstant +nearest-mipmap-linear+ #x2702) -(defconstant +linear-mipmap-nearest+ #x2701) -(defconstant +linear-mipmap-linear+ #x2703) -(defconstant +object-linear+ #x2401) -(defconstant +object-plane+ #x2501) -(defconstant +eye-linear+ #x2400) -(defconstant +eye-plane+ #x2502) -(defconstant +sphere-map+ #x2402) -(defconstant +decal+ #x2101) -(defconstant +modulate+ #x2100) -(defconstant +nearest+ #x2600) -(defconstant +repeat+ #x2901) -(defconstant +clamp+ #x2900) -(defconstant +s+ #x2000) -(defconstant +t+ #x2001) -(defconstant +r+ #x2002) -(defconstant +q+ #x2003) -(defconstant +texture-gen-r+ #x0c62) -(defconstant +texture-gen-q+ #x0c63) - -;; GL 1.1 Texturing - -(defconstant +proxy-texture-1d+ #x8063) -(defconstant +proxy-texture-2d+ #x8064) -(defconstant +texture-priority+ #x8066) -(defconstant +texture-resident+ #x8067) -(defconstant +texture-binding-1d+ #x8068) -(defconstant +texture-binding-2d+ #x8069) -(defconstant +texture-internal-format+ #x1003) -(defconstant +pack-skip-images+ #x806b) -(defconstant +pack-image-height+ #x806c) -(defconstant +unpack-skip-images+ #x806d) -(defconstant +unpack-image-height+ #x806e) -(defconstant +texture-3d+ #x806f) -(defconstant +proxy-texture-3d+ #x8070) -(defconstant +texture-depth+ #x8071) -(defconstant +texture-wrap-r+ #x8072) -(defconstant +max-3d-texture-size+ #x8073) -(defconstant +texture-binding-3d+ #x806a) - -;; Internal texture formats (GL 1.1) -(defconstant +alpha4+ #x803b) -(defconstant +alpha8+ #x803c) -(defconstant +alpha12+ #x803d) -(defconstant +alpha16+ #x803e) -(defconstant +luminance4+ #x803f) -(defconstant +luminance8+ #x8040) -(defconstant +luminance12+ #x8041) -(defconstant +luminance16+ #x8042) -(defconstant +luminance4-alpha4+ #x8043) -(defconstant +luminance6-alpha2+ #x8044) -(defconstant +luminance8-alpha8+ #x8045) -(defconstant +luminance12-alpha4+ #x8046) -(defconstant +luminance12-alpha12+ #x8047) -(defconstant +luminance16-alpha16+ #x8048) -(defconstant +intensity+ #x8049) -(defconstant +intensity4+ #x804a) -(defconstant +intensity8+ #x804b) -(defconstant +intensity12+ #x804c) -(defconstant +intensity16+ #x804d) -(defconstant +r3-g3-b2+ #x2a10) -(defconstant +rgb4+ #x804f) -(defconstant +rgb5+ #x8050) -(defconstant +rgb8+ #x8051) -(defconstant +rgb10+ #x8052) -(defconstant +rgb12+ #x8053) -(defconstant +rgb16+ #x8054) -(defconstant +rgba2+ #x8055) -(defconstant +rgba4+ #x8056) -(defconstant +rgb5-a1+ #x8057) -(defconstant +rgba8+ #x8058) -(defconstant +rgb10-a2+ #x8059) -(defconstant +rgba12+ #x805a) -(defconstant +rgba16+ #x805b) - -;; Utility - -(defconstant +vendor+ #x1f00) -(defconstant +renderer+ #x1f01) -(defconstant +version+ #x1f02) -(defconstant +extensions+ #x1f03) - -;; Errors - -(defconstant +no-error+ #x0) -(defconstant +invalid-value+ #x0501) -(defconstant +invalid-enum+ #x0500) -(defconstant +invalid-operation+ #x0502) -(defconstant +stack-overflow+ #x0503) -(defconstant +stack-underflow+ #x0504) -(defconstant +out-of-memory+ #x0505) - -;; OpenGL 1.2 - -(defconstant +rescale-normal+ #x803a) -(defconstant +clamp-to-edge+ #x812f) -(defconstant +max-elements-vertices+ #x80e8) -(defconstant +max-elements-indices+ #x80e9) -(defconstant +bgr+ #x80e0) -(defconstant +bgra+ #x80e1) -(defconstant +unsigned-byte-3-3-2+ #x8032) -(defconstant +unsigned-byte-2-3-3-rev+ #x8362) -(defconstant +unsigned-short-5-6-5+ #x8363) -(defconstant +unsigned-short-5-6-5-rev+ #x8364) -(defconstant +unsigned-short-4-4-4-4+ #x8033) -(defconstant +unsigned-short-4-4-4-4-rev+ #x8365) -(defconstant +unsigned-short-5-5-5-1+ #x8034) -(defconstant +unsigned-short-1-5-5-5-rev+ #x8366) -(defconstant +unsigned-int-8-8-8-8+ #x8035) -(defconstant +unsigned-int-8-8-8-8-rev+ #x8367) -(defconstant +unsigned-int-10-10-10-2+ #x8036) -(defconstant +unsigned-int-2-10-10-10-rev+ #x8368) -(defconstant +light-model-color-control+ #x81f8) -(defconstant +single-color+ #x81f9) -(defconstant +separate-specular-color+ #x81fa) -(defconstant +texture-min-lod+ #x813a) -(defconstant +texture-max-lod+ #x813b) -(defconstant +texture-base-level+ #x813c) -(defconstant +texture-max-level+ #x813d) -(defconstant +smooth-point-size-range+ #x0b12) -(defconstant +smooth-point-size-granularity+ #x0b13) -(defconstant +smooth-line-width-range+ #x0b22) -(defconstant +smooth-line-width-granularity+ #x0b23) -(defconstant +aliased-point-size-range+ #x846d) -(defconstant +aliased-line-width-range+ #x846e) - -;; OpenGL 1.2 Imaging subset -;; GL_EXT_color_table -(defconstant +color-table+ #x80d0) -(defconstant +post-convolution-color-table+ #x80d1) -(defconstant +post-color-matrix-color-table+ #x80d2) -(defconstant +proxy-color-table+ #x80d3) -(defconstant +proxy-post-convolution-color-table+ #x80d4) -(defconstant +proxy-post-color-matrix-color-table+ #x80d5) -(defconstant +color-table-scale+ #x80d6) -(defconstant +color-table-bias+ #x80d7) -(defconstant +color-table-format+ #x80d8) -(defconstant +color-table-width+ #x80d9) -(defconstant +color-table-red-size+ #x80da) -(defconstant +color-table-green-size+ #x80db) -(defconstant +color-table-blue-size+ #x80dc) -(defconstant +color-table-alpha-size+ #x80dd) -(defconstant +color-table-luminance-size+ #x80de) -(defconstant +color-table-intensity-size+ #x80df) -;; GL_EXT_convolution and GL_HP_convolution -(defconstant +convolution-1d+ #x8010) -(defconstant +convolution-2d+ #x8011) -(defconstant +separable-2d+ #x8012) -(defconstant +convolution-border-mode+ #x8013) -(defconstant +convolution-filter-scale+ #x8014) -(defconstant +convolution-filter-bias+ #x8015) -(defconstant +reduce+ #x8016) -(defconstant +convolution-format+ #x8017) -(defconstant +convolution-width+ #x8018) -(defconstant +convolution-height+ #x8019) -(defconstant +max-convolution-width+ #x801a) -(defconstant +max-convolution-height+ #x801b) -(defconstant +post-convolution-red-scale+ #x801c) -(defconstant +post-convolution-green-scale+ #x801d) -(defconstant +post-convolution-blue-scale+ #x801e) -(defconstant +post-convolution-alpha-scale+ #x801f) -(defconstant +post-convolution-red-bias+ #x8020) -(defconstant +post-convolution-green-bias+ #x8021) -(defconstant +post-convolution-blue-bias+ #x8022) -(defconstant +post-convolution-alpha-bias+ #x8023) -(defconstant +constant-border+ #x8151) -(defconstant +replicate-border+ #x8153) -(defconstant +convolution-border-color+ #x8154) -;; GL_SGI_color_matrix -(defconstant +color-matrix+ #x80b1) -(defconstant +color-matrix-stack-depth+ #x80b2) -(defconstant +max-color-matrix-stack-depth+ #x80b3) -(defconstant +post-color-matrix-red-scale+ #x80b4) -(defconstant +post-color-matrix-green-scale+ #x80b5) -(defconstant +post-color-matrix-blue-scale+ #x80b6) -(defconstant +post-color-matrix-alpha-scale+ #x80b7) -(defconstant +post-color-matrix-red-bias+ #x80b8) -(defconstant +post-color-matrix-green-bias+ #x80b9) -(defconstant +post-color-matrix-blue-bias+ #x80ba) -(defconstant +post-color-matrix-alpha-bias+ #x80bb) -;; GL_EXT_histogram -(defconstant +histogram+ #x8024) -(defconstant +proxy-histogram+ #x8025) -(defconstant +histogram-width+ #x8026) -(defconstant +histogram-format+ #x8027) -(defconstant +histogram-red-size+ #x8028) -(defconstant +histogram-green-size+ #x8029) -(defconstant +histogram-blue-size+ #x802a) -(defconstant +histogram-alpha-size+ #x802b) -(defconstant +histogram-luminance-size+ #x802c) -(defconstant +histogram-sink+ #x802d) -(defconstant +minmax+ #x802e) -(defconstant +minmax-format+ #x802f) -(defconstant +minmax-sink+ #x8030) -(defconstant +table-too-large+ #x8031) -;; GL_EXT_blend_color, GL_EXT_blend_minmax -(defconstant +blend-equation+ #x8009) -(defconstant +min+ #x8007) -(defconstant +max+ #x8008) -(defconstant +func-add+ #x8006) -(defconstant +func-subtract+ #x800a) -(defconstant +func-reverse-subtract+ #x800b) - -;; glPush/PopAttrib bits - -(defconstant +current-bit+ #x00000001) -(defconstant +point-bit+ #x00000002) -(defconstant +line-bit+ #x00000004) -(defconstant +polygon-bit+ #x00000008) -(defconstant +polygon-stipple-bit+ #x00000010) -(defconstant +pixel-mode-bit+ #x00000020) -(defconstant +lighting-bit+ #x00000040) -(defconstant +fog-bit+ #x00000080) -(defconstant +depth-buffer-bit+ #x00000100) -(defconstant +accum-buffer-bit+ #x00000200) -(defconstant +stencil-buffer-bit+ #x00000400) -(defconstant +viewport-bit+ #x00000800) -(defconstant +transform-bit+ #x00001000) -(defconstant +enable-bit+ #x00002000) -(defconstant +color-buffer-bit+ #x00004000) -(defconstant +hint-bit+ #x00008000) -(defconstant +eval-bit+ #x00010000) -(defconstant +list-bit+ #x00020000) -(defconstant +texture-bit+ #x00040000) -(defconstant +scissor-bit+ #x00080000) -(defconstant +all-attrib-bits+ #x000fffff) -(defconstant +client-pixel-store-bit+ #x00000001) -(defconstant +client-vertex-array-bit+ #x00000002) -(defconstant +client-all-attrib-bits+ #xffffffff) - -;; ARB Multitexturing extension - -(defconstant +arb-multitexture+ 1) -(defconstant +texture0-arb+ #x84c0) -(defconstant +texture1-arb+ #x84c1) -(defconstant +texture2-arb+ #x84c2) -(defconstant +texture3-arb+ #x84c3) -(defconstant +texture4-arb+ #x84c4) -(defconstant +texture5-arb+ #x84c5) -(defconstant +texture6-arb+ #x84c6) -(defconstant +texture7-arb+ #x84c7) -(defconstant +texture8-arb+ #x84c8) -(defconstant +texture9-arb+ #x84c9) -(defconstant +texture10-arb+ #x84ca) -(defconstant +texture11-arb+ #x84cb) -(defconstant +texture12-arb+ #x84cc) -(defconstant +texture13-arb+ #x84cd) -(defconstant +texture14-arb+ #x84ce) -(defconstant +texture15-arb+ #x84cf) -(defconstant +texture16-arb+ #x84d0) -(defconstant +texture17-arb+ #x84d1) -(defconstant +texture18-arb+ #x84d2) -(defconstant +texture19-arb+ #x84d3) -(defconstant +texture20-arb+ #x84d4) -(defconstant +texture21-arb+ #x84d5) -(defconstant +texture22-arb+ #x84d6) -(defconstant +texture23-arb+ #x84d7) -(defconstant +texture24-arb+ #x84d8) -(defconstant +texture25-arb+ #x84d9) -(defconstant +texture26-arb+ #x84da) -(defconstant +texture27-arb+ #x84db) -(defconstant +texture28-arb+ #x84dc) -(defconstant +texture29-arb+ #x84dd) -(defconstant +texture30-arb+ #x84de) -(defconstant +texture31-arb+ #x84df) -(defconstant +active-texture-arb+ #x84e0) -(defconstant +client-active-texture-arb+ #x84e1) -(defconstant +max-texture-units-arb+ #x84e2) - -;;; Misc extensions - -(defconstant +ext-abgr+ 1) -(defconstant +abgr-ext+ #x8000) -(defconstant +ext-blend-color+ 1) -(defconstant +constant-color-ext+ #x8001) -(defconstant +one-minus-constant-color-ext+ #x8002) -(defconstant +constant-alpha-ext+ #x8003) -(defconstant +one-minus-constant-alpha-ext+ #x8004) -(defconstant +blend-color-ext+ #x8005) -(defconstant +ext-polygon-offset+ 1) -(defconstant +polygon-offset-ext+ #x8037) -(defconstant +polygon-offset-factor-ext+ #x8038) -(defconstant +polygon-offset-bias-ext+ #x8039) -(defconstant +ext-texture3d+ 1) -(defconstant +pack-skip-images-ext+ #x806b) -(defconstant +pack-image-height-ext+ #x806c) -(defconstant +unpack-skip-images-ext+ #x806d) -(defconstant +unpack-image-height-ext+ #x806e) -(defconstant +texture-3d-ext+ #x806f) -(defconstant +proxy-texture-3d-ext+ #x8070) -(defconstant +texture-depth-ext+ #x8071) -(defconstant +texture-wrap-r-ext+ #x8072) -(defconstant +max-3d-texture-size-ext+ #x8073) -(defconstant +texture-3d-binding-ext+ #x806a) -(defconstant +ext-texture-object+ 1) -(defconstant +texture-priority-ext+ #x8066) -(defconstant +texture-resident-ext+ #x8067) -(defconstant +texture-1d-binding-ext+ #x8068) -(defconstant +texture-2d-binding-ext+ #x8069) -(defconstant +ext-rescale-normal+ 1) -(defconstant +rescale-normal-ext+ #x803a) -(defconstant +ext-vertex-array+ 1) -(defconstant +vertex-array-ext+ #x8074) -(defconstant +normal-array-ext+ #x8075) -(defconstant +color-array-ext+ #x8076) -(defconstant +index-array-ext+ #x8077) -(defconstant +texture-coord-array-ext+ #x8078) -(defconstant +edge-flag-array-ext+ #x8079) -(defconstant +vertex-array-size-ext+ #x807a) -(defconstant +vertex-array-type-ext+ #x807b) -(defconstant +vertex-array-stride-ext+ #x807c) -(defconstant +vertex-array-count-ext+ #x807d) -(defconstant +normal-array-type-ext+ #x807e) -(defconstant +normal-array-stride-ext+ #x807f) -(defconstant +normal-array-count-ext+ #x8080) -(defconstant +color-array-size-ext+ #x8081) -(defconstant +color-array-type-ext+ #x8082) -(defconstant +color-array-stride-ext+ #x8083) -(defconstant +color-array-count-ext+ #x8084) -(defconstant +index-array-type-ext+ #x8085) -(defconstant +index-array-stride-ext+ #x8086) -(defconstant +index-array-count-ext+ #x8087) -(defconstant +texture-coord-array-size-ext+ #x8088) -(defconstant +texture-coord-array-type-ext+ #x8089) -(defconstant +texture-coord-array-stride-ext+ #x808a) -(defconstant +texture-coord-array-count-ext+ #x808b) -(defconstant +edge-flag-array-stride-ext+ #x808c) -(defconstant +edge-flag-array-count-ext+ #x808d) -(defconstant +vertex-array-pointer-ext+ #x808e) -(defconstant +normal-array-pointer-ext+ #x808f) -(defconstant +color-array-pointer-ext+ #x8090) -(defconstant +index-array-pointer-ext+ #x8091) -(defconstant +texture-coord-array-pointer-ext+ #x8092) -(defconstant +edge-flag-array-pointer-ext+ #x8093) -(defconstant +sgis-texture-edge-clamp+ 1) -(defconstant +clamp-to-edge-sgis+ #x812f) -(defconstant +ext-blend-minmax+ 1) -(defconstant +func-add-ext+ #x8006) -(defconstant +min-ext+ #x8007) -(defconstant +max-ext+ #x8008) -(defconstant +blend-equation-ext+ #x8009) -(defconstant +ext-blend-subtract+ 1) -(defconstant +func-subtract-ext+ #x800a) -(defconstant +func-reverse-subtract-ext+ #x800b) -(defconstant +ext-blend-logic-op+ 1) -(defconstant +ext-point-parameters+ 1) -(defconstant +point-size-min-ext+ #x8126) -(defconstant +point-size-max-ext+ #x8127) -(defconstant +point-fade-threshold-size-ext+ #x8128) -(defconstant +distance-attenuation-ext+ #x8129) -(defconstant +ext-paletted-texture+ 1) -(defconstant +table-too-large-ext+ #x8031) -(defconstant +color-table-format-ext+ #x80d8) -(defconstant +color-table-width-ext+ #x80d9) -(defconstant +color-table-red-size-ext+ #x80da) -(defconstant +color-table-green-size-ext+ #x80db) -(defconstant +color-table-blue-size-ext+ #x80dc) -(defconstant +color-table-alpha-size-ext+ #x80dd) -(defconstant +color-table-luminance-size-ext+ #x80de) -(defconstant +color-table-intensity-size-ext+ #x80df) -(defconstant +texture-index-size-ext+ #x80ed) -(defconstant +color-index1-ext+ #x80e2) -(defconstant +color-index2-ext+ #x80e3) -(defconstant +color-index4-ext+ #x80e4) -(defconstant +color-index8-ext+ #x80e5) -(defconstant +color-index12-ext+ #x80e6) -(defconstant +color-index16-ext+ #x80e7) -(defconstant +ext-clip-volume-hint+ 1) -(defconstant +clip-volume-clipping-hint-ext+ #x80f0) -(defconstant +ext-compiled-vertex-array+ 1) -(defconstant +array-element-lock-first-ext+ #x81a8) -(defconstant +array-element-lock-count-ext+ #x81a9) -(defconstant +hp-occlusion-test+ 1) -(defconstant +occlusion-test-hp+ #x8165) -(defconstant +occlusion-test-result-hp+ #x8166) -(defconstant +ext-shared-texture-palette+ 1) -(defconstant +shared-texture-palette-ext+ #x81fb) -(defconstant +ext-stencil-wrap+ 1) -(defconstant +incr-wrap-ext+ #x8507) -(defconstant +decr-wrap-ext+ #x8508) -(defconstant +nv-texgen-reflection+ 1) -(defconstant +normal-map-nv+ #x8511) -(defconstant +reflection-map-nv+ #x8512) -(defconstant +ext-texture-env-add+ 1) -(defconstant +mesa-window-pos+ 1) -(defconstant +mesa-resize-buffers+ 1) -) - - - -;;; Utility stuff - -(deftype bool () 'card8) -(deftype float32 () 'single-float) -(deftype float64 () 'double-float) - -(declaim (inline aset-float32 aset-float64)) - -#+sbcl -(defun aset-float32 (value array index) - (declare (type single-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((bits (sb-kernel:single-float-bits value))) - (declare (type (unsigned-byte 32) bits)) - (aset-card32 bits array index)) - value) - - -#+cmu -(defun aset-float32 (value array index) - (declare (type single-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((bits (kernel:single-float-bits value))) - (declare (type (unsigned-byte 32) bits)) - (aset-card32 bits array index)) - value) - - -#+openmcl -(defun aset-float32 (value array index) - (declare (type single-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((bits (ccl::single-float-bits value))) - (declare (type (unsigned-byte 32) bits)) - (aset-card32 bits array index)) - value) - - -#+sbcl -(defun aset-float64 (value array index) - (declare (type double-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((low (sb-kernel:double-float-low-bits value)) - (high (sb-kernel:double-float-high-bits value))) - (declare (type (unsigned-byte 32) low high)) - (aset-card32 low array index) - (aset-card32 high array (the array-index (+ index 4)))) - value) - - -#+cmu -(defun aset-float64 (value array index) - (declare (type double-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((low (kernel:double-float-low-bits value)) - (high (kernel:double-float-high-bits value))) - (declare (type (unsigned-byte 32) low high)) - (aset-card32 low array index) - (aset-card32 high array (+ index 4))) - value) - - -#+openmcl -(defun aset-float64 (value array index) - (declare (type double-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (multiple-value-bind (low high) - (ccl::double-float-bits value) - (declare (type (unsigned-byte 32) low high)) - (aset-card32 low array index) - (aset-card32 high array (the array-index (+ index 4)))) - value) - - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun byte-width (type) - (ecase type - ((int8 card8 bool) 1) - ((int16 card16) 2) - ((int32 card32 float32) 4) - ((float64) 8))) - - -(defun setter (type) - (ecase type - (int8 'aset-int8) - (int16 'aset-int16) - (int32 'aset-int32) - (bool 'aset-card8) - (card8 'aset-card8) - (card16 'aset-card16) - (card32 'aset-card32) - (float32 'aset-float32) - (float64 'aset-float64))) - - -(defun sequence-setter (type) - (ecase type - (int8 'sset-int8) - (int16 'sset-int16) - (int32 'sset-int32) - (bool 'sset-card8) - (card8 'sset-card8) - (card16 'sset-card16) - (card32 'sset-card32) - (float32 'sset-float32) - (float64 'sset-float64))) - - -(defmacro define-sequence-setter (type) - `(defun ,(intern (format nil "~A-~A" 'sset type)) (seq buffer start length) - (declare (type sequence seq) - (type buffer-bytes buffer) - (type array-index start) - (type fixnum length)) - #.(declare-buffun) - (assert (= length (length seq)) - (length seq) - "SEQUENCE length should be ~D, not ~D." length (length seq)) - (typecase seq - (list - (let ((offset 0)) - (declare (type fixnum offset)) - (dolist (n seq) - (declare (type ,type n)) - (,(setter type) n buffer (the array-index (+ start offset))) - (incf offset ,(byte-width type))))) - ((simple-array ,type) - (dotimes (i ,(byte-width type)) - (,(setter type) - (aref seq i) - buffer - (the array-index (+ start (* i ,(byte-width type))))))) - (vector - (dotimes (i ,(byte-width type)) - (,(setter type) - (svref seq i) - buffer - (the array-index (+ start (* i ,(byte-width type)))))))))) - - -(define-sequence-setter int8) -(define-sequence-setter int16) -(define-sequence-setter int32) -(define-sequence-setter bool) -(define-sequence-setter card8) -(define-sequence-setter card16) -(define-sequence-setter card32) -(define-sequence-setter float32) -(define-sequence-setter float64) - - - -(defun make-argspecs (list) - (destructuring-bind (name type) - list - (etypecase type - (symbol `(,name ,type 1 nil)) - (list - `(,name - ,(second type) - ,(third type) - ,(if (consp (third type)) - (make-symbol (format nil "~A-~A" name 'length)) - nil)))))) - - -(defun byte-width-calculation (argspecs) - (let ((constant 0) - (calculated ())) - (loop - for (name type length length-var) in argspecs - do (let ((byte-width (byte-width type))) - (typecase length - (number (incf constant (* byte-width length))) - (symbol (push `(* ,byte-width ,length) calculated)) - (cons (push `(* ,byte-width ,length-var) calculated))))) - (if (null calculated) - constant - (list* '+ constant calculated)))) - - -(defun composite-args (argspecs) - (loop - for (name type length length-var) in argspecs - when (consp length) - collect (list length-var length))) - - -(defun make-setter-forms (argspecs) - (loop - for (name type length length-var) in argspecs - collecting `(progn - ,(if (and (numberp length) - (= 1 length)) - `(,(setter type) ,name .rbuf. .index.) - `(,(sequence-setter type) ,name .rbuf. .index. - ,(if length-var length-var length))) - (setf .index. (the array-index - (+ .index. - (the fixnum (* ,(byte-width type) - ,(if length-var length-var length))))))))) - - -(defmacro define-rendering-command (name opcode &rest args) - ;; FIXME: Must heavily type-annotate. - (labels ((expand-args (list) - (loop - for (arg type) in list - if (consp arg) - append (loop - for name in arg - collecting (list name type)) - else - collect (list arg type)))) - - (let* ((args (expand-args args)) - (argspecs (mapcar 'make-argspecs args)) - (total-byte-width (byte-width-calculation argspecs)) - (composite-args (composite-args argspecs))) - - `(defun ,name ,(mapcar #'first argspecs) - (declare ,@(mapcar #'(lambda (list) - (if (symbolp (second list)) - (list* 'type (reverse list)) - `(type sequence ,(first list)))) - args)) - #.(declare-buffun) - (assert (context-p *current-context*) - (*current-context*) - "*CURRENT-CONTEXT* is not set (~S)." *current-context*) - (let* ((.ctx. *current-context*) - (.index0. (context-index .ctx.)) - (.index. (+ .index0. 4)) - (.rbuf. (context-rbuf .ctx.)) - ,@composite-args - (.length. (+ 4 (* 4 (ceiling ,total-byte-width 4))))) - - (declare (type context .ctx.) - (type array-index .index. .index0.) - (type buffer-bytes .rbuf.) - ,@(mapcar #'(lambda (list) - `(type fixnum ,(first list))) - composite-args) - (type fixnum .length.)) - - (when (< (- (length .rbuf.) 8) - (+ .index. .length.)) - (error "Rendering command sequence too long. Implement automatic buffer flushing.")) - - (aset-card16 .length. .rbuf. (the array-index .index0.)) - (aset-card16 ,opcode .rbuf. (the array-index (+ .index0. 2))) - ,@(make-setter-forms argspecs) - (setf (context-index .ctx.) (the array-index (+ .index0. .length.)))))))) - -) ;; eval-when - - -;;; Command implementation. - - -(defun get-string (name) - (assert (context-p *current-context*) - (*current-context*) - "*CURRENT-CONTEXT* is not set (~S)." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +get-string+) - ;; *** This is CONTEXT-TAG - (card32 (context-tag ctx)) - ;; *** This is ENUM. - (card32 name)) - (let* ((length (card32-get 12)) - (bytes (sequence-get :format card8 - :result-type '(simple-array card8 (*)) - :index 32 - :length length))) - (declare (type (simple-array card8 (*)) bytes) - (type fixnum length)) - ;; FIXME: How does this interact with unicode? - (map-into (make-string (1- length)) #'code-char bytes))))) - - - - -;;; Rendering commands (in alphabetical order). - - -(define-rendering-command accum 137 - ;; *** ENUM - (op card32) - (value float32)) - - -(define-rendering-command active-texture-arb 197 - ;; *** ENUM - (texture card32)) - - -(define-rendering-command alpha-func 159 - ;; *** ENUM - (func card32) - (ref float32)) - - -(define-rendering-command begin 4 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command bind-texture 4117 - ;; *** ENUM - (target card32) - (texture card32)) - - -(define-rendering-command blend-color 4096 - (red float32) - (green float32) - (blue float32) - (alpha float32)) - - -(define-rendering-command blend-equotion 4097 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command blend-func 160 - ;; *** ENUM - (sfactor card32) - ;; *** ENUM - (dfactor card32)) - - -(define-rendering-command call-list 1 - (list card32)) - - -(define-rendering-command clear 127 - ;; *** BITFIELD - (mask card32)) - - -(define-rendering-command clear-accum 128 - (red float32) - (green float32) - (blue float32) - (alpha float32)) - - -(define-rendering-command clear-color 130 - (red float32) - (green float32) - (blue float32) - (alpha float32)) - - -(define-rendering-command clear-depth 132 - (depth float64)) - - -(define-rendering-command clear-index 129 - (c float32)) - - -(define-rendering-command clear-stencil 131 - (s int32)) - - -(define-rendering-command clip-plane 77 - (equotion-0 float64) - (equotion-1 float64) - (equotion-2 float64) - (equotion-3 float64) - ;; *** ENUM - (plane card32)) - - -(define-rendering-command color-3b 6 - ((r g b) int8)) - -(define-rendering-command color-3d 7 - ((r g b) float64)) - -(define-rendering-command color-3f 8 - ((r g b) float32)) - -(define-rendering-command color-3i 9 - ((r g b) int32)) - -(define-rendering-command color-3s 10 - ((r g b) int16)) - -(define-rendering-command color-3ub 11 - ((r g b) card8)) - -(define-rendering-command color-3ui 12 - ((r g b) card32)) - -(define-rendering-command color-3us 13 - ((r g b) card16)) - - -(define-rendering-command color-4b 14 - ((r g b a) int8)) - -(define-rendering-command color-4d 15 - ((r g b a) float64)) - -(define-rendering-command color-4f 16 - ((r g b a) float32)) - -(define-rendering-command color-4i 17 - ((r g b a) int32)) - -(define-rendering-command color-4s 18 - ((r g b a) int16)) - -(define-rendering-command color-4ub 19 - ((r g b a) card8)) - -(define-rendering-command color-4ui 20 - ((r g b a) card32)) - -(define-rendering-command color-4us 21 - ((r g b a) card16)) - - -(define-rendering-command color-mask 134 - (red bool) - (green bool) - (blue bool) - (alpha bool)) - - -(define-rendering-command color-material 78 - ;; *** ENUM - (face card32) - ;; *** ENUM - (mode card32)) - - -(define-rendering-command color-table-parameter-fv 2054 - ;; *** ENUM - (target card32) - ;; TODO: - ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 - ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 - ;; else (length params) = 0 (command is erronous) - ;; *** ENUM - (pname card32) - (params (list float32 4))) - - -(define-rendering-command color-table-parameter-iv 2055 - ;; *** ENUM - (target card32) - ;; TODO: - ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 - ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 - ;; else (length params) = 0 (command is erronous) - ;; *** ENUM - (pname card32) - (params (list int32 4))) - - -(define-rendering-command convolution-parameter-f 4103 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params float32)) - - -(define-rendering-command convolution-parameter-fv 4104 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+convolution-border-mode+ - #.+convolution-format+ - #.+convolution-width+ - #.+convolution-height+ - #.+max-convolution-width+ - #.+max-convolution-width+) - 1) - ((#.+convolution-filter-scale+ - #.+convolution-filter-bias+) - 4))))) - - -(define-rendering-command convolution-parameter-i 4105 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params int32)) - - -(define-rendering-command convolution-parameter-iv 4106 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+convolution-border-mode+ - #.+convolution-format+ - #.+convolution-width+ - #.+convolution-height+ - #.+max-convolution-width+ - #.+max-convolution-width+) - 1) - ((#.+convolution-filter-scale+ - #.+convolution-filter-bias+) - 4))))) - - -(define-rendering-command copy-color-sub-table 196 - ;; *** ENUM - (target card32) - (start int32) - (x int32) - (y int32) - (width int32)) - - -(define-rendering-command copy-color-table 2056 - ;; *** ENUM - (target card32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32)) - - -(define-rendering-command copy-convolution-filter-id 4107 - ;; *** ENUM - (target card32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32)) - - -(define-rendering-command copy-convolution-filter-2d 4108 - ;; *** ENUM - (target card32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32) - (height int32)) - - -(define-rendering-command copy-pixels 172 - (x int32) - (y int32) - (width int32) - (height int32) - ;; *** ENUM - (type card32)) - - -(define-rendering-command copy-tex-image-1d 4119 - ;; *** ENUM - (target card32) - (level int32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32) - (border int32)) - - -(define-rendering-command copy-tex-image-2d 4120 - ;; *** ENUM - (target card32) - (level int32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32) - (height int32) - (border int32)) - - -(define-rendering-command copy-tex-sub-image-1d 4121 - ;; *** ENUM - (target card32) - (level int32) - (xoffset int32) - (x int32) - (y int32) - (width int32)) - - -(define-rendering-command copy-tex-sub-image-2d 4122 - ;; *** ENUM - (target card32) - (level int32) - (xoffset int32) - (yoffset int32) - (x int32) - (y int32) - (width int32) - (height int32)) - - -(define-rendering-command copy-tex-sub-image-3d 4123 - ;; *** ENUM - (target card32) - (level int32) - (xoffset int32) - (yoffset int32) - (zoffset int32) - (x int32) - (y int32) - (width int32) - (height int32)) - - -(define-rendering-command cull-face 79 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command depth-func 164 - ;; *** ENUM - (func card32)) - - -(define-rendering-command depth-mask 135 - (mask bool)) - - -(define-rendering-command depth-range 174 - (z-near float64) - (z-far float64)) - - -(define-rendering-command draw-buffer 126 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command edge-flag-v 22 - (flag-0 bool)) - - -(define-rendering-command end 23) - - -(define-rendering-command eval-coord-1d 151 - (u-0 float64)) - -(define-rendering-command eval-coord-1f 152 - (u-0 float32)) - - -(define-rendering-command eval-coord-2d 153 - ((u-0 u-1) float64)) - -(define-rendering-command eval-coord-2f 154 - ((u-0 u-1) float32)) - - -(define-rendering-command eval-mesh-1 155 - ;; *** ENUM - (mode card32) - ((i1 i2) int32)) - - -(define-rendering-command eval-mesh-2 157 - ;; *** ENUM - (mode card32) - ((i1 i2 j1 j2) int32)) - - -(define-rendering-command eval-point-1 156 - (i int32)) - - -(define-rendering-command eval-point-2 158 - (i int32) - (j int32)) - - -(define-rendering-command fog-f 80 - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command fog-fv 81 - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+fog-index+ - #.+fog-density+ - #.+fog-start+ - #.+fog-end+ - #.+fog-mode+) - 1) - ((#.+fog-color+) - 4))))) - - - -(define-rendering-command fog-i 82 - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command fog-iv 83 - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+fog-index+ - #.+fog-density+ - #.+fog-start+ - #.+fog-end+ - #.+fog-mode+) - 1) - ((#.+fog-color+) - 4))))) - - -(define-rendering-command front-face 84 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command frustum 175 - (left float64) - (right float64) - (bottom float64) - (top float64) - (z-near float64) - (z-far float64)) - - -(define-rendering-command hint 85 - ;; *** ENUM - (target card32) - ;; *** ENUM - (mode card32)) - - -(define-rendering-command histogram 4110 - ;; *** ENUM - (target card32) - (width int32) - ;; *** ENUM - (internalformat card32) - (sink bool)) - - -(define-rendering-command index-mask 136 - (mask card32)) - - -(define-rendering-command index-d 24 - (c-0 float64)) - -(define-rendering-command index-f 25 - (c-0 float32)) - -(define-rendering-command index-i 26 - (c-0 int32)) - -(define-rendering-command index-s 27 - (c-0 int16)) - -(define-rendering-command index-ub 194 - (c-0 card8)) - - -(define-rendering-command init-names 121) - - -(define-rendering-command light-model-f 90 - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command light-model-fv 91 - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+light-model-color-control+ - #.+light-model-local-viewer+ - #.+light-model-two-side+) - 1) - ((#.+light-model-ambient+) - 4))))) - -(define-rendering-command light-model-i 92 - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command light-model-iv 93 - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+light-model-color-control+ - #.+light-model-local-viewer+ - #.+light-model-two-side+) - 1) - ((#.+light-model-ambient+) - 4))))) - - -(define-rendering-command light-f 86 - ;; *** ENUM - (light card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command light-fv 87 - ;; *** ENUM - (light card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+ambient+ - #.+diffuse+ - #.+specular+ - #.+position+) - 4) - ((#.+spot-direction+) - 3) - ((#.+spot-exponent+ - #.+spot-cutoff+ - #.+constant-attenuation+ - #.+linear-attenuation+ - #.+quadratic-attenuation+) - 1))))) - - -(define-rendering-command light-i 88 - ;; *** ENUM - (light card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command light-iv 89 - ;; *** ENUM - (light card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+ambient+ - #.+diffuse+ - #.+specular+ - #.+position+) - 4) - ((#.+spot-direction+) - 3) - ((#.+spot-exponent+ - #.+spot-cutoff+ - #.+constant-attenuation+ - #.+linear-attenuation+ - #.+quadratic-attenuation+) - 1))))) - - -(define-rendering-command line-stipple 94 - (factor int32) - (pattern card16)) - - -(define-rendering-command line-width 95 - (width float32)) - - -(define-rendering-command list-base 3 - (base card32)) - - -(define-rendering-command load-identity 176) - - -(define-rendering-command load-matrix-d 178 - (m (list float64 16))) - - -(define-rendering-command load-matrix-f 177 - (m (list float32 16))) - - -(define-rendering-command load-name 122 - (name card32)) - - -(define-rendering-command logic-op 161 - ;; *** ENUM - (name card32)) - - -(define-rendering-command map-grid-1d 147 - (u1 float64) - (u2 float64) - (un int32)) - -(define-rendering-command map-grid-1f 148 - (un int32) - (u1 float32) - (u2 float32)) - - -(define-rendering-command map-grid-2d 149 - (u1 float64) - (u2 float64) - (v1 float64) - (v2 float64) - (un int32) - (vn int32)) - - -(define-rendering-command map-grid-2f 150 - (un int32) - (u1 float32) - (u2 float32) - (vn int32) - (v1 float32) - (v2 float32)) - - -(define-rendering-command material-f 96 - ;; *** ENUM - (face card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command material-fv 97 - ;; *** ENUM - (face card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+ambient+ - #.+diffuse+ - #.+specular+ - #.+emission+ - #.+ambient-and-diffuse+) - 4) - ((#.+shininess+) - 1) - ((#.+color-index+) - 3))))) - - -(define-rendering-command material-i 98 - ;; *** ENUM - (face card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command material-iv 99 - ;; *** ENUM - (face card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+ambient+ - #.+diffuse+ - #.+specular+ - #.+emission+ - #.+ambient-and-diffuse+) - 4) - ((#.+shininess+) - 1) - ((#.+color-index+) - 3))))) - - -(define-rendering-command matrix-mode 179 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command minmax 4111 - ;; *** ENUM - (target card32) - ;; *** ENUM - (internalformat card32) - (sink bool)) - - -(define-rendering-command mult-matrix-d 181 - (m (list float64 16))) - - -(define-rendering-command mult-matrix-f 180 - (m (list float32 16))) - - -;;; *** Note that TARGET is placed last for FLOAT64 versions. -(define-rendering-command multi-tex-coord-1d-arb 198 - (v-0 float64) - ;; *** ENUM - (target card32)) - -(define-rendering-command multi-tex-coord-1f-arb 199 - ;; *** ENUM - (target card32) - (v-0 float32)) - -(define-rendering-command multi-tex-coord-1i-arb 200 - ;; *** ENUM - (target card32) - (v-0 int32)) - -(define-rendering-command multi-tex-coord-1s-arb 201 - ;; *** ENUM - (target card32) - (v-0 int16)) - - -(define-rendering-command multi-tex-coord-2d-arb 202 - ((v-0 v-1) float64) - ;; *** ENUM - (target card32)) - -(define-rendering-command multi-tex-coord-2f-arb 203 - ;; *** ENUM - (target card32) - ((v-0 v-1) float32)) - -(define-rendering-command multi-tex-coord-2i-arb 204 - ;; *** ENUM - (target card32) - ((v-0 v-1) int32)) - -(define-rendering-command multi-tex-coord-2s-arb 205 - ;; *** ENUM - (target card32) - ((v-0 v-1) int16)) - - -(define-rendering-command multi-tex-coord-3d-arb 206 - ((v-0 v-1 v-2) float64) - ;; *** ENUM - (target card32)) - -(define-rendering-command multi-tex-coord-3f-arb 207 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2) float32)) - -(define-rendering-command multi-tex-coord-3i-arb 208 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2) int32)) - -(define-rendering-command multi-tex-coord-3s-arb 209 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2) int16)) - - -(define-rendering-command multi-tex-coord-4d-arb 210 - ((v-0 v-1 v-2 v-3) float64) - ;; *** ENUM - (target card32)) - -(define-rendering-command multi-tex-coord-4f-arb 211 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2 v-3) float32)) - -(define-rendering-command multi-tex-coord-4i-arb 212 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2 v-3) int32)) - -(define-rendering-command multi-tex-coord-4s-arb 213 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2 v-3) int16)) - - -(define-rendering-command normal-3b 28 - ((v-0 v-1 v-2) int8)) - -(define-rendering-command normal-3d 29 - ((v-0 v-1 v-2) float64)) - -(define-rendering-command normal-3f 30 - ((v-0 v-1 v-2) float32)) - -(define-rendering-command normal-3i 31 - ((v-0 v-1 v-2) int32)) - -(define-rendering-command normal-3s 32 - ((v-0 v-1 v-2) int16)) - - -(define-rendering-command ortho 182 - (left float64) - (right float64) - (bottom float64) - (top float64) - (z-near float64) - (z-far float64)) - - -(define-rendering-command pass-through 123 - (token float32)) - - -(define-rendering-command pixel-transfer-f 166 - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command pixel-transfer-i 167 - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command pixel-zoom 165 - (xfactor float32) - (yfactor float32)) - - -(define-rendering-command point-size 100 - (size float32)) - - -(define-rendering-command polygon-mode 101 - ;; *** ENUM - (face card32) - ;; *** ENUM - (mode card32)) - - -(define-rendering-command polygon-offset 192 - (factor float32) - (units float32)) - - -(define-rendering-command pop-attrib 141) - - -(define-rendering-command pop-matrix 183) - - -(define-rendering-command pop-name 124) - - -(define-rendering-command prioritize-textures 4118 - (n int32) - (textures (list card32 n)) - (priorities (list float32 n))) - - -(define-rendering-command push-attrib 142 - ;; *** BITFIELD - (mask card32)) - - -(define-rendering-command push-matrix 184) - - -(define-rendering-command push-name 125 - (name card32)) - - -(define-rendering-command raster-pos-2d 33 - ((v-0 v-1) float64)) - -(define-rendering-command raster-pos-2f 34 - ((v-0 v-1) float32)) - -(define-rendering-command raster-pos-2i 35 - ((v-0 v-1) int32)) - -(define-rendering-command raster-pos-2s 36 - ((v-0 v-1) int16)) - - -(define-rendering-command raster-pos-3d 37 - ((v-0 v-1 v-2) float64)) - -(define-rendering-command raster-pos-3f 38 - ((v-0 v-1 v-2) float32)) - -(define-rendering-command raster-pos-3i 39 - ((v-0 v-1 v-2) int32)) - -(define-rendering-command raster-pos-3s 40 - ((v-0 v-1 v-2) int16)) - - -(define-rendering-command raster-pos-4d 41 - ((v-0 v-1 v-2 v-3) float64)) - -(define-rendering-command raster-pos-4f 42 - ((v-0 v-1 v-2 v-3) float32)) - -(define-rendering-command raster-pos-4i 43 - ((v-0 v-1 v-2 v-3) int32)) - -(define-rendering-command raster-pos-4s 44 - ((v-0 v-1 v-2 v-3) int16)) - - -(define-rendering-command read-buffer 171 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command rect-d 45 - ((v1-0 v1-1 v2-0 v2-1) float64)) - -(define-rendering-command rect-f 46 - ((v1-0 v1-1 v2-0 v2-1) float32)) - -(define-rendering-command rect-i 47 - ((v1-0 v1-1 v2-0 v2-1) int32)) - -(define-rendering-command rect-s 48 - ((v1-0 v1-1 v2-0 v2-1) int16)) - - -(define-rendering-command reset-histogram 4112 - ;; *** ENUM - (target card32)) - - -(define-rendering-command reset-minmax 4113 - ;; *** ENUM - (target card32)) - - -(define-rendering-command rotate-d 185 - ((angle x y z) float64)) - - -(define-rendering-command rotate-f 186 - ((angle x y z) float32)) - - -(define-rendering-command scale-d 187 - ((x y z) float64)) - - -(define-rendering-command scale-f 188 - ((x y z) float32)) - - -(define-rendering-command scissor 103 - ((x y width height) int32)) - - -(define-rendering-command shade-model 104 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command stencil-func 162 - ;; *** ENUM - (func card32) - (ref int32) - (mask card32)) - - -(define-rendering-command stencil-mask 133 - (mask card32)) - - -(define-rendering-command stencil-op 163 - ;; *** ENUM - (fail card32) - ;; *** ENUM - (zfail card32) - ;; *** ENUM - (zpass card32)) - - -(define-rendering-command tex-env-f 111 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command tex-env-fv 112 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param (list float32 (ecase pname - (#.+texture-env-mode+ 1) - (#.+texture-env-color+ 4))))) - - -(define-rendering-command tex-env-i 113 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command tex-env-iv 114 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param (list int32 (ecase pname - (#.+texture-env-mode+ 1) - (#.+texture-env-color+ 4))))) - - -;;; *** -;;; last there. -(define-rendering-command tex-gen-d 115 - (param float64) - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32)) - - -(define-rendering-command tex-gen-dv 116 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - ;; +texture-gen-mode+ n=1 - ;; +object-plane+ n=4 - ;; +eye-plane+ n=1 - (params (list float64 (ecase pname - ((#.+texture-gen-mode+ #.+eye-plane+) 1) - (#.+object-plane+ 4))))) - - -(define-rendering-command tex-gen-f 117 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command tex-gen-fv 118 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+texture-gen-mode+ #.+eye-plane+) 1) - (#.+object-plane+ 4))))) - - -(define-rendering-command tex-gen-i 119 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command tex-gen-iv 120 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+texture-gen-mode+ #.+eye-plane+) 1) - (#.+object-plane+ 4))))) - - -(define-rendering-command tex-parameter-f 105 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command tex-parameter-fv 106 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+texture-border-color+) - 4) - ((#.+texture-mag-filter+ - #.+texture-min-filter+ - #.+texture-wrap-s+ - #.+texture-wrap-t+) - 1))))) - - -(define-rendering-command tex-parameter-i 107 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command tex-parameter-iv 108 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+texture-border-color+) - 4) - ((#.+texture-mag-filter+ - #.+texture-min-filter+ - #.+texture-wrap-s+ - #.+texture-wrap-t+) - 1))))) - - -(define-rendering-command translate-d 189 - ((x y z) float64)) - -(define-rendering-command translate-f 190 - ((x y z) float32)) - - -(define-rendering-command vertex-2d 65 - ((x y) float64)) - -(define-rendering-command vertex-2f 66 - ((x y) float32)) - -(define-rendering-command vertex-2i 67 - ((x y) int32)) - -(define-rendering-command vertex-2s 68 - ((x y) int16)) - - -(define-rendering-command vertex-3d 69 - ((x y z) float64)) - -(define-rendering-command vertex-3f 70 - ((x y z) float32)) - -(define-rendering-command vertex-3i 71 - ((x y z) int32)) - -(define-rendering-command vertex-3s 72 - ((x y z) int16)) - - -(define-rendering-command vertex-4d 73 - ((x y z w) float64)) - -(define-rendering-command vertex-4f 74 - ((x y z w) float32)) - -(define-rendering-command vertex-4i 75 - ((x y z w) int32)) - -(define-rendering-command vertex-4s 76 - ((x y z w) int16)) - - -(define-rendering-command viewport 191 - ((x y width height) int32)) - - -;;; Potentially lerge rendering commands. - - -#-(and) -(define-large-rendering-command call-lists 2 - (n int32) - ;; *** ENUM - (type card32) - (lists (list type n))) - - - -;;; Requests for GL non-rendering commands. - -(defun new-list (list mode) - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +new-list+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)) - (card32 list) - ;; *** ENUM - (card32 mode)))) - - -(defun gen-lists (range) - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +gen-lists+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)) - (integer range)) - (card32-get 8)))) - - -(defun end-list () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +end-list+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx))))) - - -(defun enable (cap) - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +enable+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)) - ;; *** ENUM? - (card32 cap))))) - - -;;; FIXME: FLUSH and FINISH should send *all* buffered data, including -;;; buffered rendering commands. -(defun flush () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +flush+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx))))) - - -(defun finish () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +finish+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)))))) diff --git a/src/clx/glx.lisp b/src/clx/glx.lisp deleted file mode 100644 index 2a07ae382..000000000 --- a/src/clx/glx.lisp +++ /dev/null @@ -1,632 +0,0 @@ -(defpackage :glx - (:use :common-lisp :xlib) - (:import-from :xlib - "DEFINE-ACCESSOR" - "DEF-CLX-CLASS" - "DECLARE-EVENT" - "ALLOCATE-RESOURCE-ID" - "DEALLOCATE-RESOURCE-ID" - "PRINT-DISPLAY-NAME" - "WITH-BUFFER-REQUEST" - "WITH-BUFFER-REQUEST-AND-REPLY" - "READ-CARD32" - "WRITE-CARD32" - "CARD32-GET" - "CARD8-GET" - "SEQUENCE-GET" - "SEQUENCE-PUT" - "DATA" - - ;; Types - "ARRAY-INDEX" - "BUFFER-BYTES" - - "WITH-DISPLAY" - "BUFFER-FLUSH" - "BUFFER-WRITE" - "BUFFER-FORCE-OUTPUT" - "ASET-CARD8" - "ASET-CARD16" - "ASET-CARD32" - ) - (:export ;; Constants - "+VENDOR+" - "+VERSION+" - "+EXTENSIONS+" - - ;; Conditions - "BAD-CONTEXT" - "BAD-CONTEXT-STATE" - "BAD-DRAWABLE" - "BAD-PIXMAP" - "BAD-CONTEXT-TAG" - "BAD-CURRENT-WINDOW" - "BAD-RENDER-REQUEST" - "BAD-LARGE-REQUEST" - "UNSUPPORTED-PRIVATE-REQUEST" - "BAD-FB-CONFIG" - "BAD-PBUFFER" - "BAD-CURRENT-DRAWABLE" - "BAD-WINDOW" - - ;; Requests - "QUERY-VERSION" - "QUERY-SERVER-STRING" - "CREATE-CONTEXT" - "DESTROY-CONTEXT" - "IS-DIRECT" - "QUERY-CONTEXT" - "GET-DRAWABLE-ATTRIBUTES" - "MAKE-CURRENT" - ;;"GET-VISUAL-CONFIGS" - "CHOOSE-VISUAL" - "VISUAL-ATTRIBUTE" - "VISUAL-ID" - "RENDER" - "SWAP-BUFFERS" - "WAIT-GL" - "WAIT-X" - )) - - -(in-package :glx) - - -(declaim (optimize (debug 3) (safety 3))) - - -(define-extension "GLX" - :events (:glx-pbuffer-clobber) - :errors (bad-context - bad-context-state - bad-drawable - bad-pixmap - bad-context-tag - bad-current-window - bad-render-request - bad-large-request - unsupported-private-request - bad-fb-config - bad-pbuffer - bad-current-drawable - bad-window)) - - -;;; Opcodes. - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant +render+ 1) -(defconstant +create-context+ 3) -(defconstant +destroy-context+ 4) -(defconstant +make-current+ 5) -(defconstant +is-direct+ 6) -(defconstant +query-version+ 7) -(defconstant +wait-gl+ 8) -(defconstant +wait-x+ 9) -(defconstant +copy-context+ 10) -(defconstant +swap-buffers+ 11) -(defconstant +get-visual-configs+ 14) -(defconstant +destroy-glx-pixmap+ 15) -(defconstant +query-server-string+ 19) -(defconstant +client-info+ 20) -(defconstant +get-fb-configs+ 21) -(defconstant +query-context+ 25) -(defconstant +get-drawable-attributes+ 29) -) - - -;;; Constants - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant +vendor+ 1) -(defconstant +version+ 2) -(defconstant +extensions+ 3) -) - - -;;; Types - -;;; FIXME: -;;; - Are all the 32-bit values unsigned? Do we care? -;;; - These are not used much, yet. -(progn - (deftype attribute-pair ()) - (deftype bitfield () 'mask32) - (deftype bool32 () 'card32) ; 1 for true and 0 for false - (deftype enum () 'card32) - (deftype fbconfigid () 'card32) - ;; FIXME: How to define these two? - (deftype float32 () 'single-float) - (deftype float64 () 'double-float) - ;;(deftype glx-context () 'card32) - (deftype context-tag () 'card32) - ;;(deftype glx-drawable () 'card32) - (deftype glx-pixmap () 'card32) - (deftype glx-pbuffer () 'card32) - (deftype glx-render-command () #|TODO|#) - (deftype glx-window () 'card32) - #-(and) - (deftype visual-property () - "An ordered list of 32-bit property values followed by unordered pairs of -property types and property values." - ;; FIXME: maybe CLX-LIST or even just LIST? - 'clx-sequence)) - - -;;; FIXME: DEFINE-ACCESSOR interns getter and setter in XLIB package -;;; (using XINTERN). Therefore the accessors defined below can only -;;; be accessed using double-colon, which is a bad style. Or these -;;; forms must be taken to another file so the accessors exist before -;;; we get to this file. - -#-(and) -(define-accessor glx-context-tag (32) - ((index) `(read-card32 ,index)) - ((index thing) `(write-card32 ,index ,thing))) - -#-(and) -(define-accessor glx-enum (32) - ((index) `(read-card32 ,index)) - ((index thing) `(write-card32 ,index ,thing))) - - -;;; FIXME: I'm just not sure we need a seperate accessors for what -;;; essentially are aliases for other types. Maybe use compiler -;;; macros? -;;; -;;; This trick won't do because CLX wants e.g. CONTEXT-TAG to be a -;;; known accessor. The only trick left I think is to change the -;;; XINTERN function to intern the new symbols in the same package as -;;; he symbol part of it comes from. Don't know if it would break -;;; anything, thought. (I would be quite surprised if it did -- there -;;; is only one package in CLX after all: XLIB.) -;;; -;;; I also found the origin of the error (about symbol not being a -;;; known accessor): INDEX-INCREMENT function. Looks like all we have -;;; to do is to add an XLIB::BYTE-WIDTH property to the type symbol -;;; plist. But accessors are macros, not functions, anyway. - -#-(and) -(progn - (declaim (inline context-tag-get context-tag-put enum-get enum-put)) - (defun context-tag-get (index) (card32-get index)) - (defun context-tag-put (index thing) (card32-put index thing)) - (defun enum-get (index) (card32-get index)) - (defun enum-put (index thing) (card32-put index thing)) -) - - -;;; Structures - - -(def-clx-class (context (:constructor %make-context) - (:print-function print-context) - (:copier nil)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (tag 0 :type card32) - (drawable nil :type (or null drawable)) - ;; TODO: There can only be one current context (as far as I - ;; understand). If so, we'd need only one buffer (otherwise it's a - ;; big waste to have a quarter megabyte buffer for each context; or - ;; we could allocate/grow the buffer on demand). - ;; - ;; 256k buffer for Render command. Big requests are served with - ;; RenderLarge command. First 8 octets are Render request fields. - ;; - (rbuf (make-array (+ 8 (* 256 1024)) :element-type '(unsigned-byte 8)) :type buffer-bytes) - ;; Index into RBUF where the next rendering command should be inserted. - (index 8 :type array-index)) - - -(defun print-context (ctx stream depth) - (declare (type context ctx) - (ignore depth)) - (print-unreadable-object (ctx stream :type t) - (print-display-name (context-display ctx) stream) - (write-string " " stream) - (princ (context-id ctx) stream))) - - -(def-clx-class (visual (:constructor %make-visual) - (:print-function print-visual) - (:copier nil)) - (id 0 :type resource-id) - (attributes nil :type list)) - - -(defun print-visual (visual stream depth) - (declare (type visual visual) - (ignore depth)) - (print-unreadable-object (visual stream :type t) - (write-string "ID: " stream) - (princ (visual-id visual) stream) - (write-string " " stream) - (princ (visual-attributes visual) stream))) - - - -;;; Events. - -(defconstant +damaged+ #x8017) -(defconstant +saved+ #x8018) -(defconstant +window+ #x8019) -(defconstant +pbuffer+ #x801a) - - -(declare-event :glx-pbuffer-clobber - (card16 sequence) - (card16 event-type) ;; +DAMAGED+ or +SAVED+ - (card16 draw-type) ;; +WINDOW+ or +PBUFFER+ - (resource-id drawable) - ;; FIXME: (bitfield buffer-mask) - (card32 buffer-mask) - (card16 aux-buffer) - (card16 x y width height count)) - - - -;;; Errors. - -(define-condition bad-context (request-error) ()) -(define-condition bad-context-state (request-error) ()) -(define-condition bad-drawable (request-error) ()) -(define-condition bad-pixmap (request-error) ()) -(define-condition bad-context-tag (request-error) ()) -(define-condition bad-current-window (request-error) ()) -(define-condition bad-render-request (request-error) ()) -(define-condition bad-large-request (request-error) ()) -(define-condition unsupported-private-request (request-error) ()) -(define-condition bad-fb-config (request-error) ()) -(define-condition bad-pbuffer (request-error) ()) -(define-condition bad-current-drawable (request-error) ()) -(define-condition bad-window (request-error) ()) - -(define-error bad-context decode-core-error) -(define-error bad-context-state decode-core-error) -(define-error bad-drawable decode-core-error) -(define-error bad-pixmap decode-core-error) -(define-error bad-context-tag decode-core-error) -(define-error bad-current-window decode-core-error) -(define-error bad-render-request decode-core-error) -(define-error bad-large-request decode-core-error) -(define-error unsupported-private-request decode-core-error) -(define-error bad-fb-config decode-core-error) -(define-error bad-pbuffer decode-core-error) -(define-error bad-current-drawable decode-core-error) -(define-error bad-window decode-core-error) - - - -;;; Requests. - - -(defun query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +query-version+) - (card32 1) - (card32 3)) - (values - (card32-get 8) - (card32-get 12)))) - - -(defun query-server-string (display screen name) - "NAME is one of +VENDOR+, +VERSION+ or +EXTENSIONS+" - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +query-server-string+) - (card32 (or (position screen (display-roots display) :test #'eq) 0)) - (card32 name)) - (let* ((length (card32-get 12)) - (bytes (sequence-get :format card8 - :result-type '(simple-array card8 (*)) - :index 32 - :length length))) - (declare (type (simple-array card8 (*)) bytes) - (type fixnum length)) - (map-into (make-string (1- length)) #'code-char bytes)))) - - -(defun client-info (display) - ;; TODO: This should be invoked automatically when using this - ;; library in initialization stage. - ;; - ;; TODO: No extensions supported yet. - ;; - ;; *** Maybe the LENGTH field must be filled in some special way - ;; (similar to data)? - (with-buffer-request (display (extension-opcode display "GLX")) - (data +client-info+) - (card32 4) ; length of the request - (card32 1) ; major - (card32 3) ; minor - (card32 0) ; n - )) - - -;;; XXX: This looks like an internal thing. Should name appropriately. -(defun make-context (display) - (let ((ctx (%make-context :display display))) - (setf (context-id ctx) - (allocate-resource-id display ctx 'context)) - ;; Prepare render request buffer. - ctx)) - - -(defun create-context (screen visual - &optional - (share-list 0) - (is-direct nil)) - "Do NOT use the direct mode, yet!" - (let* ((root (screen-root screen)) - (display (drawable-display root)) - (ctx (make-context display))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +create-context+) - (resource-id (context-id ctx)) - (resource-id visual) - (card32 (or (position screen (display-roots display) :test #'eq) 0)) - (resource-id share-list) - (boolean is-direct)) - ctx)) - - -;;; TODO: Maybe make this var private to GLX-MAKE-CURRENT and GLX-GET-CURRENT-CONTEXT only? -;;; -(defvar *current-context* nil) - - -(defun destroy-context (ctx) - (let ((id (context-id ctx)) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +destroy-context+) - (resource-id id)) - (deallocate-resource-id display id 'context) - (setf (context-id ctx) 0) - (when (eq ctx *current-context*) - (setf *current-context* nil)))) - - -(defun is-direct (ctx) - (let ((display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +is-direct+) - (resource-id (context-id ctx))) - (card8-get 8)))) - - -(defun query-context (ctx) - ;; TODO: What are the attribute types? - (let ((display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +query-context+) - (resource-id (context-id ctx))) - (let ((num-attributes (card32-get 8))) - ;; FIXME: Is this really so? - (declare (type fixnum num-attributes)) - (loop - repeat num-attributes - for i fixnum upfrom 32 by 8 - collecting (cons (card32-get i) - (card32-get (+ i 4)))))))) - - -(defun get-drawable-attributes (drawable) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +get-drawable-attributes+) - (drawable drawable)) - (let ((num-attributes (card32-get 8))) - ;; FIXME: Is this really so? - (declare (type fixnum num-attributes)) - (loop - repeat num-attributes - for i fixnum upfrom 32 by 8 - collecting (cons (card32-get i) - (card32-get (+ i 4)))))))) - - -;;; TODO: What is the idea behind passing drawable to this function? -;;; Can a context be made current for different drawables at different -;;; times? (Man page on glXMakeCurrent says that context's viewport -;;; is set to the size of drawable when creating; it does not change -;;; afterwards.) -;;; -(defun make-current (drawable ctx) - (let ((display (drawable-display drawable)) - (old-tag (if *current-context* (context-tag *current-context*) 0))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +make-current+) - (resource-id (drawable-id drawable)) - (resource-id (context-id ctx)) - ;; *** CARD32 is really a CONTEXT-TAG - (card32 old-tag)) - (let ((new-tag (card32-get 8))) - (setf (context-tag ctx) new-tag - (context-drawable ctx) drawable - (context-display ctx) display - *current-context* ctx))))) - - -;;; FIXME: Decide how to represent and use these. -(eval-when (:load-toplevel :compile-toplevel :execute) - (macrolet ((generate-config-properties () - (let ((list '((:glx-visual visual-id) - (:glx-class card32) - (:glx-rgba bool32) - (:glx-red-size card32) - (:glx-green-size card32) - (:glx-blue-size card32) - (:glx-alpha-size card32) - (:glx-accum-red-size card32) - (:glx-accum-green-size card32) - (:glx-accum-blue-size card32) - (:glx-accum-alpha-size card32) - (:glx-double-buffer bool32) - (:glx-stereo bool32) - (:glx-buffer-size card32) - (:glx-depth-size card32) - (:glx-stencil-size card32) - (:glx-aux-buffers card32) - (:glx-level int32)))) - `(progn - ,@(loop for (symbol type) in list - collect `(setf (get ',symbol 'visual-config-property-type) ',type)) - (defparameter *visual-config-properties* - (map 'vector #'car ',list)) - (declaim (type simple-vector *visual-config-properties*)) - (deftype visual-config-property () - '(member ,@(mapcar #'car list))))))) - (generate-config-properties))) - - -(defun make-visual (attributes) - (let ((id-cons (first attributes))) - (assert (eq :glx-visual (car id-cons)) - (id-cons) - "GLX visual id must be first in attributes list!") - (%make-visual :id (cdr id-cons) - :attributes (rest attributes)))) - - -(defun visual-attribute (visual attribute) - (assert (or (numberp attribute) - (find attribute *visual-config-properties*)) - (attribute) - "~S is not a known GLX visual attribute." attribute) - (cdr (assoc attribute (visual-attributes visual)))) - - -;;; TODO: Make this return nice structured objects with field values of correct type. -;;; FIXME: Looks like every other result is corrupted. -(defun get-visual-configs (screen) - (let ((display (drawable-display (screen-root screen)))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +get-visual-configs+) - (card32 (or (position screen (display-roots display) :test #'eq) 0))) - (let* ((num-visuals (card32-get 8)) - (num-properties (card32-get 12)) - (num-ordered (length *visual-config-properties*))) - ;; FIXME: Is this really so? - (declare (type fixnum num-ordered num-visuals num-properties)) - (loop - with index fixnum = 28 - repeat num-visuals - collecting (make-visual - (nconc (when (<= num-ordered num-properties) - (map 'list #'(lambda (property) - (cons property (card32-get (incf index 4)))) - *visual-config-properties*)) - (when (< num-ordered num-properties) - (loop repeat (/ (- num-properties num-ordered) 2) - collecting (cons (card32-get (incf index 4)) - (card32-get (incf index 4)))))))))))) - - -(defun choose-visual (screen attributes) - "ATTRIBUTES is a list of desired attributes for a visual. The elements may be -either a symbol, which means that the boolean attribute with that name must be true; or -it can be a list of the form: (attribute-name value &optional (test '<=)) which means that -the attribute named attribute-name must satisfy the test when applied to the given value and -attribute's value in visual. -Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." - ;; TODO: Add type checks - ;; - ;; TODO: This function checks only supplied attributes; should check - ;; all attributes, with default for boolean type being false, and - ;; for number types zero. - ;; - ;; TODO: Make this smarter, like the docstring says, instead of - ;; parrotting the inflexible C API. - ;; - (flet ((visual-matches-p (visual attributes) - (dolist (attribute attributes t) - (etypecase attribute - (symbol (not (null (visual-attribute visual attribute)))) - (cons (<= (second attribute) (visual-attribute visual (car attribute)))))))) - (let* ((visuals (get-visual-configs screen)) - (candidates (loop - for visual in visuals - when (visual-matches-p visual attributes) - collect visual)) - (result (first candidates))) - - (dolist (candidate (rest candidates)) - ;; Visuals with glx-class 3 (pseudo-color) and 4 (true-color) - ;; are preferred over glx-class 2 (static-color) and 5 (direct-color). - (let ((class (visual-attribute candidate :glx-class))) - (when (or (= class 3) - (= class 4)) - (setf result candidate)))) - result))) - - -(defun render () - (declare (optimize (debug 3))) - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx)) - (rbuf (context-rbuf ctx)) - (index (context-index ctx))) - (declare (type buffer-bytes rbuf) - (type array-index index)) - (when (< 8 index) - (with-display (display) - ;; Flush display's buffer first so we don't get messed up with X requests. - (buffer-flush display) - ;; First, update the Render request fields. - (aset-card8 (extension-opcode display "GLX") rbuf 0) - (aset-card8 1 rbuf 1) - (aset-card16 (ceiling index 4) rbuf 2) - (aset-card32 (context-tag ctx) rbuf 4) - ;; Then send the request. - (buffer-write rbuf display 0 (context-index ctx)) - ;; Start filling from the beginning - (setf (context-index ctx) 8))) - (values))) - - -(defun swap-buffers () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - ;; Make sure all rendering commands are sent away. - (glx:render) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +swap-buffers+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)) - (resource-id (drawable-id (context-drawable ctx)))) - (display-force-output display))) - - -;;; FIXME: These two are more complicated than sending messages. As I -;;; understand it, wait-gl should inhibit any X requests until all GL -;;; requests are sent... -(defun wait-gl () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +wait-gl+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx))))) - - -(defun wait-x () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +wait-x+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx))))) diff --git a/src/clx/graphics.lisp b/src/clx/graphics.lisp deleted file mode 100644 index dec658067..000000000 --- a/src/clx/graphics.lisp +++ /dev/null @@ -1,447 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; CLX drawing requests - -;;; -;;; 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) - -(defvar *inhibit-appending* nil) - -(defun draw-point (drawable gcontext x y) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y)) - (let ((display (drawable-display drawable))) - (declare (type display display)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (data 0) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y)) - (setf (display-boffset display) (index+ buffer-boffset 4))) - ;; New Request - (progn - (put-items (4) - (code +x-polypoint+) - (data 0) ;; Relative-p false - (length 4) - (drawable drawable) - (gcontext gcontext) - (int16 x y)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 16))))))) - (display-invoke-after-function display))) - - -(defun draw-points (drawable gcontext points &optional relative-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p)) - (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext) - ((data boolean) relative-p) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points))) - -(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x1 y1 x2 y2) - (type generalized-boolean relative-p)) - (let ((display (drawable-display drawable))) - (declare (type display display)) - (when relative-p - (incf x2 x1) - (incf y2 y1)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x1 y1 x2 y2)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code +x-polysegment+) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x1 y1 x2 y2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) - (display-invoke-after-function display))) - -(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p fill-p) - (type (member :complex :non-convex :convex) shape)) - (if fill-p - (fill-polygon drawable gcontext points relative-p shape) - (with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext) - ((data boolean) relative-p) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points)))) - -;; Internal function called from DRAW-LINES -(defun fill-polygon (drawable gcontext points relative-p shape) - ;; This is clever about appending to previous requests. Should it be? - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p) - (type (member :complex :non-convex :convex) shape)) - (with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((member8 :complex :non-convex :convex) shape) - (boolean relative-p) - ((sequence :format int16) points))) - -(defun draw-segments (drawable gcontext segments) - (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) - (type sequence segments)) - (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) segments))) - -(defun draw-rectangle (drawable gcontext x y width height &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type generalized-boolean fill-p)) - (let ((display (drawable-display drawable)) - (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+))) - (declare (type display display) - (type card16 request)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) - (display-invoke-after-function display))) - -(defun draw-rectangles (drawable gcontext rectangles &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x) (integer y) (integer width) (integer height))) - (type sequence rectangles) - (type generalized-boolean fill-p)) - (with-buffer-request ((drawable-display drawable) - (if fill-p +x-polyfillrectangle+ +x-polyrectangle+) - :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) rectangles))) - -(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type angle angle1 angle2) - (type generalized-boolean fill-p)) - (let ((display (drawable-display drawable)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (declare (type display display) - (type card16 request)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (setf (display-boffset display) (index+ buffer-boffset 12))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 6) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 24))))))) - (display-invoke-after-function display))) - -(defun draw-arcs-list (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type list arcs) - (type generalized-boolean fill-p)) - (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((arc arcs)) - ((endp arc) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (pop arc)) - (int16-put 2 (pop arc)) - (card16-put 4 (pop arc)) - (card16-put 6 (pop arc)) - (angle-put 8 (pop arc)) - (angle-put 10 (pop arc)) - (set-buffer-offset (index+ buffer-boffset 12))))))) - -(defun draw-arcs-vector (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type vector arcs) - (type generalized-boolean fill-p)) - (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((n 0 (index+ n 6)) - (length (length arcs))) - ((index>= n length) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (aref arcs (index+ n 0))) - (int16-put 2 (aref arcs (index+ n 1))) - (card16-put 4 (aref arcs (index+ n 2))) - (card16-put 6 (aref arcs (index+ n 3))) - (angle-put 8 (aref arcs (index+ n 4))) - (angle-put 10 (aref arcs (index+ n 5))) - (set-buffer-offset (index+ buffer-boffset 12))))))) - -(defun draw-arcs (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence arcs) - (type generalized-boolean fill-p)) - (etypecase arcs - (list (draw-arcs-list drawable gcontext arcs fill-p)) - (vector (draw-arcs-vector drawable gcontext arcs fill-p)))) - -;; The following image routines are bare minimum. It may be useful to define -;; some form of "image" object to hide representation details and format -;; conversions. It also may be useful to provide stream-oriented interfaces -;; for reading and writing the data. - -(defun put-raw-image (drawable gcontext data &key - (start 0) - (depth (required-arg depth)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (left-pad 0) - (format (required-arg format))) - ;; Data must be a sequence of 8-bit quantities, already in the appropriate format - ;; for transmission; the caller is responsible for all byte and bit swapping and - ;; compaction. Start is the starting index in data; the end is computed from the - ;; other arguments. - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence data) ; Sequence of integers - (type array-index start) - (type card8 depth left-pad) ;; required - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (member :bitmap :xy-pixmap :z-pixmap) format)) - (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (gcontext gcontext) - (card16 width height) - (int16 x y) - (card8 left-pad depth) - (pad16 nil) - ((sequence :format card8 :start start) data))) - -(defun get-raw-image (drawable &key - data - (start 0) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (plane-mask #xffffffff) - (format (required-arg format)) - (result-type '(vector card8))) - ;; If data is given, it is modified in place (and returned), otherwise a new sequence - ;; is created and returned, with a size computed from the other arguments and the - ;; returned depth. The sequence is filled with 8-bit quantities, in transmission - ;; format; the caller is responsible for any byte and bit swapping and compaction - ;; required for further local use. - (declare (type drawable drawable) - (type (or null sequence) data) ;; sequence of integers - (type int16 x y) ;; required - (type card16 width height) ;; required - (type array-index start) - (type pixel plane-mask) - (type (member :xy-pixmap :z-pixmap) format)) - (declare (clx-values (clx-sequence integer) depth visual-info)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) - (let ((depth (card8-get 1)) - (length (* 4 (card32-get 4))) - (visual (resource-id-get 8))) - (values (sequence-get :result-type result-type :format card8 - :length length :start start :data data - :index +replysize+) - depth - (visual-info display visual)))))) diff --git a/src/clx/image.lisp b/src/clx/image.lisp deleted file mode 100644 index a52caa898..000000000 --- a/src/clx/image.lisp +++ /dev/null @@ -1,2668 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX Image functions - -;;; -;;; 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) - -(defmacro with-image-data-buffer ((buffer size) &body body) - (declare (indentation 0 4 1 1)) - `(let ((.reply-buffer. (allocate-reply-buffer ,size))) - (declare (type reply-buffer .reply-buffer.)) - (unwind-protect - (let ((,buffer (reply-ibuf8 .reply-buffer.))) - (declare (type buffer-bytes ,buffer)) - (with-vector (,buffer buffer-bytes) - ,@body)) - (deallocate-reply-buffer .reply-buffer.)))) - -(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) - ;; Public structure - (width 0 :type card16 :read-only t) - (height 0 :type card16 :read-only t) - (depth 1 :type card8 :read-only t) - (plist nil :type list)) - -;; Image-Plist accessors: -(defmacro image-name (image) `(getf (image-plist ,image) :name)) -(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot)) -(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot)) -(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask)) -(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask)) -(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask)) - -(defun print-image (image stream depth) - (declare (type image image) - (ignore depth)) - (print-unreadable-object (image stream :type t) - (when (image-name image) - (write-string (string (image-name image)) stream) - (write-string " " stream)) - (prin1 (image-width image) stream) - (write-string "x" stream) - (prin1 (image-height image) stream) - (write-string "x" stream) - (prin1 (image-depth image) stream))) - -(defconstant +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0)) - -(defconstant +empty-data-z+ - '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) - -(def-clx-class (image-x (:include image) (:copier nil) - (:print-function print-image)) - ;; Use this format for shoveling image data - ;; Private structure. Accessors for these NOT exported. - (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) - (bytes-per-line 0 :type card16) - (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order - (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order - (data +empty-data-x+ :type (array card8 (*))) ; row-major - (unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit - (pad +image-pad+ :type (member 8 16 32)) ; Scanline pad - (left-pad 0 :type card8)) ; Left pad - -(def-clx-class (image-xy (:include image) (:copier nil) - (:print-function print-image)) - ;; Public structure - ;; Use this format for image processing - (bitmap-list nil :type list)) ;; list of bitmaps - -(def-clx-class (image-z (:include image) (:copier nil) - (:print-function print-image)) - ;; Public structure - ;; Use this format for image processing - (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (pixarray +empty-data-z+ :type pixarray)) - -(defun create-image (&key width height depth - (data (required-arg data)) - plist name x-hot y-hot - red-mask blue-mask green-mask - bits-per-pixel format bytes-per-line - (byte-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - (bit-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - unit pad left-pad) - ;; Returns an image-x image-xy or image-z structure, depending on the - ;; type of the :DATA parameter. - (declare - (type (or null card16) width height) ; Required - (type (or null card8) depth) ; Defualts to 1 - (type (or buffer-bytes ; Returns image-x - list ; Returns image-xy - pixarray) data) ; Returns image-z - (type list plist) - (type (or null stringable) name) - (type (or null card16) x-hot y-hot) - (type (or null pixel) red-mask blue-mask green-mask) - (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) - - ;; The following parameters are ignored for image-xy and image-z: - (type (or null (member :bitmap :xy-pixmap :z-pixmap)) - format) ; defaults to :z-pixmap - (type (or null card16) bytes-per-line) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (type (or null (member 8 16 32)) unit pad) - (type (or null card8) left-pad)) - (declare (clx-values image)) - (let ((image - (etypecase data - (buffer-bytes ; image-x - (let ((data data)) - (declare (type buffer-bytes data)) - (unless depth (setq depth (or bits-per-pixel 1))) - (unless format - (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) - (unless bits-per-pixel - (setq bits-per-pixel - (cond ((eq format :xy-pixmap) 1) - ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1)))) - (unless width (required-arg width)) - (unless height (required-arg height)) - (unless bytes-per-line - (let* ((pad (or pad 8)) - (bits-per-line (index* width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad))) - (declare (type array-index pad bits-per-line - padded-bits-per-line)) - (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) - (unless unit (setq unit +image-unit+)) - (unless pad - (setq pad - (dolist (pad '(32 16 8)) - (when (and (index<= pad +image-pad+) - (zerop - (index-mod - (index* bytes-per-line 8) pad))) - (return pad))))) - (unless left-pad (setq left-pad 0)) - (make-image-x - :width width :height height :depth depth :plist plist - :format format :data data - :bits-per-pixel bits-per-pixel - :bytes-per-line bytes-per-line - :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p - :unit unit :pad pad :left-pad left-pad))) - (list ; image-xy - (let ((data data)) - (declare (type list data)) - (unless depth (setq depth (length data))) - (when data - (unless width (setq width (array-dimension (car data) 1))) - (unless height (setq height (array-dimension (car data) 0)))) - (make-image-xy - :width width :height height :plist plist :depth depth - :bitmap-list data))) - (pixarray ; image-z - (let ((data data)) - (declare (type pixarray data)) - (unless width (setq width (array-dimension data 1))) - (unless height (setq height (array-dimension data 0))) - (unless bits-per-pixel - (setq bits-per-pixel - (etypecase data - (pixarray-32 32) - (pixarray-24 24) - (pixarray-16 16) - (pixarray-8 8) - (pixarray-4 4) - (pixarray-1 1))))) - (unless depth (setq depth bits-per-pixel)) - (make-image-z - :width width :height height :depth depth :plist plist - :bits-per-pixel bits-per-pixel :pixarray data))))) - (declare (type image image)) - (when name (setf (image-name image) name)) - (when x-hot (setf (image-x-hot image) x-hot)) - (when y-hot (setf (image-y-hot image) y-hot)) - (when red-mask (setf (image-red-mask image) red-mask)) - (when blue-mask (setf (image-blue-mask image) blue-mask)) - (when green-mask (setf (image-green-mask image) green-mask)) - image)) - -;;;----------------------------------------------------------------------------- -;;; Swapping stuff - -(defun image-noswap - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (if (index= srcinc destinc) - (buffer-replace - dest src destoff - (index+ destoff (index* srcinc (index1- height)) srclen) - srcoff) - (do* ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc)) - (destend (index+ deststart srclen) (index+ deststart srclen))) - ((index-zerop h)) - (declare (type array-index srcstart deststart destend) - (type card16 h)) - (buffer-replace dest src deststart destend srcstart)))) - -(defun image-swap-two-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-three-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 3) 3)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 3) - (when (index= (index- srclen length) 2) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 1))))) - (if lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2)))))) - (do ((i length (index- i 3)) - (srcidx srcstart (index+ srcidx 3)) - (destidx deststart (index+ destidx 3))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-four-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-words - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src (index1+ srcidx))))))))) - -(defun image-swap-nibbles - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte (aref src srcidx))) - (declare (type card8 byte)) - (dpb (the card4 (ldb (byte 4 0) byte)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte))))))))))) - -(defun image-swap-nibbles-left - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index= i 1) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx))) - (declare (type card8 byte1)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - 0))))) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx)) - (byte2 (aref src (index1+ srcidx)))) - (declare (type card8 byte1 byte2)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte2))))))))))) - -(defconstant +image-byte-reverse+ - '#.(coerce - '#( - 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 - 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 - 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 - 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 - 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 - 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 - 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 - 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 - 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 - 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 - 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 - 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 - 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 - 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 - 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 - 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) - '(vector card8))) - -(defun image-swap-bits - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-two-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (br (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-four-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-words - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (br (aref src (index1+ srcidx)))))))))))) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 -;;; -;;; -;;; The following table gives the required conversion between any two -;;; formats. It is based strictly on the table above. If you believe one, -;;; you should believe the other. -;;; -;;; legend: -;;; n no changes -;;; s reverse 8-bit units within 16-bit units -;;; l reverse 8-bit units within 32-bit units -;;; w reverse 16-bit units within 32-bit units -;;; r reverse bits within 8-bit units -;;; sr s+R -;;; lr l+R -;;; wr w+R - -(defconstant +image-swap-function+ - '#.(make-array - '(12 12) :initial-contents - (let ((n 'image-noswap) - (s 'image-swap-two-bytes) - (l 'image-swap-four-bytes) - (w 'image-swap-words) - (r 'image-swap-bits) - (sr 'image-swap-bits-and-two-bytes) - (lr 'image-swap-bits-and-four-bytes) - (wr 'image-swap-bits-and-words)) - (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# - (list #| 1Mm |# n n n r sr lr n s l r r r ) - (list #| 2Mm |# n n n r sr lr n s l r r r ) - (list #| 4Mm |# n n n r sr lr n s l r r r ) - (list #| 1Ml |# r r r n s l r sr lr n n n ) - (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) - (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) - (list #| 1Lm |# n n n r sr lr n s l r r r ) - (list #| 2Lm |# s s s sr r wr s n w sr sr sr) - (list #| 4Lm |# l l l lr wr r l w n lr lr lr) - (list #| 1Ll |# r r r n s l r sr lr n n n ) - (list #| 2Ll |# r r r n s l r sr lr n n n ) - (list #| 4Ll |# r r r n s l r sr lr n n n ))))) - -;;; Of course, the table above is a lie. We also need to factor in the -;;; order of the source data to cope with swapping half of a unit at the -;;; end of a scanline, since we are trying to avoid de-ref'ing off the -;;; end of the source. -;;; -;;; Defines whether the first half of a unit has the first half of the data - -(defconstant +image-swap-lsb-first-p+ - '#.(make-array - 12 :initial-contents - (list t #| 1mm |# - t #| 2mm |# - t #| 4mm |# - t #| 1ml |# - nil #| 2ml |# - nil #| 4ml |# - t #| 1lm |# - nil #| 2lm |# - nil #| 4lm |# - t #| 1ll |# - t #| 2ll |# - t #| 4ll |# - ))) - -(defun image-swap-function - (bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p) - (clx-values function lsb-first-p)) - (cond ((index= bits-per-pixel 1) - (let ((from-index - (index+ - (ecase from-bitmap-unit (32 2) (16 1) (8 0)) - (if from-bit-lsb-first-p 3 0) - (if from-byte-lsb-first-p 6 0)))) - (values - (aref +image-swap-function+ from-index - (index+ - (ecase to-bitmap-unit (32 2) (16 1) (8 0)) - (if to-bit-lsb-first-p 3 0) - (if to-byte-lsb-first-p 6 0))) - (aref +image-swap-lsb-first-p+ from-index)))) - (t - (values - (if (if (index= bits-per-pixel 4) - (eq from-bit-lsb-first-p to-bit-lsb-first-p) - (eq from-byte-lsb-first-p to-byte-lsb-first-p)) - 'image-noswap - (ecase bits-per-pixel - (4 'image-swap-nibbles) - (8 'image-noswap) - (16 'image-swap-two-bytes) - (24 'image-swap-three-bytes) - (32 'image-swap-four-bytes))) - from-byte-lsb-first-p)))) - - -;;;----------------------------------------------------------------------------- -;;; GET-IMAGE - -(defun read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index - (mod (the (integer #x-FFFF 0) (- x)) - 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (- width left-bits right-bits)) - (middle-bytes (floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y left-bits right-bits)) - (declare (fixnum middle-bits middle-bytes)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-bits (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (index+ left-bits middle-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref array y (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - -(defun read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (mod (the fixnum (- x)) 2)) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-nibbles (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - -(defun read-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - x) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (the card8 (aref buffer-bbuf i))))))) - -(defun read-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)))))))) - -(defun read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - -(defun read-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 4)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)) - (aref buffer-bbuf (index+ i 3)))))))) - -(defun read-pixarray-internal - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel read-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function read-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (if (eq image-swap-function 'image-noswap) - (funcall - read-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) bbuf buf - (index+ boffset (index* y padded-bytes-per-line)) 0 - (index-ceiling (index* (index+ x width) bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p) - (funcall - read-pixarray-function - buf 0 pixarray x 0 width height padded-bytes-per-line - bits-per-pixel))))) - -(defun read-pixarray - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (fast-read-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel - (ecase bits-per-pixel - ( 1 #'read-pixarray-1 ) - ( 4 #'read-pixarray-4 ) - ( 8 #'read-pixarray-8 ) - (16 #'read-pixarray-16) - (24 #'read-pixarray-24) - (32 #'read-pixarray-32)) - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))) - -(defun read-xy-format-image-x - (buffer-bbuf index length data width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p pad) - (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-x)) - (assert (index<= (index* depth padded-bytes-per-plane) length)) - (let* ((bytes-per-line (index-ceiling width 8)) - (data-length (index* padded-bytes-per-plane depth))) - (declare (type array-index bytes-per-line data-length)) - (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) - (do ((plane 0 (index1+ plane))) - ((index>= plane depth)) - (declare (type image-depth plane)) - (image-noswap - buffer-bbuf data - (index+ index (index* plane padded-bytes-per-plane)) - (index* plane padded-bytes-per-plane) - bytes-per-line padded-bytes-per-line padded-bytes-per-line - height byte-lsb-first-p)) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel 1 :format :xy-pixmap - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun read-z-format-image-x - (buffer-bbuf index length data width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (clx-values image-x)) - (assert (index<= (index* height padded-bytes-per-line) length)) - (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) - (data-length (index* padded-bytes-per-line height))) - (declare (type array-index bytes-per-line data-length)) - (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) - (image-noswap - buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line - padded-bytes-per-line height byte-lsb-first-p) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel bits-per-pixel :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun read-image-xy (bbuf index length data x y width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-xy)) - (check-type data list) - (multiple-value-bind (dimensions element-type) - (if data - (values (array-dimensions (first data)) - (array-element-type (first data))) - (values (list height - (index* (index-ceiling width +image-pad+) +image-pad+)) - 'pixarray-1-element-type)) - (do* ((arrays data) - (result nil) - (limit (index+ length index)) - (plane 0 (1+ plane)) - (index index (index+ index padded-bytes-per-plane))) - ((or (>= plane depth) - (index> (index+ index padded-bytes-per-plane) limit)) - (setq data (nreverse result) depth (length data))) - (declare (type array-index limit index) - (type image-depth plane) - (type list arrays result)) - (let ((array (or (pop arrays) - (make-array dimensions :element-type element-type)))) - (declare (type pixarray-1 array)) - (push array result) - (read-pixarray - bbuf index array x y width height padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth depth :data data))) - -(defun read-image-z (bbuf index length data x y width height depth - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-z)) - (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) - (let* ((image-bits-per-line (index* width bits-per-pixel)) - (image-pixels-per-line - (index-ceiling - (index* (index-ceiling image-bits-per-line +image-pad+) - +image-pad+) - bits-per-pixel))) - (declare (type array-index image-bits-per-line image-pixels-per-line)) - (unless data - (setq data - (make-array - (list height image-pixels-per-line) - :element-type (ecase bits-per-pixel - (1 'pixarray-1-element-type) - (4 'pixarray-4-element-type) - (8 'pixarray-8-element-type) - (16 'pixarray-16-element-type) - (24 'pixarray-24-element-type) - (32 'pixarray-32-element-type))))) - (read-pixarray - bbuf index data x y width height padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel bits-per-pixel))) - -(defun get-image (drawable &key - data - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - plane-mask format result-type) - (declare (type drawable drawable) - (type (or buffer-bytes list pixarray) data) - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (or null pixel) plane-mask) - (type (or null (member :xy-pixmap :z-pixmap)) format) - (type (or null (member image-xy image-x image-z)) result-type) - (clx-values image visual-info)) - (unless result-type - (setq result-type (ecase format - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z) - ((nil) 'image-x)))) - (unless format - (setq format (case result-type - (image-xy :xy-pixmap) - ((image-z image-x) :z-pixmap)))) - (unless (ecase result-type - (image-xy (eq format :xy-pixmap)) - (image-z (eq format :z-pixmap)) - (image-x t)) - (error "Result-type ~s is incompatible with format ~s" - result-type format)) - (unless plane-mask (setq plane-mask #xffffffff)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) - (let* ((depth (card8-get 1)) - (length (index* 4 (card32-get 4))) - (visual-info (visual-info display (resource-id-get 8))) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type image-depth depth) - (type array-index length) - (type (or null visual-info) visual-info) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - (:xy-pixmap - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type pixmap-format pixmap-format)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane - (index* padded-bytes-per-line height)) - (image - (ecase result-type - (image-x - (ecase format - (:xy-pixmap - (read-xy-format-image-x - buffer-bbuf +replysize+ length data - width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p - pad)) - (:z-pixmap - (read-z-format-image-x - buffer-bbuf +replysize+ length data - width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - pad bits-per-pixel)))) - (image-xy - (read-image-xy - buffer-bbuf +replysize+ length data - 0 0 width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (read-image-z - buffer-bbuf +replysize+ length data - 0 0 width height depth padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p))))) - (declare (type image image) - (type array-index bits-per-line - padded-bits-per-line padded-bytes-per-line)) - (when visual-info - (unless (zerop (visual-info-red-mask visual-info)) - (setf (image-red-mask image) - (visual-info-red-mask visual-info))) - (unless (zerop (visual-info-green-mask visual-info)) - (setf (image-green-mask image) - (visual-info-green-mask visual-info))) - (unless (zerop (visual-info-blue-mask visual-info)) - (setf (image-blue-mask image) - (visual-info-blue-mask visual-info)))) - (values image visual-info))))))) - - -;;;----------------------------------------------------------------------------- -;;; PUT-IMAGE - -(defun write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (index+ start-x middle-bits))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (if (index> right-bits 1) - (aref array y (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref array y (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref array y (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref array y (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref array y (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref array y (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)) - (aref array y (index+ x 2)) - (aref array y (index+ x 3)) - (aref array y (index+ x 4)) - (aref array y (index+ x 5)) - (aref array y (index+ x 6)) - (aref array y (index+ x 7)))))))) - -(defun write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)))))))) - -(defun write-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) - -(defun write-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-16-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 16)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 16))))))) - -(defun write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - -(defun write-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-32-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 32)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 32)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 32)) - (setf (aref buffer-bbuf (index+ i 3)) - (write-image-load-byte 24 pixel 32))))))) - -(defun write-pixarray-internal - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel write-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function write-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (if (eq image-swap-function 'image-noswap) - (funcall - write-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - write-pixarray-function - buf 0 pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (funcall - (symbol-function image-swap-function) buf bbuf 0 boffset - (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p))))) - -(defun write-pixarray - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (fast-write-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel - (ecase bits-per-pixel - ( 1 #'write-pixarray-1 ) - ( 4 #'write-pixarray-4 ) - ( 8 #'write-pixarray-8 ) - (16 #'write-pixarray-16) - (24 #'write-pixarray-24) - (32 #'write-pixarray-32)) - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))) - -(defun write-xy-format-image-x-data - (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (assert (index-zerop (index-mod x 8))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - 1 - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (let ((x-mod-unit (index-mod x from-bitmap-unit))) - (declare (type card16 x-mod-unit)) - (if (and (index-plusp x-mod-unit) - (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) - (let* ((temp-width (index+ width x-mod-unit)) - (temp-bytes-per-line (index-ceiling temp-width 8)) - (temp-padded-bits-per-line - (index* (index-ceiling temp-width from-bitmap-unit) - from-bitmap-unit)) - (temp-padded-bytes-per-line - (index-ceiling temp-padded-bits-per-line 8))) - (declare (type card16 temp-width temp-bytes-per-line - temp-padded-bits-per-line temp-padded-bytes-per-line)) - (with-image-data-buffer - (buf (index* height temp-padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) data buf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index- x x-mod-unit) 8)) - 0 temp-bytes-per-line from-padded-bytes-per-line - temp-padded-bytes-per-line height image-swap-lsb-first-p) - (write-xy-format-image-x-data - buf obuf 0 obuf-start x-mod-unit 0 width height - temp-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) - (funcall - (symbol-function image-swap-function) data obuf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor x 8)) - obuf-start (index-ceiling width 8) from-padded-bytes-per-line - to-padded-bytes-per-line height image-swap-lsb-first-p))))) - -(defun write-xy-format-image-x - (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (dotimes (plane (image-depth image)) - (let ((data-start - (index* (index* plane (image-height image)) - (image-x-bytes-per-line image))) - (src-y src-y) - (height height)) - (declare (type int16 src-y) - (type card16 height)) - (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-xy-format-image-x-data - (image-x-data image) (buffer-obuf8 display) - data-start (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) - -(defun write-z-format-image-x-data - (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (if (index= bits-per-pixel 1) - (write-xy-format-image-x-data - data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (let ((srcoff - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index* x bits-per-pixel) 8))) - (srclen (index-ceiling (index* width bits-per-pixel) 8))) - (declare (type array-index srcoff srclen)) - (if (and (index= bits-per-pixel 4) (index-oddp x)) - (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) - (image-swap-nibbles-left - data buf srcoff 0 srclen - from-padded-bytes-per-line to-padded-bytes-per-line height nil) - (write-z-format-image-x-data - buf obuf 0 obuf-start 0 0 width height - to-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) data obuf srcoff obuf-start - srclen from-padded-bytes-per-line to-padded-bytes-per-line height - image-swap-lsb-first-p)))))) - -(defun write-z-format-image-x (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-z-format-image-x-data - (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))) - -(defun write-image-xy (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-xy image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (let ((src-y src-y) - (height height)) - (declare (type int16 src-y) - (type card16 height)) - (loop - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - bitmap src-x src-y width nlines - padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) - -(defun write-image-z (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-z image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (loop - (let ((bits-per-pixel (image-z-bits-per-pixel image)) - (nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - (image-z-pixarray image) src-x src-y width nlines - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))) - -;;; Note: The only difference between a format of :bitmap and :xy-pixmap -;;; of depth 1 is that when sending a :bitmap format the foreground -;;; and background in the gcontext are used. - -(defun put-image (drawable gcontext image &key - (src-x 0) (src-y 0) ;Position within image - (x (required-arg x)) ;Position within drawable - (y (required-arg y)) - width height - bitmap-p) - ;; Copy an image into a drawable. - ;; WIDTH and HEIGHT default from IMAGE. - ;; When BITMAP-P, force format to be :bitmap when depth=1. - ;; This causes gcontext to supply foreground & background pixels. - (declare (type drawable drawable) - (type gcontext gcontext) - (type image image) - (type int16 x y) ;; required - (type int16 src-x src-y) - (type (or null card16) width height) - (type generalized-boolean bitmap-p)) - (let* ((format - (etypecase image - (image-x (image-x-format (the image-x image))) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (src-x - (if (image-x-p image) - (index+ src-x (image-x-left-pad (the image-x image))) - src-x)) - (image-width (image-width image)) - (image-height (image-height image)) - (width (min (or width image-width) (index- image-width src-x))) - (height (min (or height image-height) (index- image-height src-y))) - (depth (image-depth image)) - (display (drawable-display drawable)) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) - (type fixnum src-x image-width image-height width height) - (type image-depth depth) - (type display display) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (when (and bitmap-p (not (index= depth 1))) - (error "Bitmaps must have depth 1")) - (unless (<= 0 src-x (index1- (image-width image))) - (error "src-x not inside image")) - (unless (<= 0 src-y (index1- (image-height image))) - (error "src-y not inside image")) - (when (and (index> width 0) (index> height 0)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - ((:bitmap :xy-pixmap) - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type (or null pixmap-format) pixmap-format)) - (if (null pixmap-format) - (error "The depth of the image ~s does not match any server pixmap format." image)) - (if (not (= (etypecase image - (image-z (image-z-bits-per-pixel image)) - (image-x (image-x-bits-per-pixel image))) - (pixmap-format-bits-per-pixel pixmap-format))) - ;; We could try to use the "/* XXX slow, but works */" - ;; code in XPutImage from X11R4 here. However, that - ;; would require considerable support code - ;; (see XImUtil.c, etc). - (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((left-pad - (if (or (eq format :xy-pixmap) (= depth 1)) - (index-mod src-x (index-min pad +image-pad+)) - 0)) - (left-padded-src-x (index- src-x left-pad)) - (left-padded-width (index+ width left-pad)) - (bits-per-line (index* left-padded-width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (request-bytes-per-line - (ecase format - ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) - (:z-pixmap padded-bytes-per-line))) - (max-bytes-per-request - (index* (index- (display-max-request-length display) 6) 4)) - (max-request-height - (floor max-bytes-per-request request-bytes-per-line))) - (declare (type card8 left-pad) - (type int16 left-padded-src-x) - (type card16 left-padded-width) - (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line request-bytes-per-line - max-bytes-per-request max-request-height)) - ;; Be sure that a scanline can fit in a request - (when (index-zerop max-request-height) - (error "Can't even fit one image scanline in a request")) - ;; Be sure a scanline can fit in a buffer - (buffer-ensure-size display padded-bytes-per-line) - ;; Send the image in multiple requests to avoid exceeding the - ;; request limit - (do* ((request-src-y src-y (index+ request-src-y request-height)) - (request-y y (index+ request-y request-height)) - (height-remaining - height (the fixnum (- height-remaining request-height))) - (request-height - (index-min height-remaining max-request-height) - (index-min height-remaining max-request-height))) - ((<= height-remaining 0)) - (declare (type array-index request-src-y request-height) - (fixnum height-remaining)) - (let* ((request-bytes (index* request-bytes-per-line request-height)) - (request-words (index-ceiling request-bytes 4)) - (request-length (index+ request-words 6))) - (declare (type array-index request-bytes) - (type card16 request-words request-length)) - (with-buffer-request (display +x-putimage+ :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) - (cond ((or (eq format :bitmap) bitmap-p) :bitmap) - ((plusp left-pad) :xy-pixmap) - (t format))) - (drawable drawable) - (gcontext gcontext) - (card16 width request-height) - (int16 x request-y) - (card8 left-pad depth) - (pad16 nil) - (progn - (length-put 2 request-length) - (setf (buffer-boffset display) (advance-buffer-offset 24)) - (etypecase image - (image-x - (ecase (image-x-format (the image-x image)) - ((:bitmap :xy-pixmap) - (write-xy-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (:z-pixmap - (write-z-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)))) - (image-xy - (write-image-xy - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (write-image-z - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p))) - ;; Be sure the request is padded to a multiple of 4 bytes - (buffer-pad-request display (index- (index* request-words 4) request-bytes)) - ))))))))) - -;;;----------------------------------------------------------------------------- -;;; COPY-IMAGE - -(defun xy-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad (index-mod padded-x 8)) - (x (index- padded-x left-pad)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (padded-width - (index* (index-ceiling (index+ width left-pad) pad) pad)) - (padded-bytes-per-line (index-ceiling padded-width 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) - (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index padded-width padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) - (dotimes (plane (image-depth image)) - (let ((data-start - (index* (image-x-bytes-per-line image) - (image-height image) - plane)) - (obuf-start - (index* padded-bytes-per-plane - plane))) - (declare (type array-index data-start obuf-start)) - (write-xy-format-image-x-data - (image-x-data image) obuf data-start obuf-start - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth (image-depth image) - :data obuf :format (image-x-format image) :bits-per-pixel 1 - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad :left-pad left-pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun z-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad - (if (index= (image-depth image) 1) - (index-mod padded-x 8) - 0)) - (x (index- padded-x left-pad)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) - (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) - (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index bits-per-pixel padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) - (write-z-format-image-x-data - (image-x-data image) obuf 0 0 - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p) - (create-image - :width width :height height :depth (image-depth image) - :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad :left-pad left-pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (ecase (image-x-format image) - ((:bitmap :xy-pixmap) - (xy-format-image-x->image-x image x y width height)) - (:z-pixmap - (z-format-image-x->image-x image x y width height)))) - -(defun image-x->image-xy (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-xy)) - (unless (or (eq (image-x-format image) :bitmap) - (eq (image-x-format image) :xy-pixmap) - (and (eq (image-x-format image) :z-pixmap) - (index= (image-depth image) 1))) - (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :xy-pixmap)) - (read-image-xy - (image-x-data image) 0 (length (image-x-data image)) nil - (index+ x (image-x-left-pad image)) y width height - (image-depth image) (image-x-bytes-per-line image) - (index* (image-x-bytes-per-line image) (image-height image)) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image))) - -(defun image-x->image-z (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-z)) - (unless (or (eq (image-x-format image) :z-pixmap) - (eq (image-x-format image) :bitmap) - (and (eq (image-x-format image) :xy-pixmap) - (index= (image-depth image) 1))) - (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :z-pixmap)) - (read-image-z - (image-x-data image) 0 (length (image-x-data image)) nil - (index+ x (image-x-left-pad image)) y width height - (image-depth image) (image-x-bytes-per-line image) - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image))) - -(defun copy-pixarray (array x y width height bits-per-pixel) - (declare (type pixarray array) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) - (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) - (copy (make-array (list height padded-width) - :element-type (array-element-type array)))) - (declare (type array-index bits-per-line padded-bits-per-line padded-width) - (type pixarray copy)) - #.(declare-buffun) - (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) - (macrolet - ((copy (array-type element-type) - `(let ((array array) - (copy copy)) - (declare (type ,array-type array copy)) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-x 0 (index1+ dst-x)) - (src-x x (index1+ src-x))) - ((index>= dst-x width)) - (declare (type card16 dst-x src-x)) - (setf (aref copy dst-y dst-x) - (the ,element-type - (aref array src-y src-x)))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))))) - copy)) - -(defun image-xy->image-x (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-bits-per-line - (index* (index-ceiling width +image-pad+) +image-pad+)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (bytes-total (index* padded-bytes-per-plane (image-depth image))) - (data (make-array bytes-total :element-type 'card8))) - (declare (type array-index padded-bits-per-line padded-bytes-per-line - padded-bytes-per-plane bytes-total) - (type buffer-bytes data)) - (let ((index 0)) - (declare (type array-index index)) - (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (write-pixarray - data index bitmap x y width height padded-bytes-per-line 1 - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) - (index-incf index padded-bytes-per-plane))) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :xy-pixmap :bits-per-pixel 1 - :bytes-per-line padded-bytes-per-line - :unit +image-unit+ :pad +image-pad+ - :byte-lsb-first-p +image-byte-lsb-first-p+ - :bit-lsb-first-p +image-bit-lsb-first-p+))) - -(defun image-xy->image-xy (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-xy)) - (create-image - :width width :height height :depth (image-depth image) - :data (mapcar - #'(lambda (array) - (declare (type pixarray-1 array)) - (copy-pixarray array x y width height 1)) - (image-xy-bitmap-list image)))) - -(defun image-xy->image-z (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (ignore image x y width height)) - (error "Format conversion from ~S to ~S not supported" - :xy-pixmap :z-pixmap)) - -(defun image-z->image-x (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) - (padded-bits-per-line - (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (bytes-total - (index* padded-bytes-per-line height (image-depth image))) - (data (make-array bytes-total :element-type 'card8)) - (bits-per-pixel (image-z-bits-per-pixel image))) - (declare (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line bytes-total) - (type buffer-bytes data) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (write-pixarray - data 0 (image-z-pixarray image) x y width height padded-bytes-per-line - (image-z-bits-per-pixel image) - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :z-pixmap - :bits-per-pixel bits-per-pixel - :bytes-per-line padded-bytes-per-line - :unit +image-unit+ :pad +image-pad+ - :byte-lsb-first-p +image-byte-lsb-first-p+ - :bit-lsb-first-p +image-bit-lsb-first-p+))) - -(defun image-z->image-xy (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (ignore image x y width height)) - (error "Format conversion from ~S to ~S not supported" - :z-pixmap :xy-pixmap)) - -(defun image-z->image-z (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (clx-values image-z)) - (create-image - :width width :height height :depth (image-depth image) - :data (copy-pixarray - (image-z-pixarray image) x y width height - (image-z-bits-per-pixel image)))) - -(defun copy-image (image &key (x 0) (y 0) width height result-type) - ;; Copy with optional sub-imaging and format conversion. - ;; result-type defaults to (type-of image) - (declare (type image image) - (type card16 x y) - (type (or null card16) width height) ;; Default from image - (type (or null (member image-x image-xy image-z)) result-type)) - (declare (clx-values image)) - (let* ((image-width (image-width image)) - (image-height (image-height image)) - (width (or width image-width)) - (height (or height image-height))) - (declare (type card16 image-width image-height width height)) - (unless (<= 0 x (the fixnum (1- image-width))) - (error "x not inside image")) - (unless (<= 0 y (the fixnum (1- image-height))) - (error "y not inside image")) - (setq width (index-min width (max (the fixnum (- image-width x)) 0))) - (setq height (index-min height (max (the fixnum (- image-height y)) 0))) - (let ((copy - (etypecase image - (image-x - (ecase result-type - ((nil image-x) (image-x->image-x image x y width height)) - (image-xy (image-x->image-xy image x y width height)) - (image-z (image-x->image-z image x y width height)))) - (image-xy - (ecase result-type - (image-x (image-xy->image-x image x y width height)) - ((nil image-xy) (image-xy->image-xy image x y width height)) - (image-z (image-xy->image-z image x y width height)))) - (image-z - (ecase result-type - (image-x (image-z->image-x image x y width height)) - (image-xy (image-z->image-xy image x y width height)) - ((nil image-z) (image-z->image-z image x y width height))))))) - (declare (type image copy)) - (setf (image-plist copy) (copy-list (image-plist image))) - (when (and (image-x-hot image) (not (index-zerop x))) - (setf (image-x-hot copy) (index- (image-x-hot image) x))) - (when (and (image-y-hot image) (not (index-zerop y))) - (setf (image-y-hot copy) (index- (image-y-hot image) y))) - copy))) - - -;;;----------------------------------------------------------------------------- -;;; Image I/O functions - - -(defun read-bitmap-file (pathname) - ;; Creates an image from a C include file in standard X11 format - (declare (type (or pathname string stream) pathname)) - (declare (clx-values image)) - (with-open-file (fstream pathname :direction :input) - (let ((line "") - (properties nil) - (name nil) - (name-end nil)) - (declare (type string line) - (type stringable name) - (type list properties)) - ;; Get properties - (loop - (setq line (read-line fstream)) - (unless (char= (aref line 0) #\#) (return)) - (flet ((read-keyword (line start end) - (kintern - (substitute - #\- #\_ - (#-excl string-upcase - #+excl correct-case - (subseq line start end)) - :test #'char=)))) - (when (null name) - (setq name-end (position #\_ line :test #'char= :from-end t) - name (read-keyword line 8 name-end)) - (unless (eq name :image) - (setf (getf properties :name) name))) - (let* ((ind-start (index1+ name-end)) - (ind-end (position #\Space line :test #'char= - :start ind-start)) - (ind (read-keyword line ind-start ind-end)) - (val-start (index1+ ind-end)) - (val (parse-integer line :start val-start))) - (setf (getf properties ind) val)))) - ;; Calculate sizes - (multiple-value-bind (width height depth left-pad) - (flet ((extract-property (ind &rest default) - (prog1 (apply #'getf properties ind default) - (remf properties ind)))) - (values (extract-property :width) - (extract-property :height) - (extract-property :depth 1) - (extract-property :left-pad 0))) - (declare (type (or null card16) width height) - (type image-depth depth) - (type card8 left-pad)) - (unless (and width height) (error "Not a BITMAP file")) - (let* ((bits-per-pixel - (cond ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1))) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line 32) 32)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (data (make-array (* padded-bytes-per-line height) - :element-type 'card8)) - (line-base 0) - (byte 0)) - (declare (type array-index bits-per-line bytes-per-line - padded-bits-per-line padded-bytes-per-line - line-base byte) - (type buffer-bytes data)) - (with-vector (data buffer-bytes) - (flet ((parse-hex (char) - (second - (assoc char - '((#\0 0) (#\1 1) (#\2 2) (#\3 3) - (#\4 4) (#\5 5) (#\6 6) (#\7 7) - (#\8 8) (#\9 9) (#\a 10) (#\b 11) - (#\c 12) (#\d 13) (#\e 14) (#\f 15)) - :test #'char-equal)))) - (declare (inline parse-hex)) - ;; Read data - ;; Note: using read-line instead of read-char would be 20% faster, - ;; but would cons a lot of garbage... - (dotimes (i height) - (dotimes (j bytes-per-line) - (loop (when (eql (read-char fstream) #\x) (return))) - (setf (aref data (index+ line-base byte)) - (index+ (index-ash (parse-hex (read-char fstream)) 4) - (parse-hex (read-char fstream)))) - (incf byte)) - (setq byte 0 - line-base (index+ line-base padded-bytes-per-line))))) - ;; Compensate for left-pad in width and x-hot - (index-decf width left-pad) - (when (and (getf properties :x-hot) (plusp (getf properties :x-hot))) - (index-decf (getf properties :x-hot) left-pad)) - (create-image - :width width :height height - :depth depth :bits-per-pixel bits-per-pixel - :data data :plist properties :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit 32 :pad 32 :left-pad left-pad - :byte-lsb-first-p t :bit-lsb-first-p t)))))) - -(defun write-bitmap-file (pathname image &optional name) - ;; Writes an image to a C include file in standard X11 format - ;; NAME argument used for variable prefixes. Defaults to "image" - (declare (type (or pathname string stream) pathname) - (type image image) - (type (or null stringable) name)) - (unless (typep image 'image-x) - (setq image (copy-image image :result-type 'image-x))) - (let* ((plist (image-plist image)) - (name (or name (image-name image) 'image)) - (left-pad (image-x-left-pad image)) - (width (index+ (image-width image) left-pad)) - (height (image-height image)) - (depth - (if (eq (image-x-format image) :z-pixmap) - (image-depth image) - 1)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (last (index* bytes-per-line height)) - (count 0)) - (declare (type list plist) - (type stringable name) - (type card8 left-pad) - (type card16 width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type image-depth depth) - (type array-index bits-per-line bytes-per-line count last)) - ;; Move x-hot by left-pad, if there is an x-hot, so image readers that - ;; don't know about left pad get the hot spot in the right place. We have - ;; already increased width by left-pad. - (when (getf plist :x-hot) - (setq plist (copy-list plist)) - (index-incf (getf plist :x-hot) left-pad)) - (with-image-data-buffer (data last) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) 32 t t) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) (image-x-data image) - data 0 0 bytes-per-line (image-x-bytes-per-line image) - bytes-per-line height image-swap-lsb-first-p)) - (with-vector (data buffer-bytes) - (setq name (string-downcase (string name))) - (with-open-file (fstream pathname :direction :output) - (format fstream "#define ~a_width ~d~%" name width) - (format fstream "#define ~a_height ~d~%" name height) - (unless (= depth 1) - (format fstream "#define ~a_depth ~d~%" name depth)) - (unless (zerop left-pad) - (format fstream "#define ~a_left_pad ~d~%" name left-pad)) - (do ((prop plist (cddr prop))) - ((endp prop)) - (when (and (not (member (car prop) '(:width :height))) - (numberp (cadr prop))) - (format fstream "#define ~a_~a ~d~%" - name - (substitute - #\_ #\- (string-downcase (string (car prop))) - :test #'char=) - (cadr prop)))) - (format fstream "static char ~a_bits[] = {" name) - (dotimes (i height) - (dotimes (j bytes-per-line) - (when (zerop (index-mod count 15)) - (terpri fstream) - (write-char #\space fstream)) - (write-string "0x" fstream) - ;; Faster than (format fstream "0x~2,'0x," byte) - (let ((byte (aref data count)) - (translate "0123456789abcdef")) - (declare (type card8 byte)) - (write-char (char translate (ldb (byte 4 4) byte)) fstream) - (write-char (char translate (ldb (byte 4 0) byte)) fstream)) - (index-incf count) - (unless (index= count last) - (write-char #\, fstream)))) - (format fstream "};~%")))))) - -(defun bitmap-image (&optional plist &rest patterns) - ;; Create an image containg pattern - ;; PATTERNS are bit-vector constants (e.g. #*10101) - ;; If the first parameter is a list, its used as the image property-list. - (declare (type (or list bit-vector) plist) - (type list patterns)) ;; list of bitvector - (declare (clx-values image)) - (unless (listp plist) - (push plist patterns) - (setq plist nil)) - (let* ((width (length (first patterns))) - (height (length patterns)) - (bitarray (make-array (list height width) :element-type 'bit)) - (row 0)) - (declare (type card16 width height row) - (type pixarray-1 bitarray)) - (dolist (pattern patterns) - (declare (type simple-bit-vector pattern)) - (dotimes (col width) - (declare (type card16 col)) - (setf (aref bitarray row col) (the bit (aref pattern col)))) - (incf row)) - (create-image :width width :height height :plist plist :data bitarray))) - -(defun image-pixmap (drawable image &key gcontext width height depth) - ;; Create a pixmap containing IMAGE. Size defaults from the image. - ;; DEPTH is the pixmap depth. - ;; GCONTEXT is used for putting the image into the pixmap. - ;; If none is supplied, then one is created, used then freed. - (declare (type drawable drawable) - (type image image) - (type (or null gcontext) gcontext) - (type (or null card16) width height) - (type (or null card8) depth)) - (declare (clx-values pixmap)) - (let* ((image-width (image-width image)) - (image-height (image-height image)) - (image-depth (image-depth image)) - (width (or width image-width)) - (height (or height image-height)) - (depth (or depth image-depth)) - (pixmap (create-pixmap :drawable drawable - :width width - :height height - :depth depth)) - (gc (or gcontext (create-gcontext - :drawable pixmap - :foreground 1 - :background 0)))) - (unless (= depth image-depth) - (if (= image-depth 1) - (unless gcontext (xlib::required-arg gcontext)) - (error "Pixmap depth ~d incompatible with image depth ~d" - depth image-depth))) - (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) - gcontext)) - ;; Tile when image-width is less than the pixmap width, or - ;; the image-height is less than the pixmap height. - ;; ??? Would it be better to create a temporary pixmap and - ;; ??? let the server do the tileing? - (do ((x image-width (+ x image-width))) - ((>= x width)) - (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) - (incf image-width image-width)) - (do ((y image-height (+ y image-height))) - ((>= y height)) - (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) - (incf image-height image-height)) - (unless gcontext (free-gcontext gc)) - pixmap)) - diff --git a/src/clx/input.lisp b/src/clx/input.lisp deleted file mode 100644 index 33807bce8..000000000 --- a/src/clx/input.lisp +++ /dev/null @@ -1,1897 +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. -;;; - -;;; -;;; Change history: -;;; -;;; Date Author Description -;;; ------------------------------------------------------------------------------------- -;;; 12/10/87 LGO Created - -(in-package :xlib) - -;; Event Resource -(defvar *event-free-list* nil) ;; List of unused (processed) events - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Maximum number of events supported (the X11 alpha release only has 34) - (defconstant +max-events+ 64) - (defvar *event-key-vector* (make-array +max-events+ :initial-element nil) - "Vector of event keys - See define-event")) - -(defvar *event-macro-vector* (make-array +max-events+ :initial-element nil) - "Vector of event handler functions - See declare-event") -(defvar *event-handler-vector* (make-array +max-events+ :initial-element nil) - "Vector of event handler functions - See declare-event") -(defvar *event-send-vector* (make-array +max-events+ :initial-element nil) - "Vector of event sending functions - See declare-event") - -(defun allocate-event () - (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer) - (make-reply-buffer +replysize+))) - -(defun deallocate-event (reply-buffer) - (declare (type reply-buffer reply-buffer)) - (setf (reply-size reply-buffer) +replysize+) - (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) - -;; Extensions are handled as follows: -;; DEFINITION: Use DEFINE-EXTENSION -;; -;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. -;; This looks up the code on the display-extension-alist. -;; -;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE -;; at LOAD time to define an internal event-code number -;; (stored in the 'event-code property of the event-name) -;; used to index the following vectors: -;; *event-key-vector* Used for getting the event-key -;; *event-macro-vector* Used for getting the event-parameter getting macros -;; -;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert -;; a server event-code into an internal event-code used to index the following -;; vectors: -;; *event-handler-vector* Used for getting the event-handler function -;; *event-send-vector* Used for getting the event-sending function -;; -;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert -;; internal event-codes to external (server) codes. -;; -;; ERRORS: Use DEFINE-ERROR to define new error decodings. -;; - - -;; Any event-code greater than 34 is for an extension -(defparameter *first-extension-event-code* 35) - -(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors) - -(defmacro define-extension (name &key events errors) - ;; Define extension NAME with EVENTS and ERRORS. - ;; Note: The case of NAME is important. - ;; To define the request, Use: - ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) - ;; See the REQUESTS file for lots of examples. - ;; To define event handlers, use declare-event. - ;; To define error handlers, use declare-error and define-condition. - (declare (type stringable name) - (type list events errors)) - (let ((name-symbol (kintern name)) ;; Intern name in the keyword package - (event-list (mapcar #'canonicalize-event-name events))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) - (delete ',name-symbol *extensions* :key #'car)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun canonicalize-event-name (event) - ;; Returns the event name keyword given an event name stringable - (declare (type stringable event)) - (declare (clx-values event-key)) - (kintern event))) - -(defun extension-event-key-p (key) - (dolist (extension *extensions* nil) - (when (member key (second extension)) - (return t)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun allocate-extension-event-code (name) - ;; Allocate an event-code for an extension. This is executed at - ;; COMPILE and LOAD time from DECLARE-EVENT. The event-code is - ;; used at compile-time by macros to index the following vectors: - ;; *EVENT-KEY-VECTOR* *EVENT-MACRO-VECTOR* *EVENT-HANDLER-VECTOR* - ;; *EVENT-SEND-VECTOR* - (let ((event-code (get name 'event-code))) - (declare (type (or null card8) event-code)) - (unless event-code - ;; First ensure the name is for a declared extension - (unless (extension-event-key-p name) - (x-type-error name 'event-key)) - (setq event-code (position nil *event-key-vector* - :start *first-extension-event-code*)) - (setf (svref *event-key-vector* event-code) name) - (setf (get name 'event-code) event-code)) - event-code))) - -(defun get-internal-event-code (display code) - ;; Given an X11 event-code, return the internal event-code. - ;; The internal event-code is used for indexing into the following vectors: - ;; *event-key-vector* *event-handler-vector* *event-send-vector* - ;; Returns NIL when the event-code is for an extension that isn't handled. - (declare (type display display) - (type card8 code)) - (declare (clx-values (or null card8))) - (setq code (logand #x7f code)) - (if (< code *first-extension-event-code*) - code - (let* ((code-offset (- code *first-extension-event-code*)) - (event-extensions (display-event-extensions display)) - (code (if (< code-offset (length event-extensions)) - (aref event-extensions code-offset) - 0))) - (declare (type card8 code-offset code)) - (when (zerop code) - (x-cerror "Ignore the event" - 'unimplemented-event :event-code code :display display)) - code))) - -(defun get-external-event-code (display event) - ;; Given an X11 event name, return the event-code - (declare (type display display) - (type event-key event)) - (declare (clx-values card8)) - (let ((code (get-event-code event))) - (declare (type (or null card8) code)) - (when (>= code *first-extension-event-code*) - (setq code (+ *first-extension-event-code* - (or (position code (display-event-extensions display)) - (x-error 'undefined-event :display display :event-name event))))) - code)) - -(defmacro extension-opcode (display name) - ;; Returns the major opcode for extension NAME. - ;; This is a macro to enable NAME to be interned for fast run-time - ;; retrieval. - ;; Note: The case of NAME is important. - (let ((name-symbol (kintern name))) ;; Intern name in the keyword package - `(or (second (assoc ',name-symbol (display-extension-alist ,display))) - (x-error 'absent-extension :name ',name-symbol :display ,display)))) - -(defun initialize-extensions (display) - ;; Initialize extensions for DISPLAY - (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0)) - (extension-alist nil)) - (declare (type vector event-extensions) - (type list extension-alist)) - (dolist (extension *extensions*) - (let ((name (first extension)) - (events (second extension))) - (declare (type keyword name) - (type list events)) - (multiple-value-bind (major-opcode first-event first-error) - (query-extension display name) - (declare (type (or null card8) major-opcode first-event first-error)) - (when (and major-opcode (plusp major-opcode)) - (push (list name major-opcode first-event first-error) - extension-alist) - (when (plusp first-event) ;; When there are extension events - ;; Grow extension vector when needed - (let ((max-event (- (+ first-event (length events)) - *first-extension-event-code*))) - (declare (type card8 max-event)) - (when (>= max-event (length event-extensions)) - (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 - :initial-element 0))) - (declare (type vector new-extensions)) - (replace new-extensions event-extensions) - (setq event-extensions new-extensions)))) - (dolist (event events) - (declare (type symbol event)) - (setf (aref event-extensions (- first-event *first-extension-event-code*)) - (get-event-code event)) - (incf first-event))))))) - (setf (display-event-extensions display) event-extensions) - (setf (display-extension-alist display) extension-alist))) - -;; -;; Reply handlers -;; - -(defvar *pending-command-free-list* nil) - -(defun start-pending-command (display) - (declare (type display display)) - (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list* - pending-command-next pending-command) - (make-pending-command)))) - (declare (type pending-command pending-command)) - (setf (pending-command-reply-buffer pending-command) nil) - (setf (pending-command-process pending-command) (current-process)) - (setf (pending-command-sequence pending-command) - (ldb (byte 16 0) (1+ (buffer-request-number display)))) - ;; Add the pending command to the end of the threaded list of pending - ;; commands for the display. - (with-event-queue-internal (display) - (threaded-nconc pending-command (display-pending-commands display) - pending-command-next pending-command)) - pending-command)) - -(defun stop-pending-command (display pending-command) - (declare (type display display) - (type pending-command pending-command)) - (with-event-queue-internal (display) - ;; Remove the pending command from the threaded list of pending commands - ;; for the display. - (threaded-delete pending-command (display-pending-commands display) - pending-command-next pending-command) - ;; Deallocate any reply buffers in this pending command - (loop - (let ((reply-buffer - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-reply-buffer reply-buffer) - (return nil))))) - ;; Clear pointers to help the Garbage Collector - (setf (pending-command-process pending-command) nil) - ;; Deallocate this pending-command - (threaded-atomic-push pending-command *pending-command-free-list* - pending-command-next pending-command) - nil) - -;;; - -(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil)) - -(defun allocate-reply-buffer (size) - (declare (type array-index size)) - (if (index<= size +replysize+) - (allocate-event) - (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index) - reply-next reply-buffer) - (make-reply-buffer (index-ash 1 index)))))) - -(defun deallocate-reply-buffer (reply-buffer) - (declare (type reply-buffer reply-buffer)) - (let ((size (reply-size reply-buffer))) - (declare (type array-index size)) - (if (index<= size +replysize+) - (deallocate-event reply-buffer) - (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) - reply-next reply-buffer))))) - -;;; - -(defun read-error-input (display sequence reply-buffer token) - (declare (type display display) - (type reply-buffer reply-buffer) - (type card16 sequence)) - (tagbody - start - (with-event-queue-internal (display) - (let ((command - ;; Find any pending command with this sequence number. - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (cond ((not (null command)) - ;; Give this reply to the pending command - (threaded-nconc reply-buffer (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))) - ((member :immediately (display-report-asynchronous-errors display)) - ;; No pending command and we should report the error immediately - (go report-error)) - (t - ;; No pending command found, count this as an asynchronous error - (threaded-nconc reply-buffer (display-asynchronous-errors display) - reply-next reply-buffer))))) - (return-from read-error-input nil) - report-error - (note-input-complete display token) - (apply #'report-error display - (prog1 (make-error display reply-buffer t) - (deallocate-event reply-buffer))))) - -(defun read-reply-input (display sequence length reply-buffer) - (declare (type display display) - (type (or null reply-buffer) reply-buffer) - (type card16 sequence) - (type array-index length)) - (unwind-protect - (progn - (when (index< +replysize+ length) - (let ((repbuf nil)) - (declare (type (or null reply-buffer) repbuf)) - (unwind-protect - (progn - (setq repbuf (allocate-reply-buffer length)) - (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) - 0 +replysize+) - (deallocate-event (shiftf reply-buffer repbuf nil))) - (when repbuf - (deallocate-reply-buffer repbuf)))) - (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length) - (return-from read-reply-input t)) - (setf (reply-data-size reply-buffer) length)) - (with-event-queue-internal (display) - ;; Find any pending command with this sequence number. - (let ((command - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (when command - ;; Give this reply to the pending command - (threaded-nconc (shiftf reply-buffer nil) - (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))))) - nil) - (when reply-buffer - (deallocate-reply-buffer reply-buffer)))) - -(defun read-event-input (display code reply-buffer) - (declare (type display display) - (type card8 code) - (type reply-buffer reply-buffer)) - ;; Push the event in the input buffer on the display's event queue - (setf (event-code reply-buffer) - (get-internal-event-code display code)) - (enqueue-event reply-buffer display) - nil) - -(defun note-input-complete (display token) - (declare (type display display)) - (when (eq (display-input-in-progress display) token) - ;; Indicate that input is no longer in progress - (setf (display-input-in-progress display) nil) - ;; Let the event process get the first chance to do input - (let ((process (display-event-process display))) - (when (not (null process)) - (process-wakeup process))) - ;; Then give processes waiting for command responses a chance - (unless (display-input-in-progress display) - (with-event-queue-internal (display) - (threaded-dolist (command (display-pending-commands display) - pending-command-next pending-command) - (process-wakeup (pending-command-process command))))))) - -(defun read-input (display timeout force-output-p predicate &rest predicate-args) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p) - (dynamic-extent predicate-args)) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) - (let ((reply-buffer nil) - (token (or (current-process) (cons nil nil)))) - (declare (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (tagbody - loop - (when (display-dead display) - (x-error 'closed-display :display display)) - (when (apply predicate predicate-args) - (return-from read-input nil)) - ;; Check and see if we have to force output - (when (and force-output-p - (or (and (not (eq (display-input-in-progress display) token)) - (not (conditional-store - (display-input-in-progress display) nil token))) - (null (buffer-listen display)))) - (go force-output)) - ;; Ensure that only one process is reading input. - (unless (or (eq (display-input-in-progress display) token) - (conditional-store (display-input-in-progress display) nil token)) - (if (eql timeout 0) - (return-from read-input :timeout) - (apply #'process-block "CLX Input Lock" - #'(lambda (display predicate &rest predicate-args) - (declare (type display display) - (dynamic-extent predicate-args) - (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) - (or (apply predicate predicate-args) - (null (display-input-in-progress display)) - (not (null (display-dead display))))) - display predicate predicate-args)) - (go loop)) - ;; Now start gobbling. - (setq reply-buffer (allocate-event)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (let ((type 0)) - (declare (type card8 type)) - ;; Wait for input before we disallow aborts. - (unless (eql timeout 0) - (let ((eof-p (buffer-input-wait display timeout))) - (when eof-p (return-from read-input eof-p)))) - (without-aborts - (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+ - (if force-output-p 0 timeout)))) - (when eof-p - (when (eq eof-p :timeout) - (if force-output-p - (go force-output) - (return-from read-input :timeout))) - (setf (display-dead display) t) - (return-from read-input eof-p))) - (setf (reply-data-size reply-buffer) +replysize+) - (when (= (the card8 (setq type (read-card8 0))) 1) - ;; Normal replies can be longer than +replysize+, so we - ;; have to handle them while aborts are still disallowed. - (let ((value - (read-reply-input - display (read-card16 2) - (index+ +replysize+ (index* (read-card32 4) 4)) - (shiftf reply-buffer nil)))) - (when value - (return-from read-input value)) - (go loop)))) - (if (zerop type) - (read-error-input - display (read-card16 2) (shiftf reply-buffer nil) token) - (read-event-input - display (read-card8 0) (shiftf reply-buffer nil))))) - (go loop) - force-output - (note-input-complete display token) - (display-force-output display) - (setq force-output-p nil) - (go loop)) - (when (not (null reply-buffer)) - (deallocate-reply-buffer reply-buffer)) - (note-input-complete display token)))) - -(defun report-asynchronous-errors (display mode) - (when (and (display-asynchronous-errors display) - (member mode (display-report-asynchronous-errors display))) - (let ((aborted t)) - (unwind-protect - (loop - (let ((error - (with-event-queue-internal (display) - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer)))) - (declare (type (or null reply-buffer) error)) - (if error - (apply #'report-error display - (prog1 (make-error display error t) - (deallocate-event error))) - (return (setq aborted nil))))) - ;; If we get aborted out of this, deallocate all outstanding asynchronous - ;; errors. - (when aborted - (with-event-queue-internal (display) - (loop - (let ((reply-buffer - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-event reply-buffer) - (return nil)))))))))) - -(defun wait-for-event (display timeout force-output-p) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p)) - (let ((event-process-p (not (eql timeout 0)))) - (declare (type generalized-boolean event-process-p)) - (unwind-protect - (loop - (when event-process-p - (conditional-store (display-event-process display) nil (current-process))) - (let ((eof (read-input - display timeout force-output-p - #'(lambda (display) - (declare (type display display)) - (or (not (null (display-new-events display))) - (and (display-asynchronous-errors display) - (member :before-event-handling - (display-report-asynchronous-errors display)) - t))) - display))) - (when eof (return eof))) - ;; Report asynchronous errors here if the user wants us to. - (when event-process-p - (report-asynchronous-errors display :before-event-handling)) - (when (not (null (display-new-events display))) - (return nil))) - (when (and event-process-p - (eq (display-event-process display) (current-process))) - (setf (display-event-process display) nil))))) - -(defun read-reply (display pending-command) - (declare (type display display) - (type pending-command pending-command)) - (loop - (when (read-input display nil nil - #'(lambda (pending-command) - (declare (type pending-command pending-command)) - (not (null (pending-command-reply-buffer pending-command)))) - pending-command) - (x-error 'closed-display :display display)) - (let ((reply-buffer - (with-event-queue-internal (display) - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer)))) - (declare (type reply-buffer reply-buffer)) - ;; Check for error. - (with-buffer-input (reply-buffer) - (ecase (read-card8 0) - (0 (apply #'report-error display - (prog1 (make-error display reply-buffer nil) - (deallocate-reply-buffer reply-buffer)))) - (1 (return reply-buffer))))))) - -;;; - -(defun event-listen (display &optional (timeout 0)) - (declare (type display display) - (type (or null number) timeout) - (clx-values number-of-events-queued eof-or-timeout)) - ;; Returns the number of events queued locally, if any, else nil. Hangs - ;; waiting for events, forever if timeout is nil, else for the specified - ;; number of seconds. - (let* ((current-event-symbol (car (display-current-event-symbol display))) - (current-event (and (boundp current-event-symbol) - (symbol-value current-event-symbol))) - (queue (if current-event - (reply-next (the reply-buffer current-event)) - (display-event-queue-head display)))) - (declare (type symbol current-event-symbol) - (type (or null reply-buffer) current-event queue)) - (if queue - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length queue reply-next reply-buffer)) - nil) - (with-event-queue (display :timeout timeout :inline t) - (let ((eof-or-timeout (wait-for-event display timeout nil))) - (if eof-or-timeout - (values nil eof-or-timeout) - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length (display-new-events display) - reply-next reply-buffer)) - nil))))))) - -(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys) - ;; The event is put at the head of the queue if append-p is nil, else the tail. - ;; Additional arguments depend on event-key, and are as specified above with - ;; declare-event, except that both resource-ids and resource objects are accepted - ;; in the event components. - (declare (type display display) - (type event-key event-key) - (type generalized-boolean append-p send-event-p) - (dynamic-extent args)) - (unless (get event-key 'event-code) - (x-type-error event-key 'event-key)) - (let* ((event (allocate-event)) - (buffer (reply-ibuf8 event)) - (event-code (get event-key 'event-code))) - (declare (type reply-buffer event) - (type buffer-bytes buffer) - (type (or null card8) event-code)) - (unless event-code (x-type-error event-key 'event-key)) - (setf (event-code event) event-code) - (with-display (display) - (apply (svref *event-send-vector* event-code) display args) - (buffer-replace buffer - (display-obuf8 display) - 0 - +replysize+ - (index+ 12 (buffer-boffset display))) - (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) - (aref buffer 2) 0 - (aref buffer 3) 0)) - (with-event-queue (display) - (if append-p - (enqueue-event event display) - (with-event-queue-internal (display) - (threaded-requeue event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)))))) - -(defun enqueue-event (new-event display) - (declare (type reply-buffer new-event) - (type display display)) - ;; Place EVENT at the end of the event queue for DISPLAY - (let* ((event-code (event-code new-event)) - (event-key (and (index< event-code (length *event-key-vector*)) - (svref *event-key-vector* event-code)))) - (declare (type array-index event-code) - (type (or null keyword) event-key)) - (if (null event-key) - (unwind-protect - (cerror "Ignore this event" "No handler for ~s event" event-key) - (deallocate-event new-event)) - (with-event-queue-internal (display) - (threaded-enqueue new-event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer) - (unless (display-new-events display) - (setf (display-new-events display) new-event)))))) - - -(defmacro define-event (name code) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setf (svref *event-key-vector* ,code) ',name) - (setf (get ',name 'event-code) ,code))) - -;; Event names. Used in "type" field in XEvent structures. Not to be -;; confused with event masks above. They start from 2 because 0 and 1 -;; are reserved in the protocol for errors and replies. */ - -(define-event :key-press 2) -(define-event :key-release 3) -(define-event :button-press 4) -(define-event :button-release 5) -(define-event :motion-notify 6) -(define-event :enter-notify 7) -(define-event :leave-notify 8) -(define-event :focus-in 9) -(define-event :focus-out 10) -(define-event :keymap-notify 11) -(define-event :exposure 12) -(define-event :graphics-exposure 13) -(define-event :no-exposure 14) -(define-event :visibility-notify 15) -(define-event :create-notify 16) -(define-event :destroy-notify 17) -(define-event :unmap-notify 18) -(define-event :map-notify 19) -(define-event :map-request 20) -(define-event :reparent-notify 21) -(define-event :configure-notify 22) -(define-event :configure-request 23) -(define-event :gravity-notify 24) -(define-event :resize-request 25) -(define-event :circulate-notify 26) -(define-event :circulate-request 27) -(define-event :property-notify 28) -(define-event :selection-clear 29) -(define-event :selection-request 30) -(define-event :selection-notify 31) -(define-event :colormap-notify 32) -(define-event :client-message 33) -(define-event :mapping-notify 34) - - -(defmacro declare-event (event-codes &body declares &environment env) - ;; Used to indicate the keyword arguments for handler functions in - ;; process-event and event-case. - ;; Generates the functions used in SEND-EVENT. - ;; A compiler warning is printed when all of EVENT-CODES are not - ;; defined by a preceding DEFINE-EXTENSION. - ;; The body is a list of declarations, each of which has the form: - ;; (type . items) Where type is a data-type, and items is a list of - ;; symbol names. The item order corresponds to the order of fields - ;; in the event sent by the server. An item may be a list of items. - ;; In this case, each item is aliased to the same event field. - ;; This is used to give all events an EVENT-WINDOW item. - ;; See the INPUT file for lots of examples. - (declare (type (or keyword list) event-codes) - (type (alist (field-type symbol) (field-names list)) - declares)) - (when (atom event-codes) (setq event-codes (list event-codes))) - (setq event-codes (mapcar #'canonicalize-event-name event-codes)) - (let* ((keywords nil) - (name (first event-codes)) - (get-macro (xintern name '-event-get-macro)) - (get-function (xintern name '-event-get)) - (put-function (xintern name '-event-put))) - (multiple-value-bind (get-code get-index get-sizes) - (get-put-items - 2 declares nil - #'(lambda (type index item args) - (flet ((event-get (type index item args) - (unless (member type '(pad8 pad16)) - `(,(kintern item) - (,(getify type) ,index ,@args))))) - (if (atom item) - (event-get type index item args) - (mapcan #'(lambda (item) - (event-get type index item args)) - item))))) - (declare (ignore get-index)) - (multiple-value-bind (put-code put-index put-sizes) - (get-put-items - 2 declares t - #'(lambda (type index item args) - (unless (member type '(pad8 pad16)) - (if (atom item) - (progn - (push item keywords) - `((,(putify type) ,index ,item ,@args))) - (let ((names (mapcar #'(lambda (name) (kintern name)) - item))) - (setq keywords (append item keywords)) - `((,(putify type) ,index - (check-consistency ',names ,@item) ,@args))))))) - (declare (ignore put-index)) - `(within-definition (,name declare-event) - (defun ,get-macro (display event-key variable) - ;; Note: we take pains to macroexpand the get-code here to enable application - ;; code to be compiled without having the CLX macros file loaded. - `(let ((%buffer ,display)) - (declare (ignorable %buffer)) - ,(getf `(:display (the display ,display) - :event-key (the keyword ,event-key) - :event-code (the card8 (logand #x7f (read-card8 0))) - :send-event-p (logbitp 7 (read-card8 0)) - ,@',(mapcar #'(lambda (form) - (clx-macroexpand form env)) - get-code)) - variable))) - - (defun ,get-function (display event handler) - (declare (type display display) - (type reply-buffer event)) - (declare (type function handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg handler)) - (reading-event (event :display display :sizes (8 16 ,@get-sizes)) - (funcall handler - :display display - :event-key (svref *event-key-vector* (event-code event)) - :event-code (logand #x7f (card8-get 0)) - :send-event-p (logbitp 7 (card8-get 0)) - ,@get-code))) - - (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) - &allow-other-keys) - (declare (type display display)) - ,(when (member 'sequence keywords) - `(unless sequence (setq sequence (display-request-number display)))) - (with-buffer-output (display :sizes ,put-sizes - :index (index+ (buffer-boffset display) 12)) - ,@put-code)) - - ,@(mapcar #'(lambda (name) - (allocate-extension-event-code name) - `(let ((event-code (or (get ',name 'event-code) - (allocate-extension-event-code ',name)))) - (setf (svref *event-macro-vector* event-code) - (function ,get-macro)) - (setf (svref *event-handler-vector* event-code) - (function ,get-function)) - (setf (svref *event-send-vector* event-code) - (function ,put-function)))) - event-codes) - ',name))))) - -(defun check-consistency (names &rest args) - ;; Ensure all args are nil or have the same value. - ;; Returns the consistent non-nil value. - (let ((value (car args))) - (dolist (arg (cdr args)) - (if value - (when (and arg (not (eq arg value))) - (x-error 'inconsistent-parameters - :parameters (mapcan #'list names args))) - (setq value arg))) - value)) - -(declare-event (:key-press :key-release :button-press :button-release) - ;; for key-press and key-release, code is the keycode - ;; for button-press and button-release, code is the button number - (data code) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - (boolean same-screen-p) - ) - -(declare-event :motion-notify - ((data boolean) hint-p) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - (boolean same-screen-p)) - -(declare-event (:enter-notify :leave-notify) - ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - ((member8 :normal :grab :ungrab) mode) - ((bit 0) focus-p) - ((bit 1) same-screen-p)) - -(declare-event (:focus-in :focus-out) - ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual - :pointer :pointer-root :none)) - kind) - (card16 sequence) - (window (window event-window)) - ((member8 :normal :while-grabbed :grab :ungrab) mode)) - -(declare-event :keymap-notify - ((bit-vector256 0) keymap)) - -(declare-event :exposure - (card16 sequence) - (window (window event-window)) - (card16 x y width height count)) - -(declare-event :graphics-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 x y width height) - (card16 minor) ;; Minor opcode - (card16 count) - (card8 major)) - -(declare-event :no-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 minor) - (card8 major)) - -(declare-event :visibility-notify - (card16 sequence) - (window (window event-window)) - ((member8 :unobscured :partially-obscured :fully-obscured) state)) - -(declare-event :create-notify - (card16 sequence) - (window (parent event-window) window) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :destroy-notify - (card16 sequence) - (window event-window window)) - -(declare-event :unmap-notify - (card16 sequence) - (window event-window window) - (boolean configure-p)) - -(declare-event :map-notify - (card16 sequence) - (window event-window window) - (boolean override-redirect-p)) - -(declare-event :map-request - (card16 sequence) - (window (parent event-window) window)) - -(declare-event :reparent-notify - (card16 sequence) - (window event-window window parent) - (int16 x y) - (boolean override-redirect-p)) - -(declare-event :configure-notify - (card16 sequence) - (window event-window window) - ((or null window) above-sibling) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :configure-request - ((data (member8 :above :below :top-if :bottom-if :opposite)) stack-mode) - (card16 sequence) - (window (parent event-window) window) - ((or null window) above-sibling) - (int16 x y) - (card16 width height border-width value-mask)) - -(declare-event :gravity-notify - (card16 sequence) - (window event-window window) - (int16 x y)) - -(declare-event :resize-request - (card16 sequence) - (window (window event-window)) - (card16 width height)) - -(declare-event :circulate-notify - (card16 sequence) - (window event-window window parent) - ((member8 :top :bottom) place)) - -(declare-event :circulate-request - (card16 sequence) - (window (parent event-window) window) - (pad16 1 2) - ((member8 :top :bottom) place)) - -(declare-event :property-notify - (card16 sequence) - (window (window event-window)) - (keyword atom) ;; keyword - ((or null card32) time) - ((member8 :new-value :deleted) state)) - -(declare-event :selection-clear - (card16 sequence) - ((or null card32) time) - (window (window event-window)) - (keyword selection) ;; keyword - ) - -(declare-event :selection-request - (card16 sequence) - ((or null card32) time) - (window (window event-window) requestor) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :selection-notify - (card16 sequence) - ((or null card32) time) - (window (window event-window)) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :colormap-notify - (card16 sequence) - (window (window event-window)) - ((or null colormap) colormap) - (boolean new-p installed-p)) - -(declare-event :client-message - (data format) - (card16 sequence) - (window (window event-window)) - (keyword type) - ((client-message-sequence format) data)) - -(declare-event :mapping-notify - (card16 sequence) - ((member8 :modifier :keyboard :pointer) request) - (card8 start) ;; first key-code - (card8 count)) - - -;; -;; EVENT-LOOP -;; - -(defun event-loop-setup (display) - (declare (type display display) - (clx-values progv-vars progv-vals - current-event-symbol current-event-discarded-p-symbol)) - (let* ((progv-vars (display-current-event-symbol display)) - (current-event-symbol (first progv-vars)) - (current-event-discarded-p-symbol (second progv-vars))) - (declare (type list progv-vars) - (type symbol current-event-symbol current-event-discarded-p-symbol)) - (values - progv-vars - (list (if (boundp current-event-symbol) - ;; The current event is already bound, so bind it to the next - ;; event. - (let ((event (symbol-value current-event-symbol))) - (declare (type (or null reply-buffer) event)) - (and event (reply-next (the reply-buffer event)))) - ;; The current event isn't bound, so bind it to the head of the - ;; event queue. - (display-event-queue-head display)) - nil) - current-event-symbol - current-event-discarded-p-symbol))) - -(defun event-loop-step-before (display timeout force-output-p current-event-symbol) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p) - (type symbol current-event-symbol) - (clx-values event eof-or-timeout)) - (unless (symbol-value current-event-symbol) - (let ((eof-or-timeout (wait-for-event display timeout force-output-p))) - (when eof-or-timeout - (return-from event-loop-step-before (values nil eof-or-timeout)))) - (setf (symbol-value current-event-symbol) (display-new-events display))) - (let ((event (symbol-value current-event-symbol))) - (declare (type reply-buffer event)) - (with-event-queue-internal (display) - (when (eq event (display-new-events display)) - (setf (display-new-events display) (reply-next event)))) - (values event nil))) - -(defun dequeue-event (display event) - (declare (type display display) - (type reply-buffer event) - (clx-values next)) - ;; Remove the current event from the event queue - (with-event-queue-internal (display) - (let ((next (reply-next event)) - (head (display-event-queue-head display))) - (declare (type (or null reply-buffer) next head)) - (when (eq event (display-new-events display)) - (setf (display-new-events display) next)) - (cond ((eq event head) - (threaded-dequeue (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)) - ((null head) - (setq next nil)) - (t - (do* ((previous head current) - (current (reply-next previous) (reply-next previous))) - ((or (null current) (eq event current)) - (when (eq event current) - (when (eq current (display-event-queue-tail display)) - (setf (display-event-queue-tail display) previous)) - (setf (reply-next previous) next))) - (declare (type reply-buffer previous) - (type (or null reply-buffer) current))))) - next))) - -(defun event-loop-step-after - (display event discard-p current-event-symbol current-event-discarded-p-symbol - &optional aborted) - (declare (type display display) - (type reply-buffer event) - (type generalized-boolean discard-p aborted) - (type symbol current-event-symbol current-event-discarded-p-symbol)) - (when (and discard-p - (not aborted) - (not (symbol-value current-event-discarded-p-symbol))) - (discard-current-event display)) - (let ((next (reply-next event))) - (declare (type (or null reply-buffer) next)) - (when (symbol-value current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) nil) - (setq next (dequeue-event display event)) - (deallocate-event event)) - (setf (symbol-value current-event-symbol) next))) - -(defmacro event-loop ((display event timeout force-output-p discard-p) &body body) - ;; Bind EVENT to the events for DISPLAY. - ;; This is the "GUTS" of process-event and event-case. - `(let ((.display. ,display) - (.timeout. ,timeout) - (.force-output-p. ,force-output-p) - (.discard-p. ,discard-p)) - (declare (type display .display.) - (type (or null number) .timeout.) - (type generalized-boolean .force-output-p. .discard-p.)) - (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.))) - (multiple-value-bind (.progv-vars. .progv-vals. - .current-event-symbol. .current-event-discarded-p-symbol.) - (event-loop-setup .display.) - (declare (type list .progv-vars. .progv-vals.) - (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) - (progv .progv-vars. .progv-vals. - (loop - (multiple-value-bind (.event. .eof-or-timeout.) - (event-loop-step-before - .display. .timeout. .force-output-p. - .current-event-symbol.) - (declare (type (or null reply-buffer) .event.)) - (when (null .event.) (return (values nil .eof-or-timeout.))) - (let ((.aborted. t)) - (unwind-protect - (progn - (let ((,event .event.)) - (declare (type reply-buffer ,event)) - ,@body) - (setq .aborted. nil)) - (event-loop-step-after - .display. .event. .discard-p. - .current-event-symbol. .current-event-discarded-p-symbol. - .aborted.)))))))))) - -(defun discard-current-event (display) - ;; Discard the current event for DISPLAY. - ;; Returns NIL when the event queue is empty, else T. - ;; To ensure events aren't ignored, application code should only call - ;; this when throwing out of event-case or process-next-event, or from - ;; inside even-case, event-cond or process-event when :peek-p is T and - ;; :discard-p is NIL. - (declare (type display display) - (clx-values generalized-boolean)) - (let* ((symbols (display-current-event-symbol display)) - (event - (let ((current-event-symbol (first symbols))) - (declare (type symbol current-event-symbol)) - (when (boundp current-event-symbol) - (symbol-value current-event-symbol))))) - (declare (type list symbols) - (type (or null reply-buffer) event)) - (unless (null event) - ;; Set the discarded-p flag - (let ((current-event-discarded-p-symbol (second symbols))) - (declare (type symbol current-event-discarded-p-symbol)) - (when (boundp current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) t))) - ;; Return whether the event queue is empty - (not (null (reply-next (the reply-buffer event))))))) - -;; -;; PROCESS-EVENT -;; -(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) - ;; If force-output-p is true, first invokes display-force-output. Invokes handler - ;; on each queued event until handler returns non-nil, and that returned object is - ;; then returned by process-event. If peek-p is true, then the event is not - ;; removed from the queue. If discard-p is true, then events for which handler - ;; returns nil are removed from the queue, otherwise they are left in place. Hangs - ;; until non-nil is generated for some event, or for the specified timeout (in - ;; seconds, if given); however, it is acceptable for an implementation to wait only - ;; once on network data, and therefore timeout prematurely. Returns nil on - ;; timeout. If handler is a sequence, it is expected to contain handler functions - ;; specific to each event class; the event code is used to index the sequence, - ;; fetching the appropriate handler. Handler is called with raw resource-ids, not - ;; with resource objects. The arguments to the handler are described using declare-event. - ;; - ;; T for peek-p means the event (for which the handler returns non-nil) is not removed - ;; from the queue (it is left in place), NIL means the event is removed. - - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean peek-p discard-p force-output-p)) - (declare (type t handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera handler)) - (event-loop (display event timeout force-output-p discard-p) - (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT - (event-decoder (and (index< event-code (length *event-handler-vector*)) - (svref *event-handler-vector* event-code)))) - (declare (type array-index event-code) - (type (or null function) event-decoder)) - (if event-decoder - (let ((event-handler (if (functionp handler) - handler - (and (type? handler 'sequence) - (< event-code (length handler)) - (elt handler event-code))))) - (if event-handler - (let ((result (funcall event-decoder display event event-handler))) - (when result - (unless peek-p - (discard-current-event display)) - (return result))) - (cerror "Ignore this event" - "No handler for ~s event" - (svref *event-key-vector* event-code)))) - (cerror "Ignore this event" - "Server Error: event with unknown event code ~d received." - event-code))))) - -(defun make-event-handlers (&key (type 'array) default) - (declare (type t type) ;Sequence type specifier - (type (or null function) default) - (clx-values sequence)) ;Default handler for initial content - ;; Makes a handler sequence suitable for process-event - (make-sequence type +max-events+ :initial-element default)) - -(defun event-handler (handlers event-key) - (declare (type sequence handlers) - (type event-key event-key) - (clx-values function)) - ;; Accessor for a handler sequence - (elt handlers (position event-key *event-key-vector* :test #'eq))) - -(defun set-event-handler (handlers event-key handler) - (declare (type sequence handlers) - (type event-key event-key) - (type function handler) - (clx-values handler)) - (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler)) - -(defsetf event-handler set-event-handler) - -;; -;; EVENT-CASE -;; - -(defmacro event-case ((&rest args) &body clauses) - ;; If force-output-p is true, first invokes display-force-output. Executes the - ;; matching clause for each queued event until a clause returns non-nil, and that - ;; returned object is then returned by event-case. If peek-p is true, then the - ;; event is not removed from the queue. If discard-p is true, then events for - ;; which the clause returns nil are removed from the queue, otherwise they are left - ;; in place. Hangs until non-nil is generated for some event, or for the specified - ;; timeout (in seconds, if given); however, it is acceptable for an implementation - ;; to wait only once on network data, and therefore timeout prematurely. Returns - ;; nil on timeout. In each clause, event-or-events is an event-key or a list of - ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise - ;; (but only in the last clause). The keys are not evaluated, and it is an error - ;; for the same key to appear in more than one clause. Args is the list of event - ;; components of interest; corresponding values (if any) are bound to variables - ;; with these names (i.e., the args are variable names, not keywords, the keywords - ;; are derived from the variable names). An arg can also be a (keyword var) form, - ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is - ;; equivalent to having one that returns nil. - (declare (arglist (display &key timeout peek-p discard-p (force-output-p t)) - (event-or-events ((&rest args) |...|) &body body) |...|)) - ;; Event-case is just event-cond with the whole body in the test-form - `(event-cond ,args - ,@(mapcar - #'(lambda (clause) - `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) - clauses))) - -;; -;; EVENT-COND -;; - -(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) - ;; The clauses of event-cond are of the form: - ;; (event-or-events binding-list test-form . body-forms) - ;; - ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they - ;; need not be typed as keywords) or the symbol t - ;; or otherwise (but only in the last clause). If - ;; no t/otherwise clause appears, it is equivalent - ;; to having one that returns nil. The keys are - ;; not evaluated, and it is an error for the same - ;; key to appear in more than one clause. - ;; - ;; BINDING-LIST The list of event components of interest. - ;; corresponding values (if any) are bound to - ;; variables with these names (i.e., the binding-list - ;; has variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also - ;; be a (keyword var) form, as for keyword args in a - ;; lambda list. - ;; - ;; The matching TEST-FORM for each queued event is executed until a - ;; clause's test-form returns non-nil. Then the BODY-FORMS are - ;; evaluated, returning the (possibly multiple) values of the last - ;; form from event-cond. If there are no body-forms then, if the - ;; test-form is non-nil, the value of the test-form is returned as a - ;; single value. - ;; - ;; Options: - ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no - ;; input is pending. - ;; - ;; PEEK-P When true, then the event is not removed from the queue. - ;; - ;; DISCARD-P When true, then events for which the clause returns nil - ;; are removed from the queue, otherwise they are left in place. - ;; - ;; TIMEOUT If NIL, hang until non-nil is generated for some event's - ;; test-form. Otherwise return NIL after TIMEOUT seconds have - ;; elapsed. - ;; - (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events (&rest args) test-form &body body) |...|)) - (let ((event (gensym)) - (disp (gensym)) - (peek (gensym))) - `(let ((,disp ,display) - (,peek ,peek-p)) - (declare (type display ,disp)) - (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p) - (event-dispatch (,disp ,event ,peek) ,@clauses))))) - -(defun get-event-code (event) - ;; Returns the event code given an event-key - (declare (type event-key event)) - (declare (clx-values card8)) - (or (get event 'event-code) - (x-type-error event 'event-key))) - -(defun universal-event-get-macro (display event-key variable) - (getf - `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code - (the card8 (logand 127 (read-card8 0))) :send-event-p - (logbitp 7 (read-card8 0))) - variable)) - -(defmacro event-dispatch ((display event peek-p) &body clauses) - ;; Helper macro for event-case - ;; CLAUSES are of the form: - ;; (event-or-events binding-list test-form . body-forms) - (let ((event-key (gensym)) - (all-events (make-array +max-events+ :element-type 'bit :initial-element 0))) - `(reading-event (,event) - (let ((,event-key (svref *event-key-vector* (event-code ,event)))) - (case ,event-key - ,@(mapcar - #'(lambda (clause) ; Translate event-cond clause to case clause - (let* ((events (first clause)) - (arglist (second clause)) - (test-form (third clause)) - (body-forms (cdddr clause))) - (flet ((event-clause (display peek-p first-form rest-of-forms) - (if rest-of-forms - `(when ,first-form - (unless ,peek-p (discard-current-event ,display)) - (return (progn ,@rest-of-forms))) - ;; No body forms, return the result of the test form - (let ((result (gensym))) - `(let ((,result ,first-form)) - (when ,result - (unless ,peek-p (discard-current-event ,display)) - (return ,result))))))) - - (if (member events '(otherwise t)) - ;; code for OTHERWISE clause. - ;; Find all events NOT used by other clauses - (let ((keys (do ((i 0 (1+ i)) - (key nil) - (result nil)) - ((>= i +max-events+) result) - (setq key (svref *event-key-vector* i)) - (when (and key (zerop (aref all-events i))) - (push key result))))) - `(otherwise - (binding-event-values - (,display ,event-key ,(or keys :universal) ,@arglist) - ,(event-clause display peek-p test-form body-forms)))) - - ;; Code for normal clauses - (let (true-events) ;; canonicalize event-names - (if (consp events) - (progn - (setq true-events (mapcar #'canonicalize-event-name events)) - (dolist (event true-events) - (setf (aref all-events (get-event-code event)) 1))) - (setf true-events (canonicalize-event-name events) - (aref all-events (get-event-code true-events)) 1)) - `(,true-events - (binding-event-values - (,display ,event-key ,true-events ,@arglist) - ,(event-clause display peek-p test-form body-forms)))))))) - clauses)))))) - -(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body) - ;; Execute BODY with the variables in VALUE-LIST bound to components of the - ;; EVENT-KEYS events. - (unless (consp event-keys) (setq event-keys (list event-keys))) - (flet ((var-key (var) (kintern (if (consp var) (first var) var))) - (var-symbol (var) (if (consp var) (second var) var))) - ;; VARS is an alist of: - ;; (component-key ((event-key event-key ...) . extraction-code) - ;; ((event-key event-key ...) . extraction-code) ...) - ;; There should probably be accessor macros for this, instead of things like cdadr. - (let ((vars (mapcar #'list value-list)) - (multiple-p nil)) - ;; Fill in the VARS alist with event-keys and extraction-code - (do ((keys event-keys (cdr keys)) - (temp nil)) - ((endp keys)) - (let* ((key (car keys)) - (binder (case key - (:universal #'universal-event-get-macro) - (otherwise (svref *event-macro-vector* (get-event-code key)))))) - (dolist (var vars) - (let ((code (funcall binder display event-key (var-key (car var))))) - (unless code (warn "~a isn't a component of the ~s event" - (var-key (car var)) key)) - (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) - (push key (caar temp)) - (push `((,key) . ,code) (cdr var))))))) - ;; Bind all the values - `(let ,(mapcar #'(lambda (var) - (if (cddr var) ;; if more than one binding form - (progn (setq multiple-p t) - (var-symbol (car var))) - (list (var-symbol (car var)) (cdadr var)))) - vars) - ;; When some values come from different places, generate code to set them - ,(when multiple-p - `(case ,event-key - ,@(do ((keys event-keys (cdr keys)) - (clauses nil) ;; alist of (event-keys bindings) - (clause nil nil) - (temp)) - ((endp keys) - (dolist (clause clauses) - (unless (cdar clause) ;; Atomize single element lists - (setf (car clause) (caar clause)))) - clauses) - ;; Gather up all the bindings associated with (car keys) - (dolist (var vars) - (when (cddr var) ;; when more than one binding form - (dolist (events (cdr var)) - (when (member (car keys) (car events)) - ;; Optimize for event-window being the same as some other binding - (if (setq temp (member (cdr events) clause - :key #'caddr - :test #'equal)) - (setq clause - (nconc clause `((setq ,(car var) ,(second (car temp)))))) - (push `(setq ,(car var) ,(cdr events)) clause)))))) - ;; Merge bindings for (car keys) with other bindings - (when clause - (if (setq temp (member clause clauses :key #'cdr :test #'equal)) - (push (car keys) (caar temp)) - (push `((,(car keys)) . ,clause) clauses)))))) - ,@body)))) - - -;;;----------------------------------------------------------------------------- -;;; Error Handling -;;;----------------------------------------------------------------------------- - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defparameter - *xerror-vector* - '#(unknown-error - request-error ; 1 bad request code - value-error ; 2 integer parameter out of range - window-error ; 3 parameter not a Window - pixmap-error ; 4 parameter not a Pixmap - atom-error ; 5 parameter not an Atom - cursor-error ; 6 parameter not a Cursor - font-error ; 7 parameter not a Font - match-error ; 8 parameter mismatch - drawable-error ; 9 parameter not a Pixmap or Window - access-error ; 10 attempt to access private resource" - alloc-error ; 11 insufficient resources - colormap-error ; 12 no such colormap - gcontext-error ; 13 parameter not a GContext - id-choice-error ; 14 invalid resource ID for this connection - name-error ; 15 font or color name does not exist - length-error ; 16 request length incorrect; - ; internal Xlib error - implementation-error ; 17 server is defective - )) -) - -(defun make-error (display event asynchronous) - (declare (type display display) - (type reply-buffer event) - (type generalized-boolean asynchronous)) - (reading-event (event) - (let* ((error-code (read-card8 1)) - (error-key (get-error-key display error-code)) - (error-decode-function (get error-key 'error-decode-function)) - (params (funcall error-decode-function display event))) - (list* error-code error-key - :asynchronous asynchronous :current-sequence (display-request-number display) - params)))) - -(defun report-error (display error-code error-key &rest params) - (declare (type display display) - (dynamic-extent params)) - ;; All errors (synchronous and asynchronous) are processed by calling - ;; an error handler in the display. The handler is called with the display - ;; as the first argument and the error-key as its second argument. If handler is - ;; an array it is expected to contain handler functions specific to - ;; each error; the error code is used to index the array, 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, additional keyword/value argument - ;; pairs are: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; :asynchronous (member t nil) - ;; 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 - (let* ((handler (display-error-handler display)) - (handler-function - (if (type? handler 'sequence) - (elt handler error-code) - handler))) - (apply handler-function display error-key params))) - -(defun request-name (code &optional display) - (if (< code (length *request-names*)) - (svref *request-names* code) - (dolist (extension (and display (display-extension-alist display)) "unknown") - (when (= code (second extension)) - (return (first extension)))))) - -#-(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - ((display :reader request-error-display) - (error-key :reader request-error-error-key) - (major :reader request-error-major) - (minor :reader request-error-minor) - (sequence :reader request-error-sequence) - (current-sequence :reader request-error-current-sequence) - (asynchronous :reader request-error-asynchronous)) - (:report report-request-error)) - -(defun report-request-error (condition stream) - (let ((error-key (request-error-error-key condition)) - (asynchronous (request-error-asynchronous condition)) - (major (request-error-major condition)) - (minor (request-error-minor condition)) - (sequence (request-error-sequence condition)) - (current-sequence (request-error-current-sequence condition))) - (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]" - asynchronous error-key (= sequence current-sequence) - sequence current-sequence major minor - (request-name major (request-error-display condition))))) - -;; Since the :report arg is evaluated as (function report-request-error) the -;; define-condition must come after the function definition. -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - ((display :reader request-error-display :initarg :display) - (error-key :reader request-error-error-key :initarg :error-key) - (major :reader request-error-major :initarg :major) - (minor :reader request-error-minor :initarg :minor) - (sequence :reader request-error-sequence :initarg :sequence) - (current-sequence :reader request-error-current-sequence :initarg :current-sequence) - (asynchronous :reader request-error-asynchronous :initarg :asynchronous)) - (:report report-request-error)) - -(define-condition resource-error (request-error) - ((resource-id :reader resource-error-resource-id :initarg :resource-id)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " ID #x~x" (resource-error-resource-id condition))))) - -(define-condition unknown-error (request-error) - ((error-code :reader unknown-error-error-code :initarg :error-code)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Error Code ~d." (unknown-error-error-code condition))))) - -(define-condition access-error (request-error) ()) - -(define-condition alloc-error (request-error) ()) - -(define-condition atom-error (request-error) - ((atom-id :reader atom-error-atom-id :initarg :atom-id)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Atom-ID #x~x" (atom-error-atom-id condition))))) - -(define-condition colormap-error (resource-error) ()) - -(define-condition cursor-error (resource-error) ()) - -(define-condition drawable-error (resource-error) ()) - -(define-condition font-error (resource-error) ()) - -(define-condition gcontext-error (resource-error) ()) - -(define-condition id-choice-error (resource-error) ()) - -(define-condition illegal-request-error (request-error) ()) - -(define-condition length-error (request-error) ()) - -(define-condition match-error (request-error) ()) - -(define-condition name-error (request-error) ()) - -(define-condition pixmap-error (resource-error) ()) - -(define-condition value-error (request-error) - ((value :reader value-error-value :initarg :value)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Value ~d." (value-error-value condition))))) - -(define-condition window-error (resource-error)()) - -(define-condition implementation-error (request-error) ()) - -;;----------------------------------------------------------------------------- -;; Internal error conditions signaled by CLX - -(define-condition x-type-error (type-error x-error) - ((type-string :reader x-type-error-type-string :initarg :type-string)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (or (x-type-error-type-string condition) - (type-error-expected-type condition)))))) - -(define-condition closed-display (x-error) - ((display :reader closed-display-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Attempt to use closed display ~s" - (closed-display-display condition))))) - -(define-condition lookup-error (x-error) - ((id :reader lookup-error-id :initarg :id) - (display :reader lookup-error-display :initarg :display) - (type :reader lookup-error-type :initarg :type) - (object :reader lookup-error-object :initarg :object)) - (:report - (lambda (condition stream) - (format stream "ID ~d from display ~s should have been a ~s, but was ~s" - (lookup-error-id condition) - (lookup-error-display condition) - (lookup-error-type condition) - (lookup-error-object condition))))) - -(define-condition connection-failure (x-error) - ((major-version :reader connection-failure-major-version :initarg :major-version) - (minor-version :reader connection-failure-minor-version :initarg :minor-version) - (host :reader connection-failure-host :initarg :host) - (display :reader connection-failure-display :initarg :display) - (reason :reader connection-failure-reason :initarg :reason)) - (:report - (lambda (condition stream) - (format stream "Connection failure to X~d.~d server ~a display ~d: ~a" - (connection-failure-major-version condition) - (connection-failure-minor-version condition) - (connection-failure-host condition) - (connection-failure-display condition) - (connection-failure-reason condition))))) - -(define-condition reply-length-error (x-error) - ((reply-length :reader reply-length-error-reply-length :initarg :reply-length) - (expected-length :reader reply-length-error-expected-length :initarg :expected-length) - (display :reader reply-length-error-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Reply length was ~d when ~d words were expected for display ~s" - (reply-length-error-reply-length condition) - (reply-length-error-expected-length condition) - (reply-length-error-display condition))))) - -(define-condition reply-timeout (x-error) - ((timeout :reader reply-timeout-timeout :initarg :timeout) - (display :reader reply-timeout-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Timeout after waiting ~d seconds for a reply for display ~s" - (reply-timeout-timeout condition) - (reply-timeout-display condition))))) - -(define-condition sequence-error (x-error) - ((display :reader sequence-error-display :initarg :display) - (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence) - (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence)) - (:report - (lambda (condition stream) - (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d" - (sequence-error-display condition) - (sequence-error-req-sequence condition) - (sequence-error-msg-sequence condition))))) - -(define-condition unexpected-reply (x-error) - ((display :reader unexpected-reply-display :initarg :display) - (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence) - (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence) - (length :reader unexpected-reply-length :initarg :length)) - (:report - (lambda (condition stream) - (format stream "Display ~s received a server reply when none was expected.~@ - Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." - (unexpected-reply-display condition) - (unexpected-reply-req-sequence condition) - (unexpected-reply-msg-sequence condition) - (unexpected-reply-length condition))))) - -(define-condition missing-parameter (x-error) - ((parameter :reader missing-parameter-parameter :initarg :parameter)) - (:report - (lambda (condition stream) - (let ((parm (missing-parameter-parameter condition))) - (if (consp parm) - (format stream "One or more of the required parameters ~a is missing." - parm) - (format stream "Required parameter ~a is missing or null." parm)))))) - -;; This can be signalled anywhere a pseudo font access fails. -(define-condition invalid-font (x-error) - ((font :reader invalid-font-font :initarg :font)) - (:report - (lambda (condition stream) - (format stream "Can't access font ~s" (invalid-font-font condition))))) - -(define-condition device-busy (x-error) - ((display :reader device-busy-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Device busy for display ~s" - (device-busy-display condition))))) - -(define-condition unimplemented-event (x-error) - ((display :reader unimplemented-event-display :initarg :display) - (event-code :reader unimplemented-event-event-code :initarg :event-code)) - (:report - (lambda (condition stream) - (format stream "Event code ~d not implemented for display ~s" - (unimplemented-event-event-code condition) - (unimplemented-event-display condition))))) - -(define-condition undefined-event (x-error) - ((display :reader undefined-event-display :initarg :display) - (event-name :reader undefined-event-event-name :initarg :event-name)) - (:report - (lambda (condition stream) - (format stream "Event code ~d undefined for display ~s" - (undefined-event-event-name condition) - (undefined-event-display condition))))) - -(define-condition absent-extension (x-error) - ((name :reader absent-extension-name :initarg :name) - (display :reader absent-extension-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Extension ~a isn't defined for display ~s" - (absent-extension-name condition) - (absent-extension-display condition))))) - -(define-condition inconsistent-parameters (x-error) - ((parameters :reader inconsistent-parameters-parameters :initarg :parameters)) - (:report - (lambda (condition stream) - (format stream "inconsistent-parameters:~{ ~s~}" - (inconsistent-parameters-parameters condition))))) - -(define-condition resource-ids-exhausted (x-error) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream "All X resource IDs are in use.")))) - -(defun get-error-key (display error-code) - (declare (type display display) - (type array-index error-code)) - ;; Return the error-key associated with error-code - (if (< error-code (length *xerror-vector*)) - (svref *xerror-vector* error-code) - ;; Search the extensions for the error - (dolist (entry (display-extension-alist display) 'unknown-error) - (let* ((event-name (first entry)) - (first-error (fourth entry)) - (errors (third (assoc event-name *extensions*)))) - (declare (type keyword event-name) - (type array-index first-error) - (type list errors)) - (when (and errors - (index<= first-error error-code - (index+ first-error (index- (length errors) 1)))) - (return (nth (index- error-code first-error) errors))))))) - -(defmacro define-error (error-key function) - ;; Associate a function with ERROR-KEY which will be called with - ;; parameters DISPLAY and REPLY-BUFFER and - ;; returns a plist of keyword/value pairs which will be passed on - ;; to the error handler. A compiler warning is printed when - ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION. - ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type - ;; macros for getting error fields. See DECODE-CORE-ERROR for - ;; an example. - (declare (type symbol error-key) - (type (or symbol list) function)) - ;; First ensure the name is for a declared extension - (unless (or (find error-key *xerror-vector*) - (dolist (extension *extensions*) - (when (member error-key (third extension)) - (return t)))) - (x-type-error error-key 'error-key)) - `(setf (get ',error-key 'error-decode-function) (function ,function))) - -;; All core errors use this, so we make it available to extensions. -(defun decode-core-error (display event &optional arg) - ;; All core errors have the following keyword/argument pairs: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; In addition, many have an additional argument that comes from the - ;; same place in the event, but is named differently. When the ARG - ;; argument is specified, the keyword ARG with card32 value starting - ;; at byte 4 of the event is returned with the other keyword/argument - ;; pairs. - (declare (type display display) - (type reply-buffer event) - (type (or null keyword) arg)) - (declare (clx-values keyword/arg-plist)) - display - (reading-event (event) - (let* ((sequence (read-card16 2)) - (minor-code (read-card16 8)) - (major-code (read-card8 10)) - (result (list :major major-code - :minor minor-code - :sequence sequence))) - (when arg - (setq result (list* arg (read-card32 4) result))) - result))) - -(defun decode-resource-error (display event) - (decode-core-error display event :resource-id)) - -(define-error unknown-error - (lambda (display event) - (list* :error-code (aref (reply-ibuf8 event) 1) - (decode-core-error display event)))) - -(define-error request-error decode-core-error) ; 1 bad request code - -(define-error value-error ; 2 integer parameter out of range - (lambda (display event) - (decode-core-error display event :value))) - -(define-error window-error decode-resource-error) ; 3 parameter not a Window - -(define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap - -(define-error atom-error ; 5 parameter not an Atom - (lambda (display event) - (decode-core-error display event :atom-id))) - -(define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor - -(define-error font-error decode-resource-error) ; 7 parameter not a Font - -(define-error match-error decode-core-error) ; 8 parameter mismatch - -(define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window - -(define-error access-error decode-core-error) ; 10 attempt to access private resource" - -(define-error alloc-error decode-core-error) ; 11 insufficient resources - -(define-error colormap-error decode-resource-error) ; 12 no such colormap - -(define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext - -(define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection - -(define-error name-error decode-core-error) ; 15 font or color name does not exist - -(define-error length-error decode-core-error) ; 16 request length incorrect; - ; internal Xlib error - -(define-error implementation-error decode-core-error) ; 17 server is defective diff --git a/src/clx/keysyms.lisp b/src/clx/keysyms.lisp deleted file mode 100644 index 0c6d59f72..000000000 --- a/src/clx/keysyms.lisp +++ /dev/null @@ -1,433 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- - -;;; Define lisp character to keysym mappings - -;;; -;;; 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) - -(define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) -(define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) -(define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) -(define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) -(define-keysym-set :kana (keysym 4 0) (keysym 4 255)) -(define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) -(define-keysym-set :cyrillic (keysym 6 0) (keysym 6 255)) -(define-keysym-set :greek (keysym 7 0) (keysym 7 255)) -(define-keysym-set :tech (keysym 8 0) (keysym 8 255)) -(define-keysym-set :special (keysym 9 0) (keysym 9 255)) -(define-keysym-set :publish (keysym 10 0) (keysym 10 255)) -(define-keysym-set :apl (keysym 11 0) (keysym 11 255)) -(define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) -(define-keysym-set :thai (keysym 13 0) (keysym 13 255)) -(define-keysym-set :korean (keysym 14 0) (keysym 14 255)) -(define-keysym-set :latin-5 (keysym 15 0) (keysym 15 255)) -(define-keysym-set :latin-6 (keysym 16 0) (keysym 16 255)) -(define-keysym-set :latin-7 (keysym 17 0) (keysym 17 255)) -(define-keysym-set :latin-8 (keysym 18 0) (keysym 18 255)) -(define-keysym-set :latin-9 (keysym 19 0) (keysym 19 255)) -(define-keysym-set :currency (keysym 32 0) (keysym 32 255)) -(define-keysym-set :|3270| (keysym 253 0) (keysym 253 255)) -(define-keysym-set :xkb (keysym 254 0) (keysym 254 255)) -(define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) - -(define-keysym :character-set-switch character-set-switch-keysym) -(define-keysym :left-shift left-shift-keysym) -(define-keysym :right-shift right-shift-keysym) -(define-keysym :left-control left-control-keysym) -(define-keysym :right-control right-control-keysym) -(define-keysym :caps-lock caps-lock-keysym) -(define-keysym :shift-lock shift-lock-keysym) -(define-keysym :left-meta left-meta-keysym) -(define-keysym :right-meta right-meta-keysym) -(define-keysym :left-alt left-alt-keysym) -(define-keysym :right-alt right-alt-keysym) -(define-keysym :left-super left-super-keysym) -(define-keysym :right-super right-super-keysym) -(define-keysym :left-hyper left-hyper-keysym) -(define-keysym :right-hyper right-hyper-keysym) - -(define-keysym #\space 032) -(define-keysym #\! 033) -(define-keysym #\" 034) -(define-keysym #\# 035) -(define-keysym #\$ 036) -(define-keysym #\% 037) -(define-keysym #\& 038) -(define-keysym #\' 039) -(define-keysym #\( 040) -(define-keysym #\) 041) -(define-keysym #\* 042) -(define-keysym #\+ 043) -(define-keysym #\, 044) -(define-keysym #\- 045) -(define-keysym #\. 046) -(define-keysym #\/ 047) -(define-keysym #\0 048) -(define-keysym #\1 049) -(define-keysym #\2 050) -(define-keysym #\3 051) -(define-keysym #\4 052) -(define-keysym #\5 053) -(define-keysym #\6 054) -(define-keysym #\7 055) -(define-keysym #\8 056) -(define-keysym #\9 057) -(define-keysym #\: 058) -(define-keysym #\; 059) -(define-keysym #\< 060) -(define-keysym #\= 061) -(define-keysym #\> 062) -(define-keysym #\? 063) -(define-keysym #\@ 064) -(define-keysym #\A 065 :lowercase 097) -(define-keysym #\B 066 :lowercase 098) -(define-keysym #\C 067 :lowercase 099) -(define-keysym #\D 068 :lowercase 100) -(define-keysym #\E 069 :lowercase 101) -(define-keysym #\F 070 :lowercase 102) -(define-keysym #\G 071 :lowercase 103) -(define-keysym #\H 072 :lowercase 104) -(define-keysym #\I 073 :lowercase 105) -(define-keysym #\J 074 :lowercase 106) -(define-keysym #\K 075 :lowercase 107) -(define-keysym #\L 076 :lowercase 108) -(define-keysym #\M 077 :lowercase 109) -(define-keysym #\N 078 :lowercase 110) -(define-keysym #\O 079 :lowercase 111) -(define-keysym #\P 080 :lowercase 112) -(define-keysym #\Q 081 :lowercase 113) -(define-keysym #\R 082 :lowercase 114) -(define-keysym #\S 083 :lowercase 115) -(define-keysym #\T 084 :lowercase 116) -(define-keysym #\U 085 :lowercase 117) -(define-keysym #\V 086 :lowercase 118) -(define-keysym #\W 087 :lowercase 119) -(define-keysym #\X 088 :lowercase 120) -(define-keysym #\Y 089 :lowercase 121) -(define-keysym #\Z 090 :lowercase 122) -(define-keysym #\[ 091) -(define-keysym #\\ 092) -(define-keysym #\] 093) -(define-keysym #\^ 094) -(define-keysym #\_ 095) -(define-keysym #\` 096) -(define-keysym #\a 097) -(define-keysym #\b 098) -(define-keysym #\c 099) -(define-keysym #\d 100) -(define-keysym #\e 101) -(define-keysym #\f 102) -(define-keysym #\g 103) -(define-keysym #\h 104) -(define-keysym #\i 105) -(define-keysym #\j 106) -(define-keysym #\k 107) -(define-keysym #\l 108) -(define-keysym #\m 109) -(define-keysym #\n 110) -(define-keysym #\o 111) -(define-keysym #\p 112) -(define-keysym #\q 113) -(define-keysym #\r 114) -(define-keysym #\s 115) -(define-keysym #\t 116) -(define-keysym #\u 117) -(define-keysym #\v 118) -(define-keysym #\w 119) -(define-keysym #\x 120) -(define-keysym #\y 121) -(define-keysym #\z 122) -(define-keysym #\{ 123) -(define-keysym #\| 124) -(define-keysym #\} 125) -(define-keysym #\~ 126) - -(progn ;; Semi-standard characters - (define-keysym #\rubout (keysym 255 255)) ; :tty - (define-keysym #\tab (keysym 255 009)) ; :tty - (define-keysym #\linefeed (keysym 255 010)) ; :tty - (define-keysym #\page (keysym 009 227)) ; :special - (define-keysym #\return (keysym 255 013)) ; :tty - (define-keysym #\backspace (keysym 255 008)) ; :tty - ) - -;;; these keysym definitions are only correct if the underlying lisp's -;;; definition of characters between 160 and 255 match latin1 exactly. -;;; If the characters are in some way locale-dependent (as, I believe, -;;; in Allegro8) or are treated as opaque without any notions of -;;; graphicness or case (as in cmucl and openmcl) then defining these -;;; keysyms is either not useful or wrong. -- CSR, 2006-03-14 -#+sbcl -(progn - (do ((i 160 (+ i 1))) - ((>= i 256)) - (if (or (<= #xc0 i #xd6) - (<= #xd8 i #xde)) - (define-keysym (code-char i) i :lowercase (+ i 32)) - (define-keysym (code-char i) i)))) - -#+(or lispm excl) -(progn ;; Nonstandard characters - (define-keysym #\escape (keysym 255 027)) ; :tty - ) - -#+ti -(progn - (define-keysym #\Inverted-exclamation-mark 161) - (define-keysym #\american-cent-sign 162) - (define-keysym #\british-pound-sign 163) - (define-keysym #\Currency-sign 164) - (define-keysym #\Japanese-yen-sign 165) - (define-keysym #\Yen 165) - (define-keysym #\Broken-bar 166) - (define-keysym #\Section-symbol 167) - (define-keysym #\Section 167) - (define-keysym #\Diaresis 168) - (define-keysym #\Umlaut 168) - (define-keysym #\Copyright-sign 169) - (define-keysym #\Copyright 169) - (define-keysym #\Feminine-ordinal-indicator 170) - (define-keysym #\Angle-quotation-left 171) - (define-keysym #\Soft-hyphen 173) - (define-keysym #\Shy 173) - (define-keysym #\Registered-trademark 174) - (define-keysym #\Macron 175) - (define-keysym #\Degree-sign 176) - (define-keysym #\Ring 176) - (define-keysym #\Plus-minus-sign 177) - (define-keysym #\Superscript-2 178) - (define-keysym #\Superscript-3 179) - (define-keysym #\Acute-accent 180) - (define-keysym #\Greek-mu 181) - (define-keysym #\Paragraph-symbol 182) - (define-keysym #\Paragraph 182) - (define-keysym #\Pilcrow-sign 182) - (define-keysym #\Middle-dot 183) - (define-keysym #\Cedilla 184) - (define-keysym #\Superscript-1 185) - (define-keysym #\Masculine-ordinal-indicator 186) - (define-keysym #\Angle-quotation-right 187) - (define-keysym #\Fraction-1/4 188) - (define-keysym #\One-quarter 188) - (define-keysym #\Fraction-1/2 189) - (define-keysym #\One-half 189) - (define-keysym #\Fraction-3/4 190) - (define-keysym #\Three-quarters 190) - (define-keysym #\Inverted-question-mark 191) - (define-keysym #\Multiplication-sign 215) - (define-keysym #\Eszet 223) - (define-keysym #\Division-sign 247) -) - -#+ti -(progn ;; There are no 7-bit ascii representations for the following - ;; European characters, so use int-char to create them to ensure - ;; nothing is lost while sending files through the mail. - (define-keysym (int-char 192) 192 :lowercase 224) - (define-keysym (int-char 193) 193 :lowercase 225) - (define-keysym (int-char 194) 194 :lowercase 226) - (define-keysym (int-char 195) 195 :lowercase 227) - (define-keysym (int-char 196) 196 :lowercase 228) - (define-keysym (int-char 197) 197 :lowercase 229) - (define-keysym (int-char 198) 198 :lowercase 230) - (define-keysym (int-char 199) 199 :lowercase 231) - (define-keysym (int-char 200) 200 :lowercase 232) - (define-keysym (int-char 201) 201 :lowercase 233) - (define-keysym (int-char 202) 202 :lowercase 234) - (define-keysym (int-char 203) 203 :lowercase 235) - (define-keysym (int-char 204) 204 :lowercase 236) - (define-keysym (int-char 205) 205 :lowercase 237) - (define-keysym (int-char 206) 206 :lowercase 238) - (define-keysym (int-char 207) 207 :lowercase 239) - (define-keysym (int-char 208) 208 :lowercase 240) - (define-keysym (int-char 209) 209 :lowercase 241) - (define-keysym (int-char 210) 210 :lowercase 242) - (define-keysym (int-char 211) 211 :lowercase 243) - (define-keysym (int-char 212) 212 :lowercase 244) - (define-keysym (int-char 213) 213 :lowercase 245) - (define-keysym (int-char 214) 214 :lowercase 246) - (define-keysym (int-char 215) 215) - (define-keysym (int-char 216) 216 :lowercase 248) - (define-keysym (int-char 217) 217 :lowercase 249) - (define-keysym (int-char 218) 218 :lowercase 250) - (define-keysym (int-char 219) 219 :lowercase 251) - (define-keysym (int-char 220) 220 :lowercase 252) - (define-keysym (int-char 221) 221 :lowercase 253) - (define-keysym (int-char 222) 222 :lowercase 254) - (define-keysym (int-char 223) 223) - (define-keysym (int-char 224) 224) - (define-keysym (int-char 225) 225) - (define-keysym (int-char 226) 226) - (define-keysym (int-char 227) 227) - (define-keysym (int-char 228) 228) - (define-keysym (int-char 229) 229) - (define-keysym (int-char 230) 230) - (define-keysym (int-char 231) 231) - (define-keysym (int-char 232) 232) - (define-keysym (int-char 233) 233) - (define-keysym (int-char 234) 234) - (define-keysym (int-char 235) 235) - (define-keysym (int-char 236) 236) - (define-keysym (int-char 237) 237) - (define-keysym (int-char 238) 238) - (define-keysym (int-char 239) 239) - (define-keysym (int-char 240) 240) - (define-keysym (int-char 241) 241) - (define-keysym (int-char 242) 242) - (define-keysym (int-char 243) 243) - (define-keysym (int-char 244) 244) - (define-keysym (int-char 245) 245) - (define-keysym (int-char 246) 246) - (define-keysym (int-char 247) 247) - (define-keysym (int-char 248) 248) - (define-keysym (int-char 249) 249) - (define-keysym (int-char 250) 250) - (define-keysym (int-char 251) 251) - (define-keysym (int-char 252) 252) - (define-keysym (int-char 253) 253) - (define-keysym (int-char 254) 254) - (define-keysym (int-char 255) 255) - ) - -#+lispm ;; Nonstandard characters -(progn - (define-keysym #\center-dot (keysym 183)) ; :latin-1 - (define-keysym #\down-arrow (keysym 008 254)) ; :technical - (define-keysym #\alpha (keysym 007 225)) ; :greek - (define-keysym #\beta (keysym 007 226)) ; :greek - (define-keysym #\and-sign (keysym 008 222)) ; :technical - (define-keysym #\not-sign (keysym 172)) ; :latin-1 - (define-keysym #\epsilon (keysym 007 229)) ; :greek - (define-keysym #\pi (keysym 007 240)) ; :greek - (define-keysym #\lambda (keysym 007 235)) ; :greek - (define-keysym #\gamma (keysym 007 227)) ; :greek - (define-keysym #\delta (keysym 007 228)) ; :greek - (define-keysym #\up-arrow (keysym 008 252)) ; :technical - (define-keysym #\plus-minus (keysym 177)) ; :latin-1 - (define-keysym #\infinity (keysym 008 194)) ; :technical - (define-keysym #\partial-delta (keysym 008 239)) ; :technical - (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl - (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl - (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl - (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl - (define-keysym #\double-arrow (keysym 008 205)) ; :technical - (define-keysym #\left-arrow (keysym 008 251)) ; :technical - (define-keysym #\right-arrow (keysym 008 253)) ; :technical - (define-keysym #\not-equals (keysym 008 189)) ; :technical - (define-keysym #\less-or-equal (keysym 008 188)) ; :technical - (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical - (define-keysym #\equivalence (keysym 008 207)) ; :technical - (define-keysym #\or-sign (keysym 008 223)) ; :technical - (define-keysym #\integral (keysym 008 191)) ; :technical -;; break isn't null -;; (define-keysym #\null (keysym 255 107)) ; :function - (define-keysym #\clear-input (keysym 255 011)) ; :tty - (define-keysym #\help (keysym 255 106)) ; :function - (define-keysym #\refresh (keysym 255 097)) ; :function - (define-keysym #\abort (keysym 255 105)) ; :function - (define-keysym #\resume (keysym 255 098)) ; :function - (define-keysym #\end (keysym 255 087)) ; :cursor -;;#\universal-quantifier -;;#\existential-quantifier -;;#\circle-plus -;;#\circle-cross same as #\circle-x - ) - -#+genera -(progn -;;#\network -;;#\symbol-help - (define-keysym #\lozenge (keysym 009 224)) ; :special - (define-keysym #\suspend (keysym 255 019)) ; :tty - (define-keysym #\function (keysym 255 032)) ; :function - (define-keysym #\square (keysym 010 231)) ; :publishing - (define-keysym #\circle (keysym 010 230)) ; :publishing - (define-keysym #\triangle (keysym 010 232)) ; :publishing - (define-keysym #\scroll (keysym 255 086)) ; :cursor - (define-keysym #\select (keysym 255 096)) ; :function - (define-keysym #\complete (keysym 255 104)) ; :function - ) - -#+ti -(progn - (define-keysym #\terminal (keysym 255 032)) ; :function - (define-keysym #\system (keysym 255 096)) ; :function - (define-keysym #\center-arrow (keysym 255 80)) - (define-keysym #\left-arrow (keysym 255 081)) ; :cursor - (define-keysym #\up-arrow (keysym 255 082)) ; :cursor - (define-keysym #\right-arrow (keysym 255 083)) ; :cursor - (define-keysym #\down-arrow (keysym 255 084)) ; :cursor - (define-keysym #\end (keysym 255 087)) ; :cursor - (define-keysym #\undo (keysym 255 101)) ; :function - (define-keysym #\break (keysym 255 107)) - (define-keysym #\keypad-space (keysym 255 128)) ; :keypad - (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad - (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad - (define-keysym #\f1 (keysym 255 145)) ; :keypad - (define-keysym #\f2 (keysym 255 146)) ; :keypad - (define-keysym #\f3 (keysym 255 147)) ; :keypad - (define-keysym #\f4 (keysym 255 148)) ; :keypad - (define-keysym #\f1 (keysym 255 190)) ; :keypad - (define-keysym #\f2 (keysym 255 191)) ; :keypad - (define-keysym #\f3 (keysym 255 192)) ; :keypad - (define-keysym #\f4 (keysym 255 193)) ; :keypad - (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad - (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad - (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad - (define-keysym #\keypad-period (keysym 255 174)) ; :keypad - (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad - (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad - (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad - (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad - (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad - (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad - (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad - (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad - (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad - (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad - (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad - (define-keysym #\f1 (keysym 255 192)) ; :function - (define-keysym #\f2 (keysym 255 193)) ; :function - (define-keysym #\f3 (keysym 255 194)) ; :function - (define-keysym #\f4 (keysym 255 195)) ; :function - (define-keysym #\network (keysym 255 214)) - (define-keysym #\status (keysym 255 215)) - (define-keysym #\clear-screen (keysym 255 217)) - (define-keysym #\left (keysym 255 218)) - (define-keysym #\middle (keysym 255 219)) - (define-keysym #\right (keysym 255 220)) - (define-keysym #\resume (keysym 255 221)) - (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete - ) - -#+ti -(progn ;; Explorer specific characters - (define-keysym #\Call (keysym 131)) ; :latin-1 - (define-keysym #\Macro (keysym 133)) ; :latin-1 - (define-keysym #\Quote (keysym 142)) ; :latin-1 - (define-keysym #\Hold-output (keysym 143)) ; :latin-1 - (define-keysym #\Stop-output (keysym 144)) ; :latin-1 - (define-keysym #\Center (keysym 156)) ; :latin-1 - (define-keysym #\no-break-space (keysym 160)) ; :latin-1 - - (define-keysym #\circle-plus (keysym 13)) ; :latin-1 - (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 - (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 - (define-keysym #\circle-cross (keysym 22)) ; :latin-1 - ) - diff --git a/src/clx/macros.lisp b/src/clx/macros.lisp deleted file mode 100644 index ff0fe4c34..000000000 --- a/src/clx/macros.lisp +++ /dev/null @@ -1,1097 +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. -;;; - -;;; CLX basically implements a very low overhead remote procedure call -;;; to the server. This file contains macros which generate the code -;;; for both the client AND the server, given a specification of the -;;; interface. This was done to eliminate errors that may occur because -;;; the client and server code get/put bytes in different places, and -;;; it makes it easier to extend the protocol. - -;;; This is built on top of BUFFER - -(in-package :xlib) - -(defmacro type-check (value type) - value type - (when +type-check?+ - `(unless (type? ,value ,type) - (x-type-error ,value ,type)))) - -;;; This variable is used by the required-arg macro just to satisfy compilers. -(defvar *required-arg-dummy*) - -;;; An error signalling macro use to specify that keyword arguments are required. -(defmacro required-arg (name) - `(progn (x-error 'missing-parameter :parameter ',name) - *required-arg-dummy*)) - -(defmacro lround (index) - ;; Round up to the next 32 bit boundary - `(the array-index (logand (index+ ,index 3) -4))) - -(defmacro wround (index) - ;; Round up to the next 16 bit boundary - `(the array-index (logand (index+ ,index 1) -2))) - -;; -;; Data-type accessor functions -;; -;; These functions translate between lisp data-types and the byte, -;; half-word or word that gets transmitted across the client/server -;; connection - -(defun index-increment (type) - ;; Given a type, return its field width in bytes - (let* ((name (if (consp type) (car type) type)) - (increment (get name 'byte-width :not-found))) - (when (eq increment :not-found) - ;; Check for TYPE in a different package - (when (not (eq (symbol-package name) *xlib-package*)) - (setq name (xintern name)) - (setq increment (get name 'byte-width :not-found))) - (when (eq increment :not-found) - (error "~s isn't a known field accessor" name))) - increment)) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun getify (name) - (xintern name '-get)) - -(defun putify (name &optional predicate-p) - (xintern name '-put (if predicate-p '-predicating ""))) - -;;; Use &body so zmacs indents properly -(defmacro define-accessor (name (width) &body get-put-macros) - ;; The first body form defines the get macro - ;; The second body form defines the put macro - ;; The third body form is optional, and defines a put macro that does - ;; type checking and does a put when ok, else NIL when the type is incorrect. - ;; If no third body form is present, then these macros assume that - ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. - ;; these predicating puts are used by the OR accessor. - (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) - (when (cdddr get-put-macros) - (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) - (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name))) - (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) - `(within-definition (,name define-accessor) - (setf (get ',name 'byte-width) ,(and width (floor width 8))) - (defmacro ,(getify name) ,(car get-macro) - ,@(cdr get-macro)) - (defmacro ,(putify name) ,(car put-macro) - ,@(cdr put-macro)) - ,@(when +type-check?+ - (let ((predicating-put (third get-put-macros))) - (when predicating-put - `((setf (get ',name 'predicating-put) t) - (defmacro ,(putify name t) ,(car predicating-put) - ,@(cdr predicating-put))))))))) -) ;; End eval-when - -(define-accessor card32 (32) - ((index) `(read-card32 ,index)) - ((index thing) `(write-card32 ,index ,thing))) - -(define-accessor card29 (32) - ((index) `(read-card29 ,index)) - ((index thing) `(write-card29 ,index ,thing))) - -(define-accessor card16 (16) - ((index) `(read-card16 ,index)) - ((index thing) `(write-card16 ,index ,thing))) - -(define-accessor card8 (8) - ((index) `(read-card8 ,index)) - ((index thing) `(write-card8 ,index ,thing))) - -(define-accessor integer (32) - ((index) `(read-int32 ,index)) - ((index thing) `(write-int32 ,index ,thing))) - -(define-accessor int16 (16) - ((index) `(read-int16 ,index)) - ((index thing) `(write-int16 ,index ,thing))) - -(define-accessor rgb-val (16) - ;; Used for color's - ((index) `(card16->rgb-val (read-card16 ,index))) - ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing)))) - -(define-accessor angle (16) - ;; Used for drawing arcs - ((index) `(int16->radians (read-int16 ,index))) - ((index thing) `(write-int16 ,index (radians->int16 ,thing)))) - -(define-accessor bit (0) - ;; Like BOOLEAN, but tests bits - ;; only used by declare-event (:enter-notify :leave-notify) - ((index bit) - `(logbitp ,bit (read-card8 ,index))) - ((index thing bit) - (if (zerop bit) - `(write-card8 ,index (if ,thing 1 0)) - `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index)))))) - -(define-accessor boolean (8) - ((index) - `(plusp (read-card8 ,index))) - ((index thing) `(write-card8 ,index (if ,thing 1 0)))) - -(define-accessor drawable (32) - ((index &optional (buffer '%buffer)) - `(lookup-drawable ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (drawable-id ,thing)))) - -(define-accessor window (32) - ((index &optional (buffer '%buffer)) - `(lookup-window ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (window-id ,thing)))) - -(define-accessor pixmap (32) - ((index &optional (buffer '%buffer)) - `(lookup-pixmap ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (pixmap-id ,thing)))) - -(define-accessor gcontext (32) - ((index &optional (buffer '%buffer)) - `(lookup-gcontext ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (gcontext-id ,thing)))) - -(define-accessor cursor (32) - ((index &optional (buffer '%buffer)) - `(lookup-cursor ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (cursor-id ,thing)))) - -(define-accessor colormap (32) - ((index &optional (buffer '%buffer)) - `(lookup-colormap ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (colormap-id ,thing)))) - -(define-accessor font (32) - ((index &optional (buffer '%buffer)) - `(lookup-font ,buffer (read-card29 ,index))) - ;; The FONT-ID accessor may make a OpenFont request. Since we don't support recursive - ;; with-buffer-request, issue a compile time error, rather than barf at run-time. - ((index thing) - (declare (ignore index thing)) - (error "FONT-ID must be called OUTSIDE with-buffer-request. Use RESOURCE-ID instead."))) - -;; Needed to get and put xatom's in events -(define-accessor keyword (32) - ((index &optional (buffer '%buffer)) - `(atom-name ,buffer (read-card29 ,index))) - ((index thing &key (buffer '%buffer)) - `(write-card29 ,index (or (atom-id ,thing ,buffer) - (error "CLX implementation error in KEYWORD-PUT"))))) - -(define-accessor resource-id (32) - ((index) `(read-card29 ,index)) - ((index thing) `(write-card29 ,index ,thing))) - -(define-accessor resource-id-or-nil (32) - ((index) (let ((id (gensym))) - `(let ((,id (read-card29 ,index))) - (and (plusp ,id) ,id)))) - ((index thing) `(write-card29 ,index (or ,thing 0)))) - -(defmacro char-info-get (index) - `(make-char-info - :left-bearing (int16-get ,index) - :right-bearing (int16-get ,(+ index 2)) - :width (int16-get ,(+ index 4)) - :ascent (int16-get ,(+ index 6)) - :descent (int16-get ,(+ index 8)) - :attributes (card16-get ,(+ index 10)))) - -(define-accessor member8 (8) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card8 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card8 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card8 ,index ,value)))))) - -(define-accessor member16 (16) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card16 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card16 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card16 ,index ,value)))))) - -(define-accessor member (32) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card29 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (if (cdr keywords) ;; IF more than one - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card29 ,index ,value)))) - `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) - -(deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list))) - -(define-accessor member-vector (32) - ((index membership-vector) - `(member-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor member16-vector (16) - ((index membership-vector) - `(member16-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor member8-vector (8) - ((index membership-vector) - `(member8-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor boole-constant (32) - ;; this isn't member-vector because we need eql instead of eq - ((index) - (let ((value (gensym))) - `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length +boole-vector+))) ,value)) - (type-check ,value '(integer 0 (,(length +boole-vector+)))) - (svref +boole-vector+ ,value)))) - ((index thing) - `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+)))) - ((index thing) - (let ((value (gensym))) - `(let ((,value (position ,thing (the simple-vector +boole-vector+)))) - (and ,value (write-card29 ,index ,value)))))) - -(define-accessor null (32) - ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index))) - ((index value) (declare (ignore value)) `(write-card32 ,index 0))) - -(define-accessor pad8 (8) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor pad16 (16) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor pad32 (32) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor bit-vector256 (256) - ;; used for key-maps - ;; REAL-INDEX parameter provided so the default index can be over-ridden. - ;; This is needed for the :keymap-notify event where the keymap overlaps - ;; the window id. - ((index &optional (real-index index) data) - `(read-bitvector256 buffer-bbuf ,real-index ,data)) - ((index map &optional (real-index index) (buffer '%buffer)) - `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map))) - -(define-accessor string (nil) - ((length index &key reply-buffer) - `(read-sequence-char - ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index)) - ((index string &key buffer (start 0) end header-length appending) - (unless buffer (setq buffer '%buffer)) - (unless header-length (setq header-length (lround index))) - (let* ((real-end (if appending (or end `(length ,string)) (gensym))) - (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) - ,string ,start ,real-end))) - (if appending - form - `(let ((,real-end ,(or end `(length ,string)))) - (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) - ,form))))) - -(define-accessor sequence (nil) - ((&key length (format 'card32) result-type transform reply-buffer data index start) - `(,(ecase format - (card8 'read-sequence-card8) - (int8 'read-sequence-int8) - (card16 'read-sequence-card16) - (int16 'read-sequence-int16) - (card32 'read-sequence-card32) - (int32 'read-sequence-int32)) - ,(or reply-buffer '%reply-buffer) - ,result-type ,length ,transform ,data - ,@(when (or start index) `(,(or start 0))) - ,@(when index `(,index)))) - ((index data &key (format 'card32) (start 0) end transform buffer appending) - (unless buffer (setq buffer '%buffer)) - (let* ((real-end (if appending (or end `(length ,data)) (gensym))) - (writer (xintern 'write-sequence- format)) - (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) - ,data ,start ,real-end ,transform))) - (flet ((maker (size) - (if appending - form - (let ((idx `(index- ,real-end ,start))) - (unless (= size 1) - (setq idx `(index-ceiling ,idx ,size))) - `(let ((,real-end ,(or end `(length ,data)))) - (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) - ,form))))) - (ecase format - ((card8 int8) - (maker 4)) - ((card16 int16 char2b) - (maker 2)) - ((card32 int32) - (maker 1))))))) - -(defmacro client-message-event-get-sequence () - '(let* ((format (read-card8 1)) - (sequence (make-array (ceiling 160 format) - :element-type `(unsigned-byte ,format)))) - (declare (type (member 8 16 32) format)) - (do ((i 12) - (j 0 (index1+ j))) - ((>= i 32)) - (case format - (8 (setf (aref sequence j) (read-card8 i)) - (index-incf i)) - (16 (setf (aref sequence j) (read-card16 i)) - (index-incf i 2)) - (32 (setf (aref sequence j) (read-card32 i)) - (index-incf i 4)))) - sequence)) - -(defmacro client-message-event-put-sequence (format sequence) - `(ecase ,format - (8 (sequence-put 12 ,sequence - :format card8 - :end (min (length ,sequence) 20) - :appending t)) - (16 (sequence-put 12 ,sequence - :format card16 - :end (min (length ,sequence) 10) - :appending t)) - (32 (sequence-put 12 ,sequence - :format card32 - :end (min (length ,sequence) 5) - :appending t)))) - -;; Used only in declare-event -(define-accessor client-message-sequence (160) - ((index format) (declare (ignore index format)) `(client-message-event-get-sequence)) - ((index value format) (declare (ignore index)) - `(client-message-event-put-sequence ,format ,value))) - - -;;; -;;; Compound accessors -;;; Accessors that take other accessors as parameters -;;; -(define-accessor code (0) - ((index) (declare (ignore index)) '(read-card8 0)) - ((index value) (declare (ignore index)) `(write-card8 0 ,value)) - ((index value) (declare (ignore index)) `(write-card8 0 ,value))) - -(define-accessor length (0) - ((index) (declare (ignore index)) '(read-card16 2)) - ((index value) (declare (ignore index)) `(write-card16 2 ,value)) - ((index value) (declare (ignore index)) `(write-card16 2 ,value))) - -(deftype data () 'card8) - -(define-accessor data (0) - ;; Put data in byte 1 of the reqeust - ((index &optional stuff) (declare (ignore index)) - (if stuff - (if (consp stuff) - `(,(getify (car stuff)) 1 ,@(cdr stuff)) - `(,(getify stuff) 1)) - `(read-card8 1))) - ((index thing &optional stuff) - (if stuff - (if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing)) - `(write-card8 1 ,thing))) - ((index thing &optional stuff) - (if stuff - `(and (type? ,thing ',stuff) - ,(if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing))) - `(and (type? ,thing 'card8) (write-card8 1 ,thing))))) - -;; Macroexpand the result of OR-GET to allow the macros file to not be loaded -;; when using event-case. This is pretty gross. - -(defmacro or-expand (&rest forms &environment environment) - `(cond ,@(mapcar #'(lambda (forms) - (mapcar #'(lambda (form) - (clx-macroexpand form environment)) - forms)) - forms))) - -;; -;; the OR type -;; -(define-accessor or (32) - ;; Select from among several types (usually NULL and something else) - ((index &rest type-list &environment environment) - (do ((types type-list (cdr types)) - (value (gensym)) - (result)) - ((endp types) - `(let ((,value (read-card32 ,index))) - (macrolet ((read-card32 (index) index ',value) - (read-card29 (index) index ',value)) - ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment)))) - (let ((item (car types)) - (args nil)) - (when (consp item) - (setq args (cdr item) - item (car item))) - (if (eq item 'null) ;; Special case for NULL - (push `((zerop ,value) nil) result) - (push - `((,(getify item) ,index ,@args)) - result))))) - - ((index value &rest type-list) - (do ((types type-list (cdr types)) - (result)) - ((endp types) - `(cond ,@(nreverse result) - ,@(when +type-check?+ - `((t (x-type-error ,value '(or ,@type-list))))))) - (let* ((type (car types)) - (type-name type) - (args nil)) - (when (consp type) - (setq args (cdr type) - type-name (car type))) - (push - `(,@(cond ((get type-name 'predicating-put) nil) - ((or +type-check?+ (cdr types)) `((type? ,value ',type))) - (t '(t))) - (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) - result))))) - -;; -;; the MASK type... -;; is used to specify a subset of a collection of "optional" arguments. -;; A mask type consists of a 32 bit mask word followed by a word for each one-bit -;; in the mask. The MASK type is ALWAYS the LAST item in a request. -;; -(setf (get 'mask 'byte-width) nil) - -(defun mask-get (index type-values body-function) - (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; This is a function, because it must return more than one form (called by get-put-items) - ;; Functions that use this must have a binding for %MASK - (let* ((bit 0) - (result - (mapcar - #'(lambda (form) - (if (atom form) - form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs - (prog1 - `(when (logbitp ,bit %mask) - ;; Execute form when bit is set - ,form) - (incf bit)))) - (get-put-items - (+ index 4) type-values nil - #'(lambda (type index item args) - (declare (ignore index)) - (funcall body-function type '(* (incf %index) 4) item args)))))) - ;; First form must load %MASK - `(,@(when (atom (car result)) - (list (pop result))) - (progn (setq %mask (read-card32 ,index)) - (setq %index ,(ceiling index 4)) - ,(car result)) - ,@(cdr result)))) - -;; MASK-PUT - -(defun mask-put (index type-values body-function) - (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES - ;; A 32 bit value follows for each non-nil value. - `((let ((%mask 0) - (%index ,index)) - ,@(let ((bit 1)) - (get-put-items - index type-values t - #'(lambda (type index item args) - (declare (ignore index)) - (if (or (symbolp item) (constantp item)) - `((unless (null ,item) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) item args))) - `((let ((.item. ,item)) - (unless (null .item.) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) '.item. args)))))))) - (write-card32 ,index %mask) - (write-card16 2 (index-ceiling (index-incf %index 4) 4)) - (incf (buffer-boffset %buffer) %index)))) - -(define-accessor progn (nil) - ;; Catch-all for inserting random code - ;; Note that code using this is then responsible for setting the request length - ((index statement) (declare (ignore index)) statement) - ((index statement) (declare (ignore index)) statement)) - - -; -; Wrapper macros, for use around the above -; - -;;; type-check was here, and has been moved up - -(defmacro check-put (index value type &rest args &environment env) - (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) - (body - (if (or (null (macroexpand `(type-check ,var ',type) env)) - (member type '(or progn pad8 pad16)) - (constantp value)) - `(,(putify type) ,index ,var ,@args) - ;; Do type checking - (if (get type 'predicating-put) - `(or (,(putify type t) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))) - `(if (type? ,var ',type) - (,(putify type) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))))))) - (if (eq var value) - body - `(let ((,var ,value)) - ,body)))) - -(defun get-put-items (index type-args putp &optional body-function) - (declare (type (or null function) body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; Given a lists of the form (type item item ... item) - ;; Calls body-function with four arguments, a function name, - ;; index, item name, and optional arguments. - ;; The results are appended together and retured. - (unless body-function - (setq body-function - #'(lambda (type index item args) - `((check-put ,index ,item ,type ,@args))))) - (do* ((items type-args (cdr items)) - (type (caar items) (caar items)) - (args nil nil) - (result nil) - (sizes nil)) - ((endp items) (values result index sizes)) - (when (consp type) - (setq args (cdr type) - type (car type))) - (cond ((member type '(return buffer))) - ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values - (setq result - (append result (if putp - (mask-put index (cdar items) body-function) - (mask-get index (cdar items) body-function))) - index nil)) - (t (do* ((item (cdar items) (cdr item)) - (increment (index-increment type))) - ((endp item)) - (when (constantp index) - (case increment ;Round up index when needed - (2 (setq index (wround index))) - (4 (setq index (lround index))))) - (setq result - (append result (funcall body-function type index (car item) args))) - (when (constantp index) - ;; Variable length requests have null length increment. - ;; Variable length requests set the request size - ;; & maintain buffer pointers - (if (null increment) - (setq index nil) - (progn - (incf index increment) - (when (and increment (zerop increment)) (setq increment 1)) - (pushnew (* increment 8) sizes))))))))) - -(defmacro with-buffer-request-internal - ((buffer opcode &key length sizes &allow-other-keys) - &body type-args) - (multiple-value-bind (code index item-sizes) - (get-put-items 4 type-args t) - (let ((length (if length `(index+ ,length +requestsize+) '+requestsize+)) - (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) - `(with-buffer-output (,buffer :length ,length :sizes ,sizes) - (setf (buffer-last-request ,buffer) buffer-boffset) - (write-card8 0 ,opcode) ;; Stick in the opcode - ,@code - ,@(when index - (setq index (lround index)) - `((write-card16 2 ,(ceiling index 4)) - (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) - (buffer-new-request-number ,buffer))))) - -(defmacro with-buffer-request - ((buffer opcode &rest options &key inline gc-force &allow-other-keys) - &body type-args &environment env) - (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.request-body.)) - (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) - 'with-buffer-request-function-nolock - 'with-buffer-request-function) - ,buffer ,gc-force #'.request-body.)) - `(let ((.display. ,buffer)) - (declare (type display .display.)) - (with-buffer (.display.) - ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) - (multiple-value-prog1 - (without-aborts - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args)) - (display-invoke-after-function .display.)))))) - -(defmacro with-buffer-request-and-reply - ((buffer opcode reply-size &key sizes multiple-reply inline) - type-args &body reply-forms &environment env) - (declare (indentation 0 4 1 4 2 1)) - (let* ((inner-reply-body - `(with-buffer-input (.reply-buffer. :display .display. - ,@(and sizes (list :sizes sizes))) - nil ,@reply-forms)) - (reply-body - (if (or (not (symbolp reply-size)) (constantp reply-size)) - inner-reply-body - `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) - (declare (type array-index ,reply-size)) - ,inner-reply-body)))) - (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (.reply-body. (.display. .reply-buffer.) - (declare (type display .display.) - (type reply-buffer .reply-buffer.)) - (progn .display. .reply-buffer. nil) - ,reply-body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.request-body. #'.reply-body.)) - (with-buffer-request-and-reply-function - ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) - `(let ((.display. ,buffer) - (.pending-command. nil) - (.reply-buffer. nil)) - (declare (type display .display.) - (type (or null pending-command) .pending-command.) - (type (or null reply-buffer) .reply-buffer.)) - (unwind-protect - (progn - (with-buffer (.display.) - (setq .pending-command. (start-pending-command .display.)) - (without-aborts - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (buffer-force-output .display.) - (display-invoke-after-function .display.)) - ,@(if multiple-reply - `((loop - (setq .reply-buffer. (read-reply .display. .pending-command.)) - (when ,reply-body (return nil)) - (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) - `((setq .reply-buffer. (read-reply .display. .pending-command.)) - ,reply-body))) - (when .reply-buffer. - (deallocate-reply-buffer .reply-buffer.)) - (when .pending-command. - (stop-pending-command .display. .pending-command.))))))) - -(defmacro compare-request ((index) &body body) - `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) - (write-int32 (index item) `(= ,item (read-int32 ,index))) - (write-card29 (index item) `(= ,item (read-card29 ,index))) - (write-int29 (index item) `(= ,item (read-int29 ,index))) - (write-card16 (index item) `(= ,item (read-card16 ,index))) - (write-int16 (index item) `(= ,item (read-int16 ,index))) - (write-card8 (index item) `(= ,item (read-card8 ,index))) - (write-int8 (index item) `(= ,item (read-int8 ,index)))) - (macrolet ((type-check (value type) value type nil)) - (and ,@(get-put-items index body t))))) - -(defmacro put-items ((index) &body body) - `(progn ,@(get-put-items index body t))) - -(defmacro decode-type (type value) - ;; Given an integer and type, return the value - (let ((args nil)) - (when (consp type) - (setq args (cdr type) - type (car type))) - `(macrolet ((read-card29 (value) value) - (read-card32 (value) value) - (read-int32 (value) `(card32->int32 ,value)) - (read-card16 (value) value) - (read-int16 (value) `(card16->int16 ,value)) - (read-card8 (value) value) - (read-int8 (value) `(int8->card8 ,value))) - (,(getify type) ,value ,@args)))) - -(defmacro encode-type (type value) - ;; Given a value and type, return an integer - ;; When check-p, do type checking on value - (let ((args nil)) - (when (consp type) - (setq args (cdr type) - type (car type))) - `(macrolet ((write-card29 (index value) index value) - (write-card32 (index value) index value) - (write-int32 (index value) index `(int32->card32 ,value)) - (write-card16 (index value) index value) - (write-int16 (index value) index `(int16->card16 ,value)) - (write-card8 (index value) index value) - (write-int8 (index value) index `(int8->card8 ,value))) - (check-put 0 ,value ,type ,@args)))) - -(defmacro set-decode-type (type accessor value) - `(setf ,accessor (encode-type ,type ,value))) -(defsetf decode-type set-decode-type) - - -;;; -;;; Request codes -;;; - -(defconstant +x-createwindow+ 1) -(defconstant +x-changewindowattributes+ 2) -(defconstant +x-getwindowattributes+ 3) -(defconstant +x-destroywindow+ 4) -(defconstant +x-destroysubwindows+ 5) -(defconstant +x-changesaveset+ 6) -(defconstant +x-reparentwindow+ 7) -(defconstant +x-mapwindow+ 8) -(defconstant +x-mapsubwindows+ 9) -(defconstant +x-unmapwindow+ 10) -(defconstant +x-unmapsubwindows+ 11) -(defconstant +x-configurewindow+ 12) -(defconstant +x-circulatewindow+ 13) -(defconstant +x-getgeometry+ 14) -(defconstant +x-querytree+ 15) -(defconstant +x-internatom+ 16) -(defconstant +x-getatomname+ 17) -(defconstant +x-changeproperty+ 18) -(defconstant +x-deleteproperty+ 19) -(defconstant +x-getproperty+ 20) -(defconstant +x-listproperties+ 21) -(defconstant +x-setselectionowner+ 22) -(defconstant +x-getselectionowner+ 23) -(defconstant +x-convertselection+ 24) -(defconstant +x-sendevent+ 25) -(defconstant +x-grabpointer+ 26) -(defconstant +x-ungrabpointer+ 27) -(defconstant +x-grabbutton+ 28) -(defconstant +x-ungrabbutton+ 29) -(defconstant +x-changeactivepointergrab+ 30) -(defconstant +x-grabkeyboard+ 31) -(defconstant +x-ungrabkeyboard+ 32) -(defconstant +x-grabkey+ 33) -(defconstant +x-ungrabkey+ 34) -(defconstant +x-allowevents+ 35) -(defconstant +x-grabserver+ 36) -(defconstant +x-ungrabserver+ 37) -(defconstant +x-querypointer+ 38) -(defconstant +x-getmotionevents+ 39) -(defconstant +x-translatecoords+ 40) -(defconstant +x-warppointer+ 41) -(defconstant +x-setinputfocus+ 42) -(defconstant +x-getinputfocus+ 43) -(defconstant +x-querykeymap+ 44) -(defconstant +x-openfont+ 45) -(defconstant +x-closefont+ 46) -(defconstant +x-queryfont+ 47) -(defconstant +x-querytextextents+ 48) -(defconstant +x-listfonts+ 49) -(defconstant +x-listfontswithinfo+ 50) -(defconstant +x-setfontpath+ 51) -(defconstant +x-getfontpath+ 52) -(defconstant +x-createpixmap+ 53) -(defconstant +x-freepixmap+ 54) -(defconstant +x-creategc+ 55) -(defconstant +x-changegc+ 56) -(defconstant +x-copygc+ 57) -(defconstant +x-setdashes+ 58) -(defconstant +x-setcliprectangles+ 59) -(defconstant +x-freegc+ 60) -(defconstant +x-cleartobackground+ 61) -(defconstant +x-copyarea+ 62) -(defconstant +x-copyplane+ 63) -(defconstant +x-polypoint+ 64) -(defconstant +x-polyline+ 65) -(defconstant +x-polysegment+ 66) -(defconstant +x-polyrectangle+ 67) -(defconstant +x-polyarc+ 68) -(defconstant +x-fillpoly+ 69) -(defconstant +x-polyfillrectangle+ 70) -(defconstant +x-polyfillarc+ 71) -(defconstant +x-putimage+ 72) -(defconstant +x-getimage+ 73) -(defconstant +x-polytext8+ 74) -(defconstant +x-polytext16+ 75) -(defconstant +x-imagetext8+ 76) -(defconstant +x-imagetext16+ 77) -(defconstant +x-createcolormap+ 78) -(defconstant +x-freecolormap+ 79) -(defconstant +x-copycolormapandfree+ 80) -(defconstant +x-installcolormap+ 81) -(defconstant +x-uninstallcolormap+ 82) -(defconstant +x-listinstalledcolormaps+ 83) -(defconstant +x-alloccolor+ 84) -(defconstant +x-allocnamedcolor+ 85) -(defconstant +x-alloccolorcells+ 86) -(defconstant +x-alloccolorplanes+ 87) -(defconstant +x-freecolors+ 88) -(defconstant +x-storecolors+ 89) -(defconstant +x-storenamedcolor+ 90) -(defconstant +x-querycolors+ 91) -(defconstant +x-lookupcolor+ 92) -(defconstant +x-createcursor+ 93) -(defconstant +x-createglyphcursor+ 94) -(defconstant +x-freecursor+ 95) -(defconstant +x-recolorcursor+ 96) -(defconstant +x-querybestsize+ 97) -(defconstant +x-queryextension+ 98) -(defconstant +x-listextensions+ 99) -(defconstant +x-setkeyboardmapping+ 100) -(defconstant +x-getkeyboardmapping+ 101) -(defconstant +x-changekeyboardcontrol+ 102) -(defconstant +x-getkeyboardcontrol+ 103) -(defconstant +x-bell+ 104) -(defconstant +x-changepointercontrol+ 105) -(defconstant +x-getpointercontrol+ 106) -(defconstant +x-setscreensaver+ 107) -(defconstant +x-getscreensaver+ 108) -(defconstant +x-changehosts+ 109) -(defconstant +x-listhosts+ 110) -(defconstant +x-changeaccesscontrol+ 111) -(defconstant +x-changeclosedownmode+ 112) -(defconstant +x-killclient+ 113) -(defconstant +x-rotateproperties+ 114) -(defconstant +x-forcescreensaver+ 115) -(defconstant +x-setpointermapping+ 116) -(defconstant +x-getpointermapping+ 117) -(defconstant +x-setmodifiermapping+ 118) -(defconstant +x-getmodifiermapping+ 119) -(defconstant +x-nooperation+ 127) - -;;; Some macros for threaded lists - -(defmacro threaded-atomic-push (item list next type) - (let ((x (gensym)) - (y (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x)) - (loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - (optimize (speed 3) (safety 0))) - (setf (,next ,x) ,y) - (when (conditional-store ,list ,y ,x) - (return ,x))))))) - -(defmacro threaded-atomic-pop (list next type) - (let ((y (gensym))) - `(loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - (optimize (speed 3) (safety 0))) - (if (null ,y) - (return nil) - (when (conditional-store ,list ,y (,next (the ,type ,y))) - (setf (,next (the ,type ,y)) nil) - (return ,y))))))) - -(defmacro threaded-nconc (item list next type) - (let ((first (gensym)) - (x (gensym)) - (y (gensym)) - (z (gensym))) - `(let ((,z ,item) - (,first ,list)) - (declare (type ,type ,z) - (type (or null ,type) ,first) - (optimize (speed 3) (safety 0))) - (if (null ,first) - (setf ,list ,z) - (do* ((,x ,first ,y) - (,y (,next ,x) (,next ,x))) - ((null ,y) - (setf (,next ,x) ,z) - ,first) - (declare (type ,type ,x) - (type (or null ,type) ,y))))))) - -(defmacro threaded-push (item list next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (shiftf (,next ,x) ,list ,x) - ,x))) - -(defmacro threaded-pop (list next type) - (let ((x (gensym))) - `(let ((,x ,list)) - (declare (type (or null ,type) ,x) - (optimize (speed 3) (safety 0))) - (when ,x - (shiftf ,list (,next (the ,type ,x)) nil)) - ,x))) - -(defmacro threaded-enqueue (item head tail next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (if (null ,tail) - (threaded-nconc ,x ,head ,next ,type) - (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) - (setf ,tail ,x)))) - -(defmacro threaded-dequeue (head tail next type) - (let ((x (gensym))) - `(let ((,x ,head)) - (declare (type (or null ,type) ,x) - (optimize (speed 3) (safety 0))) - (when ,x - (when (eq ,x ,tail) - (setf ,tail (,next (the ,type ,x)))) - (setf ,head (,next (the ,type ,x)))) - ,x))) - -(defmacro threaded-requeue (item head tail next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (if (null ,tail) - (setf ,tail (setf ,head ,x)) - (shiftf (,next ,x) ,head ,x)) - ,x))) - -(defmacro threaded-dolist ((variable list next type) &body body) - `(block nil - (do* ((,variable ,list (,next (the ,type ,variable)))) - ((null ,variable)) - (declare (type (or null ,type) ,variable)) - ,@body))) - -(defmacro threaded-delete (item list next type) - (let ((x (gensym)) - (y (gensym)) - (z (gensym)) - (first (gensym))) - `(let ((,x ,item) - (,first ,list)) - (declare (type ,type ,x) - (type (or null ,type) ,first) - (optimize (speed 3) (safety 0))) - (when ,first - (if (eq ,first ,x) - (setf ,first (setf ,list (,next ,x))) - (do* ((,y ,first ,z) - (,z (,next ,y) (,next ,y))) - ((or (null ,z) (eq ,z ,x)) - (when (eq ,z ,x) - (setf (,next ,y) (,next ,x)))) - (declare (type ,type ,y)) - (declare (type (or null ,type) ,z))))) - (setf (,next ,x) nil) - ,first))) - -(defmacro threaded-length (list next type) - (let ((x (gensym)) - (count (gensym))) - `(do ((,x ,list (,next (the ,type ,x))) - (,count 0 (index1+ ,count))) - ((null ,x) - ,count) - (declare (type (or null ,type) ,x) - (type array-index ,count) - (optimize (speed 3) (safety 0)))))) - diff --git a/src/clx/manager.lisp b/src/clx/manager.lisp deleted file mode 100644 index dffe3a9bb..000000000 --- a/src/clx/manager.lisp +++ /dev/null @@ -1,795 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; Window Manager Property functions - -;;; -;;; 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 wm-name (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) - -(defsetf wm-name (window) (name) - `(set-string-property ,window :WM_NAME ,name)) - -(defun set-string-property (window property string) - (declare (type window window) - (type keyword property) - (type stringable string)) - (change-property window property (string string) :STRING 8 :transform #'char->card8) - string) - -(defun wm-icon-name (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_ICON_NAME :type :STRING - :result-type 'string :transform #'card8->char)) - -(defsetf wm-icon-name (window) (name) - `(set-string-property ,window :WM_ICON_NAME ,name)) - -(defun wm-client-machine (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_CLIENT_MACHINE :type :STRING - :result-type 'string :transform #'card8->char)) - -(defsetf wm-client-machine (window) (name) - `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) - -(defun get-wm-class (window) - (declare (type window window)) - (declare (clx-values (or null name-string) (or null class-string))) - (let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8)))) - (declare (type (or null (vector card8)) value)) - (when value - (let* ((name-len (position 0 (the (vector card8) value))) - (name (subseq (the (vector card8) value) 0 name-len)) - (class - (when name-len - (subseq (the (vector card8) value) (1+ name-len) - (position 0 (the (vector card8) value) :start (1+ name-len)))))) - (values (and (plusp (length name)) (map 'string #'card8->char name)) - (and (plusp (length class)) (map 'string #'card8->char class))))))) - -(defun set-wm-class (window resource-name resource-class) - (declare (type window window) - (type (or null stringable) resource-name resource-class)) - (change-property window :WM_CLASS - (concatenate '(vector card8) - (map '(vector card8) #'char->card8 - (string (or resource-name ""))) - #(0) - (map '(vector card8) #'char->card8 - (string (or resource-class ""))) - #(0)) - :string 8) - (values)) - -(defun wm-command (window) - ;; Returns a list whose car is the command and - ;; whose cdr is the list of arguments - (declare (type window window)) - (declare (clx-values list)) - (do* ((command-string (get-property window :WM_COMMAND :type :STRING - :result-type '(vector card8))) - (command nil) - (start 0 (1+ end)) - (end 0) - (len (length command-string))) - ((>= start len) (nreverse command)) - (setq end (position 0 command-string :start start)) - (push (map 'string #'card8->char (subseq command-string start end)) - command))) - -(defsetf wm-command set-wm-command) -(defun set-wm-command (window command) - ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or - ;; equivalent), with elements of command separated by NULL characters. This - ;; enables - ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) - ;; to recover a lisp command. - (declare (type window window) - (type list command)) - (change-property window :WM_COMMAND - (apply #'concatenate '(vector card8) - (mapcan #'(lambda (c) - (list (map '(vector card8) #'char->card8 - (with-output-to-string (stream) - (with-standard-io-syntax - (prin1 c stream)))) - #(0))) - command)) - :string 8) - command) - -;;----------------------------------------------------------------------------- -;; WM_HINTS - -(def-clx-class (wm-hints) - (input nil :type (or null (member :off :on))) - (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive))) - (icon-pixmap nil :type (or null pixmap)) - (icon-window nil :type (or null window)) - (icon-x nil :type (or null card16)) - (icon-y nil :type (or null card16)) - (icon-mask nil :type (or null pixmap)) - (window-group nil :type (or null resource-id)) - (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field - ;; may be extended in the future - ) - -(defun wm-hints (window) - (declare (type window window)) - (declare (clx-values wm-hints)) - (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector))) - (when prop - (decode-wm-hints prop (window-display window))))) - -(defsetf wm-hints set-wm-hints) -(defun set-wm-hints (window wm-hints) - (declare (type window window) - (type wm-hints wm-hints)) - (declare (clx-values wm-hints)) - (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) - wm-hints) - -(defun decode-wm-hints (vector display) - (declare (type (simple-vector 9) vector) - (type display display)) - (declare (clx-values wm-hints)) - (let ((input-hint 0) - (state-hint 1) - (icon-pixmap-hint 2) - (icon-window-hint 3) - (icon-position-hint 4) - (icon-mask-hint 5) - (window-group-hint 6)) - (let ((flags (aref vector 0)) - (hints (make-wm-hints)) - (%buffer display)) - (declare (type card32 flags) - (type wm-hints hints) - (type display %buffer)) - (setf (wm-hints-flags hints) flags) - (when (logbitp input-hint flags) - (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) - (when (logbitp state-hint flags) - (setf (wm-hints-initial-state hints) - (decode-type (member :dont-care :normal :zoom :iconic :inactive) - (aref vector 2)))) - (when (logbitp icon-pixmap-hint flags) - (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) - (when (logbitp icon-window-hint flags) - (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) - (when (logbitp icon-position-hint flags) - (setf (wm-hints-icon-x hints) (aref vector 5) - (wm-hints-icon-y hints) (aref vector 6))) - (when (logbitp icon-mask-hint flags) - (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) - (when (and (logbitp window-group-hint flags) (> (length vector) 7)) - (setf (wm-hints-window-group hints) (aref vector 8))) - hints))) - - -(defun encode-wm-hints (wm-hints) - (declare (type wm-hints wm-hints)) - (declare (clx-values simple-vector)) - (let ((input-hint #b1) - (state-hint #b10) - (icon-pixmap-hint #b100) - (icon-window-hint #b1000) - (icon-position-hint #b10000) - (icon-mask-hint #b100000) - (window-group-hint #b1000000) - (mask #b1111111) - ) - (let ((vector (make-array 9 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 9) vector) - (type card16 flags)) - (when (wm-hints-input wm-hints) - (setf flags input-hint - (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) - (when (wm-hints-initial-state wm-hints) - (setf flags (logior flags state-hint) - (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) - (wm-hints-initial-state wm-hints)))) - (when (wm-hints-icon-pixmap wm-hints) - (setf flags (logior flags icon-pixmap-hint) - (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) - (when (wm-hints-icon-window wm-hints) - (setf flags (logior flags icon-window-hint) - (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) - (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) - (setf flags (logior flags icon-position-hint) - (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) - (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) - (when (wm-hints-icon-mask wm-hints) - (setf flags (logior flags icon-mask-hint) - (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) - (when (wm-hints-window-group wm-hints) - (setf flags (logior flags window-group-hint) - (aref vector 8) (wm-hints-window-group wm-hints))) - (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) - vector))) - -;;----------------------------------------------------------------------------- -;; WM_SIZE_HINTS - -(def-clx-class (wm-size-hints) - (user-specified-position-p nil :type generalized-boolean) ;; True when user specified x y - (user-specified-size-p nil :type generalized-boolean) ;; True when user specified width height - ;; the next four fields are obsolete when using a modern window manager - ;; (that will use min-width and friends instead), but they should be set by - ;; clients in case an old window manager is used - (x nil :type (or null int32)) - (y nil :type (or null int32)) - (width nil :type (or null card32)) - (height nil :type (or null card32)) - (min-width nil :type (or null card32)) - (min-height nil :type (or null card32)) - (max-width nil :type (or null card32)) - (max-height nil :type (or null card32)) - (width-inc nil :type (or null card32)) - (height-inc nil :type (or null card32)) - (min-aspect nil :type (or null number)) - (max-aspect nil :type (or null number)) - (base-width nil :type (or null card32)) - (base-height nil :type (or null card32)) - (win-gravity nil :type (or null win-gravity)) - (program-specified-position-p nil :type generalized-boolean) ;; True when program specified x y - (program-specified-size-p nil :type generalized-boolean) ;; True when program specified width height - ) - - -(defun wm-normal-hints (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) - -(defsetf wm-normal-hints set-wm-normal-hints) -(defun set-wm-normal-hints (window hints) - (declare (type window window) - (type wm-size-hints hints)) - (declare (clx-values wm-size-hints)) - (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) - hints) - -;;; OBSOLETE -(defun wm-zoom-hints (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) - -;;; OBSOLETE -(defsetf wm-zoom-hints set-wm-zoom-hints) -;;; OBSOLETE -(defun set-wm-zoom-hints (window hints) - (declare (type window window) - (type wm-size-hints hints)) - (declare (clx-values wm-size-hints)) - (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) - hints) - -(defun decode-wm-size-hints (vector) - (declare (type (or null (simple-vector *)) vector)) - (declare (clx-values (or null wm-size-hints))) - (when vector - (let ((flags (aref vector 0)) - (hints (make-wm-size-hints))) - (declare (type card16 flags) - (type wm-size-hints hints)) - (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags)) - (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags)) - (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags)) - (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags)) - (when (logbitp 4 flags) - (setf (wm-size-hints-min-width hints) (aref vector 5) - (wm-size-hints-min-height hints) (aref vector 6))) - (when (logbitp 5 flags) - (setf (wm-size-hints-max-width hints) (aref vector 7) - (wm-size-hints-max-height hints) (aref vector 8))) - (when (logbitp 6 flags) - (setf (wm-size-hints-width-inc hints) (aref vector 9) - (wm-size-hints-height-inc hints) (aref vector 10))) - (when (logbitp 7 flags) - (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) - (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) - (when (> (length vector) 15) - ;; This test is for backwards compatibility since old Xlib programs - ;; can set a size-hints structure that is too small. See ICCCM. - (when (logbitp 8 flags) - (setf (wm-size-hints-base-width hints) (aref vector 15) - (wm-size-hints-base-height hints) (aref vector 16))) - (when (logbitp 9 flags) - (setf (wm-size-hints-win-gravity hints) - (decode-type (member-vector +win-gravity-vector+) (aref vector 17))))) - ;; Obsolete fields - (when (or (logbitp 0 flags) (logbitp 2 flags)) - (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) - (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) - (when (or (logbitp 1 flags) (logbitp 3 flags)) - (setf (wm-size-hints-width hints) (aref vector 3) - (wm-size-hints-height hints) (aref vector 4))) - hints))) - -(defun encode-wm-size-hints (hints) - (declare (type wm-size-hints hints)) - (declare (clx-values simple-vector)) - (let ((vector (make-array 18 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 18) vector) - (type card16 flags)) - (when (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 0) flags) 1)) - (when (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 1) flags) 1)) - (when (wm-size-hints-program-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) - (when (wm-size-hints-program-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) - (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) - (setf (ldb (byte 1 4) flags) 1 - (aref vector 5) (wm-size-hints-min-width hints) - (aref vector 6) (wm-size-hints-min-height hints))) - (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints)) - (setf (ldb (byte 1 5) flags) 1 - (aref vector 7) (wm-size-hints-max-width hints) - (aref vector 8) (wm-size-hints-max-height hints))) - (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints)) - (setf (ldb (byte 1 6) flags) 1 - (aref vector 9) (wm-size-hints-width-inc hints) - (aref vector 10) (wm-size-hints-height-inc hints))) - (let ((min-aspect (wm-size-hints-min-aspect hints)) - (max-aspect (wm-size-hints-max-aspect hints))) - (when (and min-aspect max-aspect) - (setf (ldb (byte 1 7) flags) 1 - min-aspect (rationalize min-aspect) - max-aspect (rationalize max-aspect) - (aref vector 11) (numerator min-aspect) - (aref vector 12) (denominator min-aspect) - (aref vector 13) (numerator max-aspect) - (aref vector 14) (denominator max-aspect)))) - (when (and (wm-size-hints-base-width hints) - (wm-size-hints-base-height hints)) - (setf (ldb (byte 1 8) flags) 1 - (aref vector 15) (wm-size-hints-base-width hints) - (aref vector 16) (wm-size-hints-base-height hints))) - (when (wm-size-hints-win-gravity hints) - (setf (ldb (byte 1 9) flags) 1 - (aref vector 17) (encode-type - (member-vector +win-gravity-vector+) - (wm-size-hints-win-gravity hints)))) - ;; Obsolete fields - (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) - (unless (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) - (setf (aref vector 1) (wm-size-hints-x hints) - (aref vector 2) (wm-size-hints-y hints))) - (when (and (wm-size-hints-width hints) (wm-size-hints-height hints)) - (unless (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) - (setf (aref vector 3) (wm-size-hints-width hints) - (aref vector 4) (wm-size-hints-height hints))) - (setf (aref vector 0) flags) - vector)) - -;;----------------------------------------------------------------------------- -;; Icon_Size - -;; Use the same intermediate structure as WM_SIZE_HINTS - -(defun icon-sizes (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector))) - (declare (type (or null (simple-vector 6)) vector)) - (when vector - (make-wm-size-hints - :min-width (aref vector 0) - :min-height (aref vector 1) - :max-width (aref vector 2) - :max-height (aref vector 3) - :width-inc (aref vector 4) - :height-inc (aref vector 5))))) - -(defsetf icon-sizes set-icon-sizes) -(defun set-icon-sizes (window wm-size-hints) - (declare (type window window) - (type wm-size-hints wm-size-hints)) - (let ((vector (vector (wm-size-hints-min-width wm-size-hints) - (wm-size-hints-min-height wm-size-hints) - (wm-size-hints-max-width wm-size-hints) - (wm-size-hints-max-height wm-size-hints) - (wm-size-hints-width-inc wm-size-hints) - (wm-size-hints-height-inc wm-size-hints)))) - (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32) - wm-size-hints)) - -;;----------------------------------------------------------------------------- -;; WM-Protocols - -(defun wm-protocols (window) - (map 'list #'(lambda (id) (atom-name (window-display window) id)) - (get-property window :WM_PROTOCOLS :type :ATOM))) - -(defsetf wm-protocols set-wm-protocols) -(defun set-wm-protocols (window protocols) - (change-property window :WM_PROTOCOLS - (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) - protocols) - :ATOM 32) - protocols) - -;;----------------------------------------------------------------------------- -;; WM-Colormap-windows - -(defun wm-colormap-windows (window) - (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW - :transform #'(lambda (id) - (lookup-window (window-display window) id))))) - -(defsetf wm-colormap-windows set-wm-colormap-windows) -(defun set-wm-colormap-windows (window colormap-windows) - (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32 - :transform #'window-id) - colormap-windows) - -;;----------------------------------------------------------------------------- -;; Transient-For - -(defun transient-for (window) - (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list))) - (and prop (lookup-window (window-display window) (car prop))))) - -(defsetf transient-for set-transient-for) -(defun set-transient-for (window transient) - (declare (type window window transient)) - (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32) - transient) - -;;----------------------------------------------------------------------------- -;; Set-WM-Properties - -(defun set-wm-properties (window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints zoom-hints - ;; the following are used for wm-normal-hints - (user-specified-position-p nil usppp) - (user-specified-size-p nil usspp) - (program-specified-position-p nil psppp) - (program-specified-size-p nil psspp) - x y width height min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group) - ;; Set properties for WINDOW. - (declare (arglist window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints - ;; the following are used for wm-normal-hints - user-specified-position-p user-specified-size-p - program-specified-position-p program-specified-size-p - min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group)) - (declare (type window window) - (type (or null stringable) name icon-name resource-name resource-class client-machine) - (type (or null list) command) - (type (or null wm-hints) hints) - (type (or null wm-size-hints) normal-hints zoom-hints) - (type generalized-boolean user-specified-position-p user-specified-size-p) - (type generalized-boolean program-specified-position-p program-specified-size-p) - (type (or null int32) x y) - (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) - (type (or null win-gravity) win-gravity) - (type (or null number) min-aspect max-aspect) - (type (or null (member :off :on)) input) - (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) - (type (or null pixmap) icon-pixmap icon-mask) - (type (or null window) icon-window) - (type (or null card32) icon-x icon-y) - (type (or null resource-id) window-group) - (dynamic-extent options)) - (when name (setf (wm-name window) name)) - (when icon-name (setf (wm-icon-name window) icon-name)) - (when client-machine (setf (wm-client-machine window) client-machine)) - (when (or resource-name resource-class) - (set-wm-class window resource-name resource-class)) - (when command (setf (wm-command window) command)) - ;; WM-HINTS - (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window - :icon-x :icon-y :icon-mask :window-group)) - (when (getf options arg) (return t))) - (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) - (when input (setf (wm-hints-input wm-hints) input)) - (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) - (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) - (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) - (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) - (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) - (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) - (when window-group (setf (wm-hints-window-group wm-hints) window-group)) - (setf (wm-hints window) wm-hints)) - (when hints (setf (wm-hints window) hints))) - ;; WM-NORMAL-HINTS - (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height - :width-inc :height-inc :min-aspect :max-aspect - :user-specified-position-p :user-specified-size-p - :program-specified-position-p :program-specified-size-p - :base-width :base-height :win-gravity)) - (when (getf options arg) (return t))) - (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) - (when x (setf (wm-size-hints-x size) x)) - (when y (setf (wm-size-hints-y size) y)) - (when width (setf (wm-size-hints-width size) width)) - (when height (setf (wm-size-hints-height size) height)) - (when min-width (setf (wm-size-hints-min-width size) min-width)) - (when min-height (setf (wm-size-hints-min-height size) min-height)) - (when max-width (setf (wm-size-hints-max-width size) max-width)) - (when max-height (setf (wm-size-hints-max-height size) max-height)) - (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) - (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) - (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) - (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) - (when base-width (setf (wm-size-hints-base-width size) base-width)) - (when base-height (setf (wm-size-hints-base-height size) base-height)) - (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) - (when usppp - (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) - (when usspp - (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) - (when psppp - (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) - (when psspp - (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) - (setf (wm-normal-hints window) size)) - (when normal-hints (setf (wm-normal-hints window) normal-hints))) - (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) - ) - -;;; OBSOLETE -(defun set-standard-properties (window &rest options) - (declare (dynamic-extent options)) - (apply #'set-wm-properties window options)) - -;;----------------------------------------------------------------------------- -;; WM Control - -(defun iconify-window (window screen) - (declare (type window window) - (type screen screen)) - (let ((root (screen-root screen))) - (declare (type window root)) - (send-event root :client-message '(:substructure-redirect :substructure-notify) - :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) - -(defun withdraw-window (window screen) - (declare (type window window) - (type screen screen)) - (unmap-window window) - (let ((root (screen-root screen))) - (declare (type window root)) - (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) - :window window :event-window root :configure-p nil))) - - -;;----------------------------------------------------------------------------- -;; Colormaps - -(def-clx-class (standard-colormap (:copier nil) (:predicate nil)) - (colormap nil :type (or null colormap)) - (base-pixel 0 :type pixel) - (max-color nil :type (or null color)) - (mult-color nil :type (or null color)) - (visual nil :type (or null visual-info)) - (kill nil :type (or (member nil :release-by-freeing-colormap) - drawable gcontext cursor colormap font))) - -(defun rgb-colormaps (window property) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) - (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) - (declare (type (or null simple-vector) prop)) - (when prop - (list (make-standard-colormap - :colormap (lookup-colormap (window-display window) (aref prop 0)) - :base-pixel (aref prop 7) - :max-color (make-color :red (card16->rgb-val (aref prop 1)) - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - :mult-color (make-color :red (card16->rgb-val (aref prop 2)) - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))) - :visual (and (<= 9 (length prop)) - (visual-info (window-display window) (aref prop 8))) - :kill (and (<= 10 (length prop)) - (let ((killid (aref prop 9))) - (if (= killid 1) - :release-by-freeing-colormap - (lookup-resource-id (window-display window) killid))))))))) - -(defsetf rgb-colormaps set-rgb-colormaps) -(defun set-rgb-colormaps (window property maps) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type list maps)) - (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) - (index -1)) - (dolist (map maps) - (setf (aref prop (incf index)) - (encode-type colormap (standard-colormap-colormap map))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (standard-colormap-base-pixel map)) - (setf (aref prop (incf index)) - (visual-info-id (standard-colormap-visual map))) - (setf (aref prop (incf index)) - (let ((kill (standard-colormap-kill map))) - (etypecase kill - (symbol - (ecase kill - ((nil) 0) - ((:release-by-freeing-colormap) 1))) - (drawable (drawable-id kill)) - (gcontext (gcontext-id kill)) - (cursor (cursor-id kill)) - (colormap (colormap-id kill)) - (font (font-id kill)))))) - (change-property window property prop :RGB_COLOR_MAP 32))) - -;;; OBSOLETE -(defun get-standard-colormap (window property) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) - (declare (clx-values colormap base-pixel max-color mult-color)) - (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) - (declare (type (or null simple-vector) prop)) - (when prop - (values (lookup-colormap (window-display window) (aref prop 0)) - (aref prop 7) ;Base Pixel - (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))))))) - -;;; OBSOLETE -(defun set-standard-colormap (window property colormap base-pixel max-color mult-color) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type colormap colormap) - (type pixel base-pixel) - (type color max-color mult-color)) - (let ((prop (vector (encode-type colormap colormap) - (encode-type rgb-val (color-red max-color)) - (encode-type rgb-val (color-red mult-color)) - (encode-type rgb-val (color-green max-color)) - (encode-type rgb-val (color-green mult-color)) - (encode-type rgb-val (color-blue max-color)) - (encode-type rgb-val (color-blue mult-color)) - base-pixel))) - (change-property window property prop :RGB_COLOR_MAP 32))) - -;;----------------------------------------------------------------------------- -;; Cut-Buffers - -(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) - (transform #'card8->char) (start 0) end) - ;; Return the contents of cut-buffer BUFFER - (declare (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type array-index start) - (type (or null array-index) end) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) - (declare (clx-values sequence type format bytes-after)) - (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) - (get-property root property :type type :result-type result-type - :start start :end end :transform transform))) - -;; Implement the following: -;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) -;; (transform #'char->card8) (start 0) end) (data) -;; In order to avoid having to pass positional parameters to set-cut-buffer, -;; We've got to do the following. WHAT A PAIN... -#-clx-ansi-common-lisp -(define-setf-method cut-buffer (display &rest option-list) - (declare (dynamic-extent option-list)) - (do* ((options (copy-list option-list)) - (option options (cddr option)) - (store (gensym)) - (dtemp (gensym)) - (temps (list dtemp)) - (values (list display))) - ((endp option) - (values (nreverse temps) - (nreverse values) - (list store) - `(set-cut-buffer ,store ,dtemp ,@options) - `(cut-buffer ,@options))) - (unless (member (car option) '(:buffer :type :format :start :end :transform)) - (error "Keyword arg ~s isn't recognized" (car option))) - (let ((x (gensym))) - (push x temps) - (push (cadr option) values) - (setf (cadr option) x)))) - -(defun - #+clx-ansi-common-lisp (setf cut-buffer) - #-clx-ansi-common-lisp set-cut-buffer - (data display &key (buffer 0) (type :STRING) (format 8) - (start 0) end (transform #'char->card8)) - (declare (type sequence data) - (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type (member 8 16 32) format) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (integer) t)) transform)) - (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) - (change-property root property data type format :transform transform :start start :end end) - data)) - -(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) - ;; Positive rotates left, negative rotates right (opposite of actual protocol request). - ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. - (declare (type display display) - (type int16 delta) - (type generalized-boolean careful-p)) - (let* ((root (screen-root (first (display-roots display)))) - (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 - :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) - (when careful-p - (let ((props (list-properties root))) - (dotimes (i 8) - (unless (member (aref buffers i) props) - (setf (cut-buffer display :buffer i) ""))))) - (rotate-properties root buffers delta))) - diff --git a/src/clx/manual/clx.texinfo b/src/clx/manual/clx.texinfo deleted file mode 100644 index a0b52e7cd..000000000 --- a/src/clx/manual/clx.texinfo +++ /dev/null @@ -1,18312 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c $Id: clx.texinfo,v 1.3 2004/11/18 12:01:48 dan Exp $ -@c %**start of header -@setfilename clx.info -@settitle Common LISP X Interface -@setchapternewpage odd -@c %**end of header - -@dircategory lisp -@direntry -* CLX: (clx). Common LISP X Interface -@end direntry - -@copying -The Common LISP X Interface (CLX) - -Copyright @copyright{} 1988, 1989 Texas Instruments Incorporated - -@quotation -Permission is granted to any individual or institution to use, copy, -modify and distribute this document, provided that this complete -copyright and permission notice is maintained, intact, in all copies -and supporting documentation. Texas Instruments Incorporated makes no -representations about the suitability of this document or the software -described herein for any purpose. It is provided "as is" without -express or implied warranty. -@end quotation - -@end copying - -@titlepage -@title The Common Lisp X Interface (CLX) - -@page -@vskip 0pt plus 1filll -@insertcopying -@end titlepage - -@contents - -@ifnottex -@node Top, Acknowledgments, (dir), (dir) -@top The Common LISP X Interface (CLX) - -@insertcopying -@end ifnottex - -@menu -* Acknowledgments:: -* Introduction to CLX:: -* Displays:: -* Screens:: -* Windows and Pixmaps:: -* Graphics Contexts:: -* Graphic Operations:: -* Images:: -* Font and Characters:: -* Colors:: -* Cursors:: -* Atoms:: -* Events and Input:: -* Resources:: -* Control Functions:: -* Extensions:: -* Errors:: -* Undocumented:: -* Glossary:: -* Function Index:: -* Type Index:: - -@detailmenu - --- The Detailed Node Listing --- - -Introduction to CLX - -* The X Window System:: -* A Quick Tour of CLX:: -* Naming and Argument Conventions:: -* Programming Considerations:: -* Data Types:: - -The X Window System - -* Windows:: -* Input Events:: - -A Quick Tour of CLX - -* A Simple Menu:: -* Displaying the Menu:: -* Menu Input:: -* The Main Program:: -* Debugging With CLX:: - -Displays - -* Opening the Display:: -* Display Attributes:: -* Managing the Output Buffer:: -* Closing the Display:: - -Screens - -* Screens and Visuals:: -* Screen Attributes:: - -Windows and Pixmaps - -* Drawables:: -* Creating Windows:: -* Window Attributes:: -* Stacking Order:: -* Window Hierarchy:: -* Mapping Windows:: -* Destroying Windows:: -* Pixmaps:: - -Graphics Contexts - -* Creating Graphics Contexts:: -* Graphics Context Attributes:: -* Copying Graphics Contexts:: -* Destroying Graphics Contexts:: -* Graphics Context Cache:: - -Graphic Operations - -* Area and Plane Operations:: -* Drawing Points:: -* Drawing Lines:: -* Drawing Rectangles:: -* Drawing Arcs:: -* Drawing Text:: - -Images - -* Image Types:: -* Image Functions:: -* Image Files:: -* Direct Image Transfer:: - -Image Types - -* Basic Images:: -* XY-Format Images:: -* Z-Format Images:: - -Font and Characters - -* Opening Fonts:: -* Listing Fonts:: -* Font Attributes:: -* Chracter Attributes:: -* Querying Text Size:: - -Colors - -* Colormaps and Colors:: -* Color Functions:: -* Colormap Functions:: - -Colormap Functions - -* Creating Colormaps:: -* Installing Colormaps:: -* Allocating Colors:: -* Finding Colors:: -* Changing Colors:: -* Colormap Attributes:: - -Cursors - -* Creating Cursors:: -* Cursor Functions:: -* Cursor Attributes:: - -Atoms, Properties and Selections - -* Atoms (Atoms):: -* Properties:: -* Selections:: - -Events and Input - -* Selecting Events:: -* Processing Events:: -* Managing the Event Queue:: -* Sending Events:: -* Pointer Position:: -* Managing Input Focus:: -* Grabbing the Pointer:: -* Grabbing a Button:: -* Grabbing the Keyboard:: -* Grabbing a Key:: -* Event Types:: -* Releasing Queued Events:: - -Event Types - -* Keyboard and Pointer Events:: -* Input Focus Events:: -* Keyboard and Pointer State Events:: -* Exposure Events:: -* Window State Events:: -* Structure Control Events:: -* Client Communications Events:: -* Declaring Event Types:: - -Resources - -* Resource Binings:: -* Basic Resource Database Functions:: -* Accessing Resource Values:: -* Resource Database Files:: - -Accessing Resource Values - -* Complete Names and Classes:: -* Matching Resource Names:: -* Resource Access Functions:: - -Control Functions - -* Grabbing the Server:: -* Pointer Control:: -* Keyboard Control:: -* Keyboard Encodings:: -* Client Termination:: -* Managing Host Access:: -* Screen Saver:: - -Keyboard Encodings - -* Keycodes and Keysyms:: -* Keyboard Mapping:: -* Using Keycodes and Keysyms:: - -Extensions - -* Extensions (Extensions):: -* SHAPE - The X11 Nonrectangular Window Shape Extension:: -* RENDER - A new rendering system for X11:: -* DPMS - The X11 Display Power Management Signaling Extension:: -* BIG-REQUESTS - Big Requests Extension:: - -RENDER - A new rendering system for X11 - -* Picture formats:: -* The picture object:: -* Glyphs and Glyphsets:: -* Using glyphs:: -* Errors (Extensions):: - -Errors - -* Introduction (Errors):: - -@end detailmenu -@end menu - -@node Acknowledgments, Introduction to CLX, Top, Top -@chapter Acknowledgments - -Primary Interface Author: - -Robert W. Scheifler - -@display -MIT Laboratory for Computer Science -545 Technology Square, Room 418 -Cambridge, MA 02139 -@email{rws@@zermatt.lcs.mit.edu} -@end display - -Primary Implementation Author: - -LaMott Oren - -@display -Texas Instruments -PO Box 655474, MS 238 -Dallas, TX 75265 -@email{oren@@csc.ti.com} -@end display - - - -Design Contributors: - -@itemize @bullet -@item Dan Cerys, BBN -@item Scott Fahlman, CMU -@item Kerry Kimbrough, Texas Instruments -@item Chris Lindblad, MIT -@item Rob MacLachlan, CMU -@item Mike McMahon, Symbolics -@item David Moon, Symbolics -@item LaMott Oren, Texas Instruments -@item Daniel Weinreb, Symbolics -@item John Wroclawski, MIT -@item Richard Zippel, Symbolics -@end itemize - -Documentation Contributors: - -@itemize @bullet -@item Keith Cessna, Texas Instruments -@item Kerry Kimbrough, Texas Instruments -@item Mike Myjak -@item LaMott Oren, Texas Instruments -@item Dan Stenger, Texas Instruments -@end itemize - -The X Window System is a trademark of MIT. - -UNIX is a trademark of AT&T Bell Laboratories. - -ULTRIX, ULTRIX-32, ULTRIX-32m, ULTRIX-32w, and VAX/VMS are trademarks of Digital Equipment -Corporation. - -@node Introduction to CLX, Displays, Acknowledgments, Top -@chapter Introduction to CLX - -This manual assumes a basic understanding of window systems and the Common Lisp programming -language. To provide an introduction to the Common Lisp X Interface (CLX) programming, this -section discusses the following: - -@itemize @bullet -@item Overview of the X Window System -@item Naming and argument conventions -@item Programming considerations -@end itemize - -@menu -* The X Window System:: -* A Quick Tour of CLX:: -* Naming and Argument Conventions:: -* Programming Considerations:: -* Data Types:: -@end menu - -@node The X Window System, A Quick Tour of CLX, Introduction to CLX, Introduction to CLX -@section The X Window System - -The X Window System was developed at the Massachusetts Institute of -Technology (MIT) and first released in 1985. Since then, the X Window -System has become an industry-standard product available on virtually -every type of bit-mapped workstation. The current version of X, -Version 11, has been implemented for several different computer -architectures, for a wide variety of display hardware, and also for -many different operating systems. X Version 11 represents the -fulfillment of the original design goals proposed by MIT, as follows: - -@table @asis -@item Portable -Support virtually any bitmap display and any interactive input device -(including keyboards, mice, tablets, joysticks, and touch screens). -Make it easy to implement the window system on different operating -systems. - -@item Device-Independent Applications -Avoid rewriting, recompiling, or even relinking in order to use -different display/input hardware. Make it easy for an application to -work on both monochrome and color hardware. - -@item Network Transparent -Let an application run on one computer while using another computer's -display, even if the other computer has a different operating system -or hardware architecture. - -@item Multitasking -Support multiple applications being displayed simultaneously. - -@item No User Interface Policy - -Since no one agrees on what constitutes the best user interface, make -it possible for a broad range of user interface styles (or policies) -to be implemented, external to the window system and to the -application programs. - -@item Cheap Windows -Windows should be abundant, and ubiquitous. Provide overlapping -windows and a simple mechanism for window hierarchy. - -@item High-Performance Graphics -Provide powerful interfaces for synthesizing 2-D images (geometric -primitives, high-quality text with multiple typefaces, and scanned -images). - -@item Extensible -Include a mechanism for adding new capabilities. Allow separate sites -to develop independent extensions without becoming incompatible with -remote applications. -@end table - -Some of these goals lead directly to the basic X architecture -- the -client-server model. The basic window system is implemented by the X -@emph{server} program. An application program (the @emph{client}) -sends window system @emph{requests} to the X server through a reliable -two-way byte-stream. - -In general, the server and the client can be executing on separate -host computers, in which case the byte-stream is implemented via some -network protocol (TCP, DECnet(tm), Chaosnet, and so -forth). The X server, which is connected to several client programs -running concurrently, executes client requests in round-robin -fashion. The server is responsible for drawing client graphics on the -display screen and for making sure that graphics output to a window -stays inside its boundary. - -The other primary job of the X server is to channel input from the -keyboard, pointer, and other input devices back to the appropriate -client programs. Input arrives at the client asynchronously in the -form of input @emph{events} representing up/down transitions of keys -or pointer buttons, changes in the pointer position, and so on. In -some cases, a request generates a return value (or @emph{reply}) from -the server, which is another kind of client input. Replies and input -events are received via the same byte-stream connecting the client -with the server. - -@menu -* Windows:: -* Input Events:: -@end menu - -@node Windows, Input Events, The X Window System, The X Window System -@subsection Windows - -The X Window System supports one or more screens containing -overlapping windows and subwindows. A @emph{screen} is a physical -monitor and hardware, which can be either color or black and -white. There can be multiple screens per display workstation. A single -server can provide display services for any number of screens. A set -of screens for a single user with one keyboard and one mouse is called -a @emph{display}. - -All windows in an X server are arranged in a strict hierarchy. At the -top of the hierarchy are the @emph{root windows}, which cover each of -the display screens. Each root window is either partially or -completely covered by child windows. All windows, except for root -windows, have parents. Any window can in turn have its own -children. In this way, an application program can create a window tree -of arbitrary depth on each screen. - -A child window can be larger than its parent. That is, part or all of -the child window can extend beyond the boundaries of the parent. -However, all output to a window is clipped by the boundaries of its -parent window. If several children of a window have overlapping -locations, one of the children is considered to be on top of/or raised -over the others, @emph{obscuring} them. Window output to areas that -are covered by other windows is suppressed. - -A window has a border that is zero or more pixels in width and can be -any pattern (pixmap) or solid color. A window usually has a background -pattern that is drawn by the X server. Each window has its own -coordinate system. Child windows obscure their parents unless the -child windows have no background. Graphics operations in the parent -window are usually clipped by the children. - -X also provides objects called @emph{pixmaps} for off-screen storage -of graphics. Single-plane pixmaps (that is, of depth 1) are sometimes -referred to as @emph{bitmaps}. Both pixmaps and windows can be used -interchangeably in most graphics functions. Pixmaps are also used in -various graphics operations to define patterns, or -@emph{tiles}. Windows and pixmaps together are referred to as -@emph{drawables}. - -@node Input Events, , Windows, The X Window System -@subsection Input Events - -The X input mechanism is conceptually simple yet quite powerful. Most -events are attached to a particular window (that is, contain an -identifier for the window receiving the event). A client program can -receive multiple window input streams, all multiplexed over the single -byte-stream connection to the server. - -Clients can tailor their input by expressing interest in only certain -event types. The server uses special event types to send important -messages to the client. For example, the client can elect to receive -an @var{:enter-notify} -(@pxref{:enter-notify}) event -when the pointer cursor moves into a certain window. Another vital -message from the server is an @var{:exposure} -(@pxref{:exposure}) event. This is a -signal to the client indicating that at least some portion of the -window has suddenly become visible (perhaps the user moved another -window which had been overlapping it). The client is then responsible -for doing what is necessary to redisplay the window's image. Client -programs must be prepared to regenerate the contents of windows in -this way on demand. - -Input is also subject to policy decisions about which client window -receives keyboard and pointer events. Since the pointer is free to roam -between windows, just clicking on a window is often enough to send a -pointer event to that window. Keyboard events, however, must go to a -keyboard focus window which has to be designated in some other way. -Usually, the arbiter of such input management policy is a program called -the @emph{window manager}. The window manager gives the human -user a way to make a window the keyboard focus, to manage the layout of -windows on the screen, to represent windows with icons, and so forth. In -fact, the window manager client determines most of the so-called look -and feel of the X Window System. - -@node A Quick Tour of CLX, Naming and Argument Conventions, The X Window System, Introduction to CLX -@section A Quick Tour of CLX - -The X Window System is defined by the X Window System Protocol -Specification, a detailed description of the encoding and the meaning of -requests and events sent between a client and a server. This standard -protocol does not depend on any particular programming language. As a -result, each programming language must define its own functional -interface for using the X protocol. The standard X interface used by -Common Lisp programmers is called CLX. CLX is a set of data types, -functions, and macros which allow a Common Lisp client program to -interact with an X server to send requests and to receive input events -and replies. - -For the most part, CLX functions are closely tied to the underlying -requests in the X protocol. Many CLX functions simply add requests to an -output buffer. These requests later execute asynchronously on the X -display server. However, some functions of CLX lie outside the scope of -the protocol--for example, reading events and managing a clientside -event queue. CLX is also responsible for important batching and caching -tasks that minimize network communication. - -The following paragraphs show an example of a CLX client program. All -CLX functions and macros are shown in upper case. Note that some of the -terms used are unique to X, while other terms that are common to other -window systems have different meanings in X. It may be helpful to refer -to the glossary when you are uncertain of a term's meaning in the -context of the X Window System. - -@menu -* A Simple Menu:: -* Displaying the Menu:: -* Menu Input:: -* The Main Program:: -* Debugging With CLX:: -@end menu - -@node A Simple Menu, Displaying the Menu, A Quick Tour of CLX, A Quick Tour of CLX -@subsection A Simple Menu - -The example client program creates and displays a simple pop-up menu -consisting of a column of strings--a title string followed by selectable -menu item strings. The implementation uses one window to represent the -entire menu, plus a set of subwindows, one for each menu item. Here is -the definition of a structure which represents such a menu. - -@lisp -(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 if unchanged since displayed -@end lisp - - -The @code{window} slot will contain the -@var{window} (@pxref{window}) -object that represents the menu. The @code{item-} -@code{alist} represents the relationship between the menu items -and their associated subwindows. Each entry in @code{item-alist} -is a list whose first element is a (sub)window object and whose second -element is the corresponding item string. A -@var{window} (@pxref{window}) -object is an instance of a CLX-defined data type which represents X -windows. A -@var{window} (@pxref{window}) -object actually carries two pieces of information: an X window ID -integer and a -@var{display} (@pxref{display}) -object. A -@var{display} (@pxref{display}) -is another CLX-defined data type that represents a connection to a -specific X display server. The @code{gcontext} slot contains an -instance of a CLX data type known as a @emph{graphics context}. A -graphics context is a set of display attribute values, such as -foreground color, fill style, line style, text font, and so forth. Each -X graphics request (and hence each CLX graphics function call) must -supply a graphics context to use in displaying the request. The menu's -@code{gcontext} will thus hold all of the attribute values used -during menu display. - -The first thing to do is make an instance of a @code{menu} object: - -@lisp -(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)))) -@end lisp - -@var{create-window} (@pxref{create-window}) -is one of the most important CLX functions, since it creates and returns -a @var{window} (@pxref{window}) -object. Several of its options are shown here. The default window class -is @var{:input-output}, but X provides for @var{:input-only} windows, -too. Every window must have a parent window, except for a system-defined -@emph{root window}, which represents an entire display screen. The -@var{:event-mask} keyword value, a CLX -@var{event-mask} (@pxref{event-mask}) -data type, says that an input event will be received for the menu window -when the window is exposed and also when the pointer cursor leaves the -window. The window border is a pattern-filled or (as in this case) a -solid-colored boundary which is maintained automatically by the X -server; a client cannot draw in a window's border, since all graphics -requests are relative to the origin (upper-left corner) of the window's -interior and are clipped by the server to this inside region. Turning on -the @var{:save-under} option is a hint to the X server that, when this -window is made visible, it may be more efficient to save the pixels it -obscures, rather than require several client programs to refresh their -windows when the pop-up menu disappears. This is a way to work around -X's client-managed refresh policy when only a small amount of screen -space is needed temporarily. - -Why is @var{:override-redirect} turned on for the menu window? This is -actually a little unusual, because it prevents any window manager client -from @emph{redirecting} the position of the menu when it is popped up. -Remember that the window manager represents the user's policy for -controlling the positions of his windows, so this kind of redirection is -ordinarily correct. However, in this case, as a favor to the user, the -menu avoids redirection in order to pop up the menu at a very specific -location; that is, under the pointer cursor. - -What about the item subwindows? The @code{menu-set-item-list} -function in the following example creates them whenever the menu's item -list is changed. The upper-left x and y coordinates and the width and -height are not important yet, because they are computed just before the -menu is displayed. This function also calls -@var{create-window} (@pxref{create-window}), -demonstrating the equal treatment of parent and children windows in the -X window hierarchy. - -@lisp -(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))))) -@end lisp - -@node Displaying the Menu, Menu Input, A Simple Menu, A Quick Tour of CLX -@subsection Displaying the Menu - -The @code{menu-recompute-geometry} function (shown in the -following example) handles the job of calculating the size of the menu, -based on its current item list and its current text font. CLX provides a -way to inquire the geometrical properties of a font object (for example, -its ascent and descent from the baseline) and also a -@var{text-extents} (@pxref{text-extents}) -function. -@var{text-extents} (@pxref{text-extents}) -returns the geometry of a given string as displayed in a given font. -Notice the use of the -@var{with-state} (@pxref{with-state}) -macro when setting a window's geometry attributes. CLX strives to -preserve the familiar @code{setf} style of accessing individual window -attributes, even though an attribute access actually involves sending a -request to a (possibly remote) server and/or waiting for a reply. -@var{with-state} (@pxref{with-state}) -tells CLX to batch together all read and write accesses to a given -window, using a local cache to minimize the number of server requests. -This CLX feature can result in a dramatic improvement in client -performance without burdening the programmer interface. - -@code{menu-recompute-geometry} causes all the item subwindows to -become @emph{mapped}. Mapping a window means attempting to make it -visible on the screen. However, a subwindow will not actually be -@emph{visible} until it and all of its ancestors are mapped. Even then, -another window might be covering up the subwindow. - -@lisp -(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) - *menu-item-margin*)) - (item-width 0) - (items (menu-item-alist menu)) - menu-width) - - ;; Find max item string width - (setf item-width - (+ *menu-item-margin* - (dolist (next-item items item-width) - (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*))) - (let ((window (menu-window menu))) - - ;; Update width and height of menu window - (WITH-STATE (window) - (setf (DRAWABLE-WIDTH window) menu-width - (DRAWABLE-HEIGHT window) (* (1+ (length items)) item-height))) - - ;; Update width, height, position of item windows - (let ((item-left (round (- menu-width item-width) 2)) - (next-item-top (- item-height (round *menu-item-margin* 2)))) - (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 item-height)))) - - ;; 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)))) -@end lisp - -Of course, the sample client must know how to draw/redraw the menu and -its items, so the function @code{menu-refresh} is defined next to -handle that task (shown in the following example). Note that the -location of window output is given relative to the window origin. -Windows and subwindows have different coordinate systems. The location -of the origin (upper-left corner) of a subwindow's coordinate system is -given with respect to its parent window's coordinate system. Negative -coordinates are valid, although only output to the +x/+y quadrant of a -window's coordinate system will ever be visible. - -@lisp -(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) - (let ((box-margin (round *menu-item-margin* 2))) - (dolist (item (menu-item-alist menu)) - (DRAW-IMAGE-GLYPHS - (first item) gcontext - box-margin ;start x - (+ baseline-y box-margin) ;start y - (second item)))))) -@end lisp - -@var{with-gcontext} (@pxref{with-gcontext}) -is a CLX macro that allows you temporarily to modify a graphics context -within the dynamic scope of the macro body. -@var{draw-image-glyphs} (@pxref{draw-image-glyphs}) -is a CLX text drawing function which produces a terminal-like rendering: -foreground character on a background block. (More sophisticated text -rendering functions are also available.) The strange use of -@emph{glyphs} instead of @emph{string} here actually highlights an -important fact: X and Common Lisp have totally different concepts of a -character. A Common Lisp character is an object whose implementation can -comprehend a vast universe of text complexities (typefaces, type styles, -international character sets, symbols, and so forth). However, to X, a -string is just a sequence of integer indexes into the array of bitmaps -represented by a CLX font object. In general, -@var{draw-image-glyphs} (@pxref{draw-image-glyphs}), -@var{text-extents} (@pxref{text-extents}), -and other CLX text functions accept a @var{:translate} keyword -argument. Its value is a function which translates the characters of a -string argument into the appropriate font-and-index pairs needed by CLX. -This example relies upon the default translation function, which simply -uses @var{char-code} to compute an index into the current font. - -@node Menu Input, The Main Program, Displaying the Menu, A Quick Tour of CLX -@subsection Menu Input - -Now that a menu can be displayed, the sample client program must define -how the menu will process user input. The @code{menu-choose} -function (shown in the following example) has the classic structure of -an X client program. First, do some initialization (for example, present -the menu at a given location). Then, enter an input event loop. Read an -input event, process it, and repeat the loop until a termination event -is received. The -@var{event-case} (@pxref{event-case}) -macro continues reading an event from the menu window's display object -until one of its clauses returns non-@var{nil}. These clauses specify -the action to be taken for each event type and also bind values from the -event report to local variables, such as the @var{event-window} -receiving the event. Notice that the @var{:force-output-p} option is -enabled, causing -@var{event-case} (@pxref{event-case}) -to begin by sending any client requests which CLX has not yet output to -the server. To improve performance, CLX quietly queues up requests and -periodically sends them off in a batch. However, in an interactive -feedback loop such as this, it is important to keep the display crisply -up-to-date. - -@lisp -(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 - (menu-highlight-item menu (find window items :key #'first)) - 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 - (menu-unhighlight-item menu (find window items :key #'first))) - 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))) -@end lisp - -The event loop in @code{menu-choose} demonstrates an idiom used in -all X programs: the contents of a window are displayed (in this case, by -calling @code{menu-refresh}) only when an -@var{:exposure} (@pxref{:exposure}) -event is received, signaling that the server has actually made the -window @emph{viewable}. The handling of -@var{:exposure} (@pxref{:exposure}) -in @code{menu-choose} also implements a little trick for improving -efficiency. In general, when a window is exposed after being previously -obscured (perhaps only partially), the server is free to send several -@var{:exposure} (@pxref{:exposure}) -events, one for each rectangular tile of the exposed region. For small -windows like this menu, it is not worth the trouble to redraw the image -one tile at a time. So the code above just ignores all but the last tile -exposure and redraws everything in one call to -@code{menu-refresh}. - -@node The Main Program, Debugging With CLX, Menu Input, A Quick Tour of CLX -@subsection The Main Program - -After all the preceding build-up and the other functions referenced -(but not shown here) have been implemented, the code for the main -client program is very small. - -@lisp -(defun just-say-lisp (host &optional (font-name "fg-16")) - (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (nice-font (OPEN-FONT display font-name)) - - ;; Create a menu as a child of the root window. - (a-menu (create-menu (SCREEN-ROOT screen) - 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 - (loop - ;; Determine the current root window position of the pointer - (multiple-value-bind (x y) (QUERY-POINTER (SCREEN-ROOT screen)) - - (let ((choice (menu-choose a-menu x y))) - (when (string-equal "Lisp" choice) - (return))))) - - (CLOSE-DISPLAY display)))) -@end lisp - -Note that the main program event loop lies in the body of an -@var{unwind-protect} form. This is a good programming technique -because, without this protection, an unexpected error could cause the -program to terminate without freeing the @emph{server resources} it has -created. Server resources are CLX objects which refer to objects -actually stored on the X server. Examples of these are -@var{window} (@pxref{window}), -@var{font} (@pxref{font}), -@var{pixmap} (@pxref{pixmap}), -@var{cursor} (@pxref{cursor}), -@var{colormap} (@pxref{colormap}), -and -@var{gcontext} (@pxref{gcontext}) -objects. These server resources are created and destroyed by user -requests. Server resources created by a client are also destroyed when -its display connection is closed. If client resources are repeatedly -created without being destroyed, then the server will eventually run out -of memory and fail. - -Most server resources are potentially sharable between applications. In -fact, windows are manipulated explicitly by window manager programs. -Fonts and cursors are typically shared automatically since the X server -loads and unloads font storage as needed. -@var{gcontext} (@pxref{gcontext}) -objects are not ordinarily shared between client applications. - -@node Debugging With CLX, , The Main Program, A Quick Tour of CLX -@subsection Debugging With CLX - -Typically, most CLX programs do not need to control the buffering of -output requests directly. However, CLX programmers need to be aware of -the asynchronous nature of client-server communication. It may be -convenient to control the CLX output buffer more directly, especially -during debugging. - -A client that wants a request to execute immediately instead of -asynchronously can follow it with a call to -@var{display-force-output} (@pxref{display-force-output}). -This function @emph{blocks} (does not return) until all previously -buffered output requests have been sent. Otherwise, the output buffer is -always flushed by a call to any function which returns a value from the -server or which waits for input (for example, -@var{get-property} (@pxref{get-property}). -Certain output requests can cause input events to be sent. For example, -@var{map-window} (@pxref{map-window}) -can cause -@var{:exposure} (@pxref{:exposure}) -events to be sent. Synchronizing output with the resulting input can be -done with the -@var{display-finish-output} (@pxref{display-finish-output}) -function. This function blocks until all previously buffered output has -been sent and all resulting input events have been received. - -Functions that return information from the server block until an -explicit reply is received or an error occurs. If a nonblocking call -results in an error, the error is generally not reported until later. -All errors (synchronous and asynchronous) are processed by calling an -error handler defined for the display. If the 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 since it is -assumed that the handler either takes care of the error completely, or -else signals. - -@node Naming and Argument Conventions, Programming Considerations, A Quick Tour of CLX, Introduction to CLX -@section Naming and Argument Conventions - -Throughout CLX, a number of conventions for naming and syntax of the CLX -functions have been followed. These conventions are intended to make the -syntax of the functions more predictable. - -The major naming conventions are as follows: - -@itemize @bullet -@item -To better differentiate the CLX symbols from other symbols, they have -all been placed in the package XLIB. External symbols have been -explicitly exported. - -@item -The @emph{display} argument, where used, is always first in the -argument list. - -@item -All server resource objects, where used, occur at the beginning of the -argument list, immediately after the display variable. - -@item -When a graphics context (@emph{gcontext}) is present together with -another type of server resource (most commonly, a @emph{drawable}), -the graphics context occurs in the argument list after the other -server resource. Drawables out rank all other server resources. - -@item -Source arguments always precede the destination arguments in the -argument list. - -@item -The @emph{x} argument always precedes the @emph{y} argument in the -argument list. - -@item -The @emph{width} argument always precedes the @emph{height} argument -in the argument list. - -@item -Where the @emph{x}, @emph{y}, @emph{width} and @emph{height} arguments -are used together, the @emph{x} and @emph{y} arguments always precede -the @emph{width} and @emph{height} arguments. - -@item -Where a @emph{mask} is accompanied with a @emph{structure}, the mask -always precedes the structure in the argument list. -@end itemize - -@node Programming Considerations, Data Types, Naming and Argument Conventions, Introduction to CLX -@section Programming Considerations - -The major programming considerations are as follows: - -@itemize @bullet -@item -Keyboards are the greatest variable between different manufacturer's -workstations. If you want your program to be portable, you should be -particularly conservative here. - -@item -Many display systems have limited amounts of off-screen memory. If you -can, you should minimize use of pixmaps and backing store. - -@item -The user should have control of his screen real-estate. Therefore, you -should write your applications to react to window management, rather -than presume control of the entire screen. What you do inside of your -top level window, however, is up to your application. - -@item -Coordinates and sizes in X are actually 16-bit quantities. They -usually are declared as an -@var{int16} (@pxref{int16}) in -the functions. Values larger than 16 bits can be truncated silently. -Sizes (width and height) are unsigned quantities. - -@item -The types -@var{color} (@pxref{color}), -@var{colormap} (@pxref{colormap}), -@var{cursor} (@pxref{cursor}), -@var{display} (@pxref{display}), -@var{font} (@pxref{font}), -@var{gcontext} (@pxref{gcontext}), -@var{pixmap} (@pxref{pixmap}), -@var{screen} (@pxref{screen}), -and -@var{window} (@pxref{window}) -are defined solely by a functional interface. Even though they are -treated like structures in this document, it is not specified whether -they are implemented as structures or classes. Although some -interfaces are described as functions, they are not required to be -defined using @var{defun.} (It is a requirement that they be -functions as opposed to macros or special forms.) -@end itemize - -@node Data Types, , Programming Considerations, Introduction to CLX -@section Data Types - - -The following are some data type definitions that are commonly used in -CLX function definitions. - -@deftp {Type} alist (key-type-and-name datum-type-and-name) 'list -@var{alist} defines an association list. An association list is a -sequence, containing zero or more repetitions of the given elements -with each of the elements expressed as (@emph{type} @emph{name}). -@end deftp - - -@deftp {Type} angle `(number ,(* -2pi) ,(* 2pi)) -@var{angle} defines an angle in units of radians and is bounded by -(-2%pi;) and (2%pi;). Note that we are explicitly using a -different angle representation than what is actually transmitted in -the protocol. -@end deftp - - -@deftp {Type} arc-seq '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) (angle angle1) (angle angle2)) -@var{arc-seq} defines a six-tuple sequence of the form -(@emph{x}, @emph{y}, @emph{width}, @emph{height}, @emph{angle1}, @emph{angle2}). -The points @emph{x} and @emph{y} are signed, 16-bit quantities with a -range from -32,768 to 32,767. The @emph{width} and @emph{height} -values are unsigned, 16-bit quantities and range from 0 to 65,535. -@emph{angle1} and @emph{angle2} are in units of radians, and bounded -by (-2%pi;) and (2%pi;). -@end deftp - - -@deftp {Type} array-index `(integer 0 ,array-dimension-limit) -@var{array-index} defines a type which is a subtype of the integers -and can be used to describe all variables that can be array -indices. The range is inclusive because start and end array index -specifiers can be one (1) past the end. -@end deftp - - -@deftp {Type} bit-gravity '(member gravity*) -A keyword that specifies which region of a window should be retained -when the window is resized. - -@emph{gravity} -- One of the following: -@itemize @c menu - -@item @var{:center} -@item @var{:north} -@item @var{:south} -@item @var{:static} - -@item @var{:east} -@item @var{:north-east} -@item @var{:south-east :west} - -@item @var{:forget} -@item @var{:north-west} -@item @var{:south-west} -@end itemize - -If a window is reconfigured without changing its inside width or -height, then the contents of the window moves with the window and are -not lost. Otherwise, the contents of a resized window are either moved -or lost, depending on its bit-gravity attribute. See -@var{window-bit-gravity}, in @ref{Window Attributes}, for additional -information. - -@end deftp - - - -@deftp {Type} bitmap '(array bit (* *)) -Specifies a two-dimensional array of bits. -@end deftp - - -@deftp {Structure} bitmap-format - -A structure that describes the storage format of a bitmap. - -The @var{bitmap-format} structure contains slots for @var{unit}, -@var{pad}, and @var{lsb-first-p}. The @var{unit} member indicates -the unit of increments used to maintain the bitmap data. The units -available for use are 8, 16, or 32 bits. The @var{pad} member -indicates how many bits are needed to pad the left edge of the -scan-line. The @var{lsb-first-p} member is a predicate which -indicates the ordering of bits with the bitmap unit. - -@end deftp - - -@deftp {Slot of bitmap-format} unit - -Type: (@var{member} 8 16 32). - -The size of a contiguous grouping of bits, which can be 8, 16, or -32. The default is 8. - -@end deftp - - - -@deftp {Slot of bitmap-format} pad - -Type: (@var{member} 8 16 32). - -The number of bits to left-pad the scan-line, which can be 8, 16, or -32. The default is 8. -@end deftp - - -@deftp {Slot of bitmap-format} lsb-first-p - -Type: @var{boolean}. - -A predicate indicating whether the least significant bit comes first -(@var{true}) or not (@var{nil}). -@end deftp - - -@deftp {Type} boolean '(or nil (not nil)) -@var{boolean} defines a type which is all inclusive. It is used for -variables that can take on a true (non-@var{nil}) or false -(@var{nil}) value. -@end deftp - -@deftp {Type} boole-constant `(member value*) - -@var{boole-constant} defines a type that is a set of the values -associated with the 16 boolean operation-code constants for the Common -Lisp language. It is used for the set of allowed source and -destination combination functions in a graphics context. - -@emph{value} -- One of the following: -@itemize @c menu - -@item @var{boole-1} -@item @var{boole-c1} -@item @var{boole-nand} -@item @var{boole-xor} - -@item @var{boole-2} -@item @var{boole-c2} -@item @var{boole-nor} - -@item @var{boole-and} -@item @var{boole-clr} -@item @var{boole-orc1} - -@item @var{boole-andc1} -@item @var{boole-eqv} -@item @var{boole-orc2} - -@item @var{boole-andc2} -@item @var{boole-ior} -@item @var{boole-set} -@end itemize -@end deftp - - -@deftp {Type} card8 '(unsigned-byte 8) -An unsigned integer value that is a maximum of eight bits long. This -gives a number of this type a range from 0 to 255. -@end deftp - - -@deftp {Type} card16 '(unsigned-byte 16) -An unsigned integer value that is a maximum of 16 bits long. This -gives a number of this type a range from 0 to 65,535. -@end deftp - - -@deftp {Type} card29 '(unsigned-byte 29) -An unsigned integer value that is a maximum of 29 bits long. This -gives a number of this type a range from 0 to 536,870,911. -@end deftp - - -@deftp {Type} card32 '(unsigned-byte 32) -An unsigned integer value that is a maximum of 32 bits long. This -gives a number of this type a range from 0 to 4,294,967,295. -@end deftp - - -@deftp {Type} color '(satisfies color-p) -@anchor{color} -A @var{color}. @xref{Color Functions}, for additional -information. -@end deftp - - -@deftp {Type} colormap '(satisfies colormap-p) -@anchor{colormap} -A @var{colormap}. @xref{Colormap Functions}, for -additional information. -@end deftp - - -@deftp {Type} cursor '(satisfies cursor-p) -@anchor{cursor} -A @var{cursor}. @xref{Cursors}, for additional information. -@end deftp - - -@deftp {Type} device-event-mask '(or mask32 (list device-event-mask-class)) -@anchor{event-mask} - -Provides a way to specify a set of bits for an event bitmask. Two ways -of specifying the bits are allowed: by setting the event bits in a 32 -bit mask, or by listing the keyword names of the device related event -bits in a list. -@end deftp - - -@deftp {Type} device-event-mask-class '(member event*) -A keyword name, for a device related event, that corresponds to a -particular bit in an event bitmask. The set of names is a subset of -the names in the type @var{event-mask-class}. - -@emph{event} -- One of the following: -@itemize @c menu - -@item @var{:button-1-motion} -@item @var{:button-motion} - -@item @var{:button-2-motion} -@item @var{:button-press} - -@item @var{:button-3-motion} -@item @var{:key-press} - -@item @var{:button-4-motion} -@item @var{:key-release} - -@item @var{:button-5-motion} -@item @var{:pointer-motion} -@end itemize -@end deftp - - -@deftp {Type} display '(satisfies display-p) -@anchor{display} -A connection to an X server. @xref{Displays}, for additional -information. -@end deftp - - -@deftp {Type} drawable '(or window pixmap) -Both @var{windows} and @var{pixmaps} can be used as sources and -destinations in graphics operations. @var{windows} and @var{pixmaps} -together are known as @emph{drawables}. However, an @var{:input-only} -window cannot be used as a source or destination in a graphics -operation. -@end deftp - - -@deftp {Type} draw-direction '(member :left-to-right :right-to-left) -Defines a list of rotation directions for drawing arcs and -fonts. @var{draw-direction} can have the values of -@var{:left-to-right} or @var{:right-to-left}. -@end deftp - - -@deftp {Type} error-key '(member error*) -Defines a list of all predefined errors. All errors (synchronous and -asynchronous) are processed by calling an error handler in the -display. The handler is called with the display as the first argument -and the error-key as its second argument. - -@emph{error} -- One of the following: -@itemize @c menu - -@item @var{:access} -@item @var{:drawable} -@item @var{:implementation} -@item @var{:value} - -@item @var{:alloc} -@item @var{:font} -@item @var{:length} -@item @var{:window} - -@item @var{:atom} -@item @var{:gcontext} -@item @var{:match} - -@item @var{:colormap} -@item @var{:id-choice} -@item @var{:name} - -@item @var{:cursor} -@item @var{:illegal-request} -@item @var{:pixmap} -@end itemize -@end deftp - -@deftp {Type} event-key '(member event-type*) -Defines a list that specifies all predefined event-types. Clients are -informed of information asynchronously by means of events. These -events can be either asynchronously generated from devices or -generated as side effects of client requests. - -@emph{event-type} -- One of the following: -@itemize @c menu - -@item @var{:button-press} -@item @var{:exposure} -@item @var{:motion-notify} - -@item @var{:button-release} -@item @var{:focus-in} -@item @var{:no-exposure} - -@item @var{:circulate-notify} -@item @var{:focus-out} -@item @var{:property-notify} - -@item @var{:circulate-request} -@item @var{:graphics-exposure} -@item @var{:reparent-notify} - -@item @var{:client-message} -@item @var{:gravity-notify} -@item @var{:resize-request} - -@item @var{:colormap-notify} -@item @var{:keymap-notify} -@item @var{:selection-clear} - -@item @var{:configure-notify} -@item @var{:key-press} -@item @var{:selection-notify} - -@item @var{:configure-request} -@item @var{:key-release} -@item @var{:selection-request} - -@item @var{:create-notify} -@item @var{:leave-notify} -@item @var{:unmap-notify} - -@item @var{:destroy-notify} -@item @var{:map-notify} -@item @var{:visibility-notify} - -@item @var{:enter-notify} -@item @var{:map-request} -@end itemize -@end deftp - -@deftp {Type} event-mask '(or mask32 (list event-mask-class)) -Provides a way to specify a set of bits for an event bitmask. Two ways -of specifying the bits are allowed: by setting the event bits in a 32 -bit mask, or by listing the keyword names of the event bits in a list. -@end deftp - - -@deftp {Type} event-mask-class '(member event*) -The elements of the type @var{event-mask-class} are keyword names -that correspond to a particular bit in an event bitmask. - -@emph{event} -- One of the following: -@itemize @c menu - -@item @var{:button-1-motion} -@item @var{:enter-window} -@item @var{:pointer-motion-hint} - -@item @var{:button-2-motion} -@item @var{:exposure} -@item @var{:property-change} - -@item @var{:button-3-motion} -@item @var{:focus-change} -@item @var{:resize-redirect} - -@item @var{:button-4-motion} -@item @var{:key-press} -@item @var{:structure-notify} - -@item @var{:button-5-motion} -@item @var{:key-release} -@item @var{:substructure-notify} - -@item @var{:button-motion} -@item @var{:keymap-state} -@item @var{:substructure-redirect} - -@item @var{:button-press} -@item @var{:leave-window} -@item @var{:visibility-change} - -@item @var{:button-release} -@item @var{:owner-grab-button} - -@item @var{:colormap-change} -@item @var{:pointer-motion} -@end itemize -@end deftp - - -@defun make-event-keys event-mask -Returns a list of @var{event-mask-class} keyword names for the event -bits that are set in the specified event mask. - -@table @var -@item event-mask -An event mask (type @var{mask32}). -@end table - -@end defun - - -@defun make-event-mask &rest keys - -@table @var -@item keys -@var{event-mask-class} keywords. -@end table - -Constructs an event mask from a set of @var{event-mask-class} keyword -names. - -@table @var -@item event-mask -Type @var{mask32}. -@end table - -@end defun - - -@deftp {Type} font '(satisfies font-p) -@anchor{font} - -A text font. @xref{Font and Characters}, for additional -information. - -@end deftp - - -@deftp {Type} fontable '(or stringable font) - -A @var{fontable} is either a @var{font} object or the name of one of -the fonts in the font database. - -@end deftp - - -@deftp {Type} font-props 'list - -A @var{list} that contains alternating keywords and integers. - -@end deftp - - -@deftp {Type} gcontext '(satisfies gcontext-p) -@anchor{gcontext} - -A graphics context. @xref{Graphics Contexts}, for additional -information. - -@end deftp - - -@deftp {Type} gcontext-key '(member type*) - -A list of predefined types for use in @var{gcontext} -processing. Various information for graphics output is stored in a -graphics context (GC or GContext), such as foreground pixel, -background pixel, line width, clipping region, and so forth. - -@var{type} -- One of the following: -@itemize @c menu - -@item @var{:arc-mode} -@item @var{:exposures} -@item @var{:line-width} - -@item @var{:background} -@item @var{:fill-rule} -@item @var{:plane-mask} - -@item @var{:cap-style :fill-style} -@item @var{:stipple} - -@item @var{:clip-mask} -@item @var{:font} -@item @var{:subwindow-mode} - -@item @var{:clip-x} -@item @var{:foreground} -@item @var{:tile} - -@item @var{:clip-y} -@item @var{:function} -@item @var{:ts-x} - -@item @var{:dash-offset} -@item @var{:join-style} -@item @var{:ts-y} - -@item @var{:dashes} -@item @var{:line-style} -@end itemize -@end deftp - -@deftp {Type} grab-status '(member grab-type*) - -There are two kinds of grabs: active and passive. An @emph{active -grab} occurs when a single client grabs the keyboard and/or pointer -explicitly. Clients can also grab a particular keyboard key or pointer -button in a window. The grab activates when the key or button is -actually pressed, and is called a @emph{passive grab}. Passive grabs -can be very convenient for implementing reliable pop-up menus. - -@var{grab-type} -- One of the following: - -@itemize @c menu - -@item @var{:already-grabbed} - -@item @var{:frozen} - -@item @var{:invalid-time} - -@item @var{:not-viewable} - -@item @var{:success} -@end itemize -@end deftp - - -@deftp {Type} image-depth '(integer 0 32) -Used in determining the depth of a pixmap, window, or image. The value -specifies the number of bits deep that a given pixel has within a -given pixmap, window, or image. -@end deftp - - -@deftp {Type} index-size '(member :default 8 16) -Used to control the element size of the destination buffer given to -the translate function when drawing glyphs. If @var{:default} is -specified, the size is based on the current font, if known; otherwise, -16 is used. -@end deftp - - -@deftp {Type} int8 '(signed-byte 8) -A signed integer value that is a maximum of eight bits long. A number -of this type can have a range from -128 to 127. -@end deftp - - -@deftp {Type} int16 '(signed-byte 16) -@anchor{int16} -A signed integer value that is a maximum of 16 bits long. A number of -this type can have a range from -32,768 to 32,767. -@end deftp - - -@deftp {Type} int32 '(signed-byte 32) -A signed integer value that is a maximum of 32 bits long. A number of -this type can have a range from -2,147,483,648 to 2,147,483,647. -@end deftp - - -@deftp {Type} keysym 'card32 -Used as an encoding of a symbol on a keycap on a keyboard. It is an -unsigned integer value represented in a maximum of 32 bits long. A -@var{keysym} type can have a range from 0 to 4,294,967,295. -@end deftp - - -@deftp {Type} mask16 ' card16 -A positional bitmask that contains 16 boolean flags. -@end deftp - - -@deftp {Type} mask32 ' card32 -A positional bitmask that contains 32 boolean flags. -@end deftp - - -@deftp {Type} modifier-key '(member modifier*) -A keyword identifying one of the modifier keys on the keyboard device. - -@var{modifier} -- One of the following: -@itemize @c menu - -@item @var{:shift} -@item @var{:mod-2} - -@item @var{:lock} -@item @var{:mod-3} - -@item @var{:control} -@item @var{:mod-4} - -@item @var{:mod-1} -@item @var{:mod-5} -@end itemize -@end deftp - - -@deftp {Type} modifier-mask '(or (member :any) mask16 (list modifier-key)) -A bitmask or list of keywords that specifies a set of modifier -keys. The keyword @var{:any} is equivalent to any subset of modifier -key. -@end deftp - - -@deftp {Type} pixarray '(or (array pixel (* *)) (array card16 (* *)) (array card8 (* *)) (array (unsigned-byte 4) (* *)) (array bit (* *))) - -Specifies a two-dimensional array of pixels. - -@end deftp - - - -@deftp {Type} pixel '(unsigned-byte 32) - -An unsigned integer value that is a maximum of 32 bits long. This -gives a pixel type a value range from 0 to 4,294,967,295. Useful -values are dependent on the class of colormap being used. - -@end deftp - - -@deftp {Type} pixmap '(satisfies pixmap-p) -@anchor{pixmap} - -A @var{pixmap}, @pxref{Pixmaps}), for additional information. - -@end deftp - - -@deftp {Structure} pixmap-format - -A structure that describes the storage format of a pixmap. - -The @var{pixmap-format} structure contains slots for @var{depth}, -@var{bits-per-pixel}, and @var{scanline-pad}. The @var{depth} member -indicates the number of bit planes in the pixmap. The -@var{bits-per-pixel} member indicates the number of bits used to -represent a single pixel. For X, a pixel can be 1, 4, 8, 16, 24, or 32 -bits wide. As for @var{bitmap-format}, the @var{scanline-pad} member -indicates how many pixels are needed to pad the left edge of the -scan-line. -@end deftp - -@deftp {Slot of pixmap-format} depth - -Type: @var{image-depth}. - -The number of bit planes in the pixmap. -@end deftp - - -@deftp {Slot of pixmap-format} bits-per-pixel - - -Type: (@var{member} 1 4 8 16 24 32). - -The number of consecutive bits used to encode a single pixel. The -default is 8. -@end deftp - - -@deftp {Slot of pixmap-format} scanline-pad - -Type: (@var{member} 8 16 32). - -The number of bits to left-pad the scan-line, which can be 8, 16, or -32. The default is 8. -@end deftp - -@deftp {Type} point-seq '(repeat-seq (int16 x) (int16 y)) - -The @var{point-seq} type is used to define sequences of -(@var{x},@var{y}) pairs of points. The paired values are 16-bit, -signed integer quantities. This gives the points in this type a range -from -32,768 to 32,767. -@end deftp - -@deftp {Type} pointer-event-mask '(or mask32 (list pointer-event-mask-class)) - -Provides a way to specify a set of bits for an event bitmask. Two ways -of specifying the bits are allowed: by setting the event bits in a 32 -bit mask, or by listing the keyword names of the pointer related event -bits in a list. - -@end deftp - - -@deftp {Type} pointer-event-mask-class '(member event*) - -A keyword name, for a pointer related event, that corresponds to a -particular bit in an event bitmask. The set of names is a subset of -the names in the type @var{event-mask-class}. - -@var{event} -- One of the following: - -@itemize @c menu - -@item @var{:button-1-motion} -@item @var{:button-motion} -@item @var{:leave-window} - -@item @var{:button-2-motion} -@item @var{:button-press} -@item @var{:pointer-motion} - -@item @var{:button-3-motion} -@item @var{:button-release} -@item @var{:pointer-motion-hint} - -@item @var{:button-4-motion} -@item @var{:enter-window} - -@item @var{:button-5-motion} -@item @var{:keymap-state} -@end itemize -@end deftp - -@deftp {Type} rect-seq '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)) - -@var{rect-seq} defines a four-tuple sequence of the form (@var{x}, -@var{y}, @var{width}, @var{height}). The points @var{x} and -@var{y} are signed, 16-bit quantities with a range from -32,768 to -32,767. The @var{width} and @var{height} values are unsigned, 16-bit -quantities and range from 0 to 65,535. - -@end deftp - - -@deftp {Type} repeat-seq (&rest elts) 'sequence - -A subtype used to define repeating sequences. - -@end deftp - - -@deftp {Type} resource-id 'card29 - -A numeric identifier that is assigned by the server to a server -resource object. - -@end deftp - - -@deftp {Type} rgb-val '(float 0.0 1.0) - -An @var{rgb-val} is a floating-point value between 0 and 1 that -specifies a saturation for a red, green, or blue additive primary. The -0 value indicates no saturation and 1 indicates full saturation. - -@end deftp - -@deftp {Type} screen '(satisfies screen-p) -@anchor{screen} - -A display screen. @xref{Screens}, for further information. - -@end deftp - - -@deftp {Type} seg-seq '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)) - -Defines sequences of (@var{x1}, @var{y1}, @var{x2}, @var{y2}) sets -of points. The point values are 16-bit, signed integer -quantities. This gives the points in this type a range from -32,768 to -32,767. - -@end deftp - - -@deftp {Type} state-mask-key '(or modifier-key (member button*)) - -A keyword identifying one of the display modifier keys or pointer -buttons whose state is reported in device events. - -@var{button} -- One of the following: - -@itemize @c menu -@item @var{:button-1} -@item @var{:button-4} -@item @var{:button-2} -@item @var{:button-5} -@item @var{:button-3} -@end itemize - -@end deftp - -@defun make-state-keys state-mask - -@table @var -@item state-mask -A 16-bit mask of type @var{mask16}. - -@end table - -Returns a list of @var{state-mask-key} symbols corresponding to the -@var{state-mask}. A symbol belongs to the returned list if, and only -if, the corresponding @var{state-mask} bit is 1. - -@table @var -@item state-keywords -Type @var{list}. -@end table - -@end defun - - -@defun make-state-mask &rest keys - -@table @var -@item keys -A list of @var{state-mask-key} symbols. -@end table - -Returns a 16-bit @var{mask} representing the given -@var{state-mask-key} symbols. The returned @var{mask} contains a 1 -bit for each keyword. - -@table @var -@item mask -Type @var{mask16}. -@end table -@end defun - -@deftp {Type} stringable '(or string symbol) - -Used for naming something. This type can be either a string or a -@var{symbol} whose @var{symbol-name} is used as the string containing -the name. The case of the characters in the string is ignored when -comparing stringables. - -@end deftp - - -@deftp {Type} timestamp '(or null card32) - -An encoding of a time. @var{nil} stands for the current time. - -@end deftp - - -@deftp {Structure} visual-info - -A structure that represents a visual type. The elements of this -structure are @var{id}, @var{class}, @var{red-mask}, @var{green-mask}, -@var{blue-mask}, @var{bits-per-rgb}, and @var{colormap-entries}. - -@end deftp - - -@deftp {Slot of visual-info} id - -Type: @var{card29}. - -A unique identification number. - -@end deftp - - -@deftp {Slot of visual-info} class - -Type: (member :direct-color :gray-scale :pseudo-color :static-color :static-gray :true-color). - -The class of the visual type. - -@end deftp - - -@deftp {Slots of visual-info} red-mask -@deftpx {Slots of visual-info} green-mask -@deftpx {Slots of visual-info} blue-mask - -Type: @var{pixel}. - -The @var{red-mask}, @var{green-mask}, and @var{blue-mask} elements are -only meaningful for the @var{:direct-color} and @var{:true-color} -classes. Each mask has one contiguous set of bits with no -intersections. - -@end deftp - -@deftp {Slot of visual-info} bits-per-rgb - -Type: @var{card8}. - -Specifies the log base 2 of the approximate number of distinct color -values ( individually) of red, green, and blue. Actual RGB values are -unsigned 16-bit numbers. - -@end deftp - - -@deftp {Slot of visual-info} colormap-entries - -Type: @var{card16}. - -Defines the number of available colormap entries in a newly created -colormap. For @var{:direct-color} and @var{:true-color}, this is the -size of an individual pixel subfield. - -@end deftp - - -@deftp {Type} win-gravity '(member gravity*) - -A keyword that specifies how to reposition a window when its parent is -resized. - -@var{gravity} -- One of the following: -@itemize @c menu - -@item @var{:center} -@item @var{:north-west} -@item @var{:static} - -@item @var{:east} -@item @var{:south} -@item @var{:unmap} - -@item @var{:north} -@item @var{:south-east} -@item @var{:west} - -@item @var{:north-east} -@item @var{:south-west} -@end itemize - -If a parent window is reconfigured without changing its inside width -or height, then all child windows move with the parent and are not -changed. Otherwise, each child of the resized parent is moved, -depending on the child's gravity attribute. See @var{window-gravity} -(@pxref{Window Attributes})), for additional information. - -@end deftp - - -@deftp {Type} window '(satisfies window-p) -@anchor{window} - -A window. @xref{Windows and Pixmaps}, for additional -information. - -@end deftp - - -@deftp {Type} xatom '(or string symbol) - -A name that has been assigned a corresponding unique ID by the -server. @var{xatoms} are used to identify properties, selections, and -types defined in the X server. An @var{xatom} can be either a -@var{string} or @var{symbol} whose @var{symbol-name} is used as the -@var{xatom} name. The case of the characters in the string are -significant when comparing @var{xatoms}. - -@end deftp - -@node Displays, Screens, Introduction to CLX, Top -@chapter Displays - -A particular X server, together with its screens and input devices, is -called a @emph{display}. The CLX @var{display} object contains all the -information about the particular display and its screens, as well as the -state that is needed to communicate with the display over a particular -connection. - -Before your program can use a display, you must establish a connection to -the X server driving your display. Once you have established a connection, -you then can use the CLX macros and functions discussed in this section to -return information about the display. This section discusses how to: - -@itemize @bullet -@item Open (connect) a display -@item Obtain information about a display -@item Access and change display attributes -@item Close (disconnect) a display -@end itemize - -@menu -* Opening the Display:: -* Display Attributes:: -* Managing the Output Buffer:: -* Closing the Display:: -@end menu - -@node Opening the Display, Display Attributes, Displays, Displays -@section Opening the Display - - -The @var{open-display} and @var{open-default-display} functions are -used to open a connection to an X server. @var{open-default-display} -is an extension that is not present in the MIT CLX tree, but is -preferred where available as it uses the same rules for display -defaulting as the C Xlib bindings, and tends to get authorization -right more often than @var{open-display} (particularly on -ssh-forwarded connections) - -@defun open-display host &key :display :protocol - -@table @var -@item host -Specifies the name of the @emph{host} machine on which the server -executes. A string must be acceptable as a @emph{host}, but otherwise -the possible types are not constrained and will likely be very system -dependent. - -@item :display -An integer that specifies which display device on the @emph{host} -should be used for this connection. This is needed since multiple -displays can be controlled by a single X server. The default is -display 0 (zero). - -@item :protocol -A keyword argument that specifies which network protocol should be -used for connecting to the server (for example, @var{:tcp}, -@var{:dna}, or @var{:chaos}). The set of possible values and the -default value are implementation specific. - -@end table - -Returns a @var{display} that serves as the connection to the X -server and contains all the information about that X server. - -Authorization, if any, is assumed to come from the -environment. After a successful call to @var{open-display}, all -screens on the display can be used by the client application. - -@table @var -@item display -Type @var{display}. -@end table - -@end defun - -@defun open-default-display &optional display-name - -@table @var -@item display-name -The display to connect to. Display names have the format - -@verbatim - [protocol/] [hostname] : [:] displaynumber [.screennumber] -@end verbatim - -There are two special cases in parsing, to match that done in the Xlib -C language bindings - -@itemize @bullet -@item If the hostname is @code{unix} or the empty string, any supplied -protocol is ignored and a connection is made using the @code{local} transport. -@item If a double colon separates @var{hostname} from @var{displaynumber}, the -protocol is assumed to be @code{decnet}. -@end itemize - -If @var{display-name} is not supplied, a default will be provided -appropriate for the local environment: on a POSIX system - the only -kind this CLX port runs on - the default display is taken from the -environment variable @env{DISPLAY}. See also the section ``DISPLAY -NAMES'' in X(7) - -@end table - -Open a connection to @var{display-name} or to the appropriate -default display. - -@code{open-display-name} always attempts to do display authorization, -following complicated rules that closely match the ones that the C -Xlib bindings use. Briefly: 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 the -environment variable @env{AUTHORITY_PATHNAME} (typically -@file{$HOME/.Xauthority}). If the protocol is @code{: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. - -@end defun - -@node Display Attributes, Managing the Output Buffer, Opening the Display, Displays -@section Display Attributes - -The complete set of display attributes is discussed in the following -paragraphs. - -@defun display-authorization-data display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the authorization data string for @var{display} that was -transmitted to the server by @var{open-display} during connection -setup. The data is specific to the particular authorization protocol -that was used. The @var{display-authorization-name} function returns -the protocol used. - -@table @var -@item authorization-data -Type @var{string}. -@end table - -@end defun - -@defun display-authorization-name display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the authorization protocol namestring for @var{display} that -was transmitted by @var{open-display} to the server during connection -setup. The @var{authorization-name} indicates what authorization -protocol the client expects the server to use. Specification of valid -authorization mechanisms is not part of the X protocol. A server that -implements a different protocol than the client expects, or a server -that only implements the host-based mechanism, can simply ignore this -information. If both name and data strings are empty, this is to be -interpreted as "no explicit authorization." - -@table @var -@item authorization-name -Type @var{string}. -@end table - -@end defun - -@defun display-bitmap-format display -@anchor{display-bitmap-format} - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @emph{bitmap-format} information for the specified @emph{display}. - -@table @var -@item bitmap-format -Type @var{bitmap-format}. -@end table - -@end defun - -@defun display-byte-order display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @var{byte-order} to be employed in communication with the -server for the given @var{display}. The possible values are as -follows: - -@table @var -@item :lsbfirst -Values are transmitted least significant byte first. -@item :msbfirst -Values are transmitted most significant byte first. -@end table - -Except where explicitly noted in the protocol, all 16-bit and 32-bit -quantities sent by the client must be transmitted with this -@var{byte-order}, and all 16-bit and 32-bit quantities returned by the -server are transmitted with this @var{byte-order}. - -@table @var -@item byte-order -Either @var{:lsbfirst} or @var{:msbfirst}. -@end table - -@end defun - -@defun display-display display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @var{display-number} for the host associated with -@var{display}. - -@table @var -@item display-number -Type @var{integer}. -@end table - -@end defun - -@defun display-error-handler display - -@table @var -@item display -A @var{display} object. -@end table - -Returns and (with @code{setf}) sets the @var{error-handler} function -for the given @var{display}. CLX calls (one of) the display error -handler functions to handle server errors returned to the -connection. The default error handler, @var{default-error-handler}, -signals conditions as they occur. @xref{Errors}, for a list of -the conditions that CLX can signal. For more information about errors -and error handling, refer to the section entitled Common Lisp -Condition System in the @emph{Lisp Reference} manual. - -If the value of @var{error-handler} is a sequence, it is expected to -contain a handler function for each specific error. The error code is -used as an index into the sequence to fetch the appropriate handler -function. If this element is a function, it is called for all -errors. Any results returned by the handler are ignored since it is -assumed the handler either takes care of the error completely or else -signals. The arguments passed to the handler function are the -@var{display} object, a symbol naming the type of error, and a set of -keyword-value argument pairs that vary depending on the type of -error. For all core errors, the keyword-value argument pairs are: - -@multitable @columnfractions 0.5 0.5 -@item @var{:current-sequence} @tab @var{card16} -@item @var{:major} @tab @var{card8} -@item @var{:minor} @tab @var{card16} -@item @var{:sequence} @tab @var{card16} -@end multitable - -For @var{colormap}, @var{cursor}, @var{drawable}, @var{font}, -@var{gcontext}, @var{id-choice}, @var{pixmap}, and @var{window} -errors, the keyword-value pairs are the core error pairs plus: - -@multitable @columnfractions 0.5 0.5 -@item @var{:resource-id} @tab @var{card32} -@end multitable - -For @var{:atom} errors, the keyword-value pairs are the core error -pairs plus: - -@multitable @columnfractions 0.5 0.5 -@item @var{:atom-id} @tab @var{card32} -@end multitable - -For @var{:value} errors, the keyword-value pairs are the core error -pairs plus: - -@multitable @columnfractions 0.5 0.5 -@item @var{:value} @tab @var{card32} -@end multitable - -@table @var -@item error-handler -Type @var{function} or @var{sequence}. -@end table - -@end defun - -@defun display-image-lsb-first-p display - -@table @var -@item display -A @var{display} object. -@end table - -Although the server is generally responsible for byte swapping -communication data to match the client, images (pixmaps/bitmaps) are -always transmitted and received in formats (including byte order) -specified by the server. Within images for each scan-line unit in -bitmaps or for each pixel value in pixmaps, the leftmost bit in the -image as displayed on the screen is either the least or most -significant bit in the unit. For the given @var{display}, -@var{display-image-lsb-first-p} returns non-@var{nil} if the leftmost -bit is the least significant bit; otherwise, it returns @var{nil}. - -@table @var -@item image-lsb-first-p -Type @var{boolean}. -@end table - -@end defun - - -@defun display-keycode-range display - -@table @var -@item display -A @var{display} object. -@end table - -Returns @var{min-keycode} and @var{max-keycode} as multiple -values. See the @var{display-max-keycode} and -@var{display-min-keycode} functions for additional information. - -@table @var -@item min-keycode -@itemx max-keycode -Type @var{card8}. -@end table - -@end defun - - -@defun display-max-keycode display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the maximum keycode value for the specified -@emph{display}. This value is never greater than 255. Not all keycodes -in the allowed range are required to have corresponding keys. - -@table @var -@item max-keycode -Type @var{card8}. -@end table - -@end defun - - -@defun display-max-request-length display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the maximum length of a request, in four-byte units, that is -accepted by the specified @emph{display}. Requests larger than this -generate a length error, and the server will read and simply discard -the entire request. This length is always at least 4096 (that is, -requests of length up to and including 16384 bytes are accepted by all -servers). - -@table @var -@item max-request-length -Type @var{card16}. -@end table - -@end defun - - -@defun display-min-keycode display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the minimum keycode value for the specified -@var{display}. This value is never less than eight. Not all keycodes -in the allowed range are required to have corresponding keys. - -@table @var -@item min-keycode -Type @var{card8}. -@end table - -@end defun - - -@defun display-motion-buffer-size display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the approximate size of the motion buffer for the specified -@var{display}. The server can retain the recent history of pointer -motion at a finer granularity than is reported by @var{:motion-notify} -events. Such history is available through the @var{motion-events} -function. - -@table @var -@item motion-buffer-size -Type @var{card32}. -@end table - -@end defun - - -@defun display-p display - -@table @var -@item display-p -Type @var{boolean}. -@end table - -Returns non-@var{nil} if @emph{display} is a @var{display} object; -@end defun - -@defun display-pixmap-formats display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the list of @var{pixmap-format} values for the given -@emph{display}. This list contains one entry for each depth value. The -entry describes the format used to represent images of that depth. An -entry for a depth is included if any screen supports that depth, and -all screens supporting that depth must support (only) the format for -that depth. - -@table @var -@item pixmap-formats -Type @var{list}. -@end table - -@end defun - - -@defun display-plist display - -@table @var -@item display -A @var{display} object. -@end table - -Returns and (with @code{setf}) sets the property list for the specified -@emph{display}. This function provides a hook where extensions can add -data. -@table @var -@item plist -Type @var{list}. -@end table - -@end defun - - -@defun display-protocol-major-version display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the major version number of the X protocol associated with the -specified @emph{display}. In general, the major version would -increment for incompatible changes. The returned protocol version -number indicates the protocol the server actually supports. This might -not equal the version supported by the client. The server can (but -need not) refuse connections from clients that offer a different -version than the server supports. A server can (but need not) support -more than one version simultaneously. -@table @var -@item protocol-major-version -Type @var{card16}. -@end table - -@end defun - - -@defun display-protocol-minor-version display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the minor protocol revision number associated with the -specified @emph{display}. In general, the minor version would -increment for small upward compatible changes in the X protocol. -@table @var -@item protocol-minor-version -Type @var{card16}. -@end table - -@end defun - - -@defun display-protocol-version display - -@table @var -@item display -A @var{display} object. -@end table - -Returns @emph{protocol-major-version} and -@emph{protocol-minor-version} as multiple values. See the -@var{display-protocol-major-version} and -@var{display-protocol-minor-version} functions for additional -information. - -@table @var -@item protocol-major-version -@itemx protocol-minor-version -@end table - -@end defun - - -@defun display-resource-id-base display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @emph{resource-id-base} value that was returned from the -server during connection setup for the specified @emph{display}. This -is used in combination with the @emph{resource-id-mask} to construct -valid IDs for this connection. -@table @var -@item resource-id-base -Type @var{resource-id}. -@end table - -@end defun - - -@defun display-resource-id-mask display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @emph{resource-id-mask} that was returned from the server -during connection setup for the specified @emph{display}. The -@emph{resource-id-mask} contains a single contiguous set of bits (at -least 18) which the client uses to allocate resource IDs for types -@var{window}, @var{pixmap}, @var{cursor}, @var{font}, @var{gcontext}, -and @var{colormap} by choosing a value with (only) some subset of -these bits set, and @var{or}ing it with the -@emph{resource-id-base}. Only values constructed in this way can be -used to name newly created server resources over this -connection. Server resource IDs never have the top three bits set. The -client is not restricted to linear or contiguous allocation of server -resource IDs. Once an ID has been freed, it can be reused, but this -should not be necessary. - - -An ID must be unique with respect to the IDs of all other server -resources, not just other server resources of the same type. However, -note that the value spaces of server resource identifiers, atoms, -visualids, and keysyms are distinguished by context, and as such are -not required to be disjoint (for example, a given numeric value might -be both a valid window ID, a valid atom, and a valid keysym.) -@table @var -@item resource-id-mask -Type @var{resource-id}. -@end table - -@end defun - - -@defun display-roots display - -@table @var -@item display -A @var{display} object. -@end table - -Returns a list of all the @var{screen} structures available for the -given @emph{display}. -@table @var -@item roots -A list of screens. -@end table - -@end defun - - -@defun display-vendor display - -@table @var -@item display -A @var{display} object. -@end table -Returns @emph{vendor-name} and @emph{release-number} as -multiple values. See the @var{display-vendor-name} and -@var{display-release-number} functions for additional information. -@table @var -@item vendor-name -@itemx release-number -@end table - -@end defun - - -@defun display-vendor-name display - -@table @var -@item display -A @var{display} object. -@end table - -Returns a string that provides some vendor identification of the X -server implementation associated with the specified @emph{display}. -@table @var -@item vendor-name -Type @var{string}. -@end table - -@end defun - - -@defun display-version-number display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the X protocol version number for this implementation of CLX. -@table @var -@item version-number -Type @var{card16}. -@end table - -@end defun - -@defun display-xid display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the function that is used to allocate server resource IDs for -this @emph{display}. -@table @var -@item resource-allocator -Type @var{function}. -@end table - -@end defun - - -@defmac with-display display &body body - -This macro is for use in a multi-process -environment. @var{with-display} provides exclusive access to the local -@var{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 @var{with-display}), -then synchronization need not (but can) occur immediately. Except -where noted, all routines effectively contain an implicit -@var{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 work correctly. This macro does not prevent -concurrent event processing (@pxref{with-event-queue}). - -@table @var -@item display -A @var{display}. -@end table - -@end defmac - -@node Managing the Output Buffer, Closing the Display, Display Attributes, Displays -@section Managing the Output Buffer - - -Most CLX functions cause output requests to be generated to an X -server. Output requests are not transmitted immediately but instead -are stored in an @emph{output buffer} for the appropriate -display. Requests in the output buffer are typically sent only when -the buffer is filled. Alternatively, buffered requests can be sent -prior to processing an event in the input event queue -(@pxref{Processing Events}). In either case, CLX sends the output -buffer automatically without explicit instructions from the client -application. - -However, in some cases, explicit control over the output buffer is -needed, typically to ensure that the X server is in a consistent state -before proceeding further. The @var{display-force-output} and -@var{display-finish-output} functions allow a client program to -synchronize with buffered output requests. - -@defun display-after-function display - -@table @var -@item display -A @var{display} object. -@end table - -Returns and (with @code{setf}) sets the @emph{after-function} for the -given @emph{display}. If @emph{after-function} is non-@var{nil}, it is -a function that is called after every protocol request is generated, -even those inside an explicit @var{with-display}, but never called -from inside the @emph{after-function}. The function is called inside -the effective @var{with-display} for the associated request. The -default value is @var{nil}. This can be set, for example, to -#'@var{display-force-output} or #' @var{display-finish-outpu}t. -@table @var -@item after-function -Type @var{function} or @var{null}. -@end table - -@end defun - - -@defun display-force-output display -@anchor{display-force-output} - -@table @var -@item display -A @var{display} object. -@end table - -Forces any buffered output to be sent to the X server. - -@end defun - - -@defun display-finish-output display -@anchor{display-finish-output} - -@table @var -@item display -A @var{display} object. -@end table - -Forces any buffered output to be sent to the X server and then waits -until all requests display error handler. Any events generated by -output requests are read and stored in the event queue. - -@end defun - -@node Closing the Display, , Managing the Output Buffer, Displays -@section Closing the Display - -To close or disconnect a display from the X server, use @var{close-display}. - -@defun close-display display - -@table @var -@item display -A @var{display} object. -@end table - -Closes the connection to the X server for the specified -@var{display}. It destroys all server resources (@var{window}, -@var{font}, @var{pixmap}, @var{colormap}, @var{cursor}, and -@var{gcontext}), that the client application has created on this -display, unless the close down mode of the server resource has been -changed (@pxref{set-close-down-mode}). Therefore, these server -resources should never be referenced again. In addition, this function -discards any output requests that have been buffered but have not yet -been sent. - -@end defun - -@node Screens, Windows and Pixmaps, Displays, Top -@chapter Screens - -@menu -* Screens and Visuals:: -* Screen Attributes:: -@end menu - -@node Screens and Visuals, Screen Attributes, Screens, Screens -@section Screens and Visuals - - -An X display supports graphical output to one or more -@emph{screens}. Each screen has its own root window and window -hierarchy. Each window belongs to exactly one screen and cannot -simultaneously appear on another screen. - - -The kinds of graphics hardware used by X screens can vary greatly in -their support for color and in their methods for accessing raster -memory. X uses the concept of a @emph{visual type} (usually -referred to simply as a @emph{visual}) which uniquely identifies the -hardware capabilities of a display screen. Fundamentally, a visual is -represented by a @var{card29} integer ID, which uniquely identifies -the visual type relative to a single display. CLX also represents a -visual with a @var{visual-info} structure that contains other -attributes associated with a visual (@pxref{Data Types}). A -screen can support more than one depth (that is, pixel size), and for -each supported depth, a screen may support more than one visual. -However, it is more typical for a screen to have only a single depth -and a single visual type. - - -A visual represents various aspects of the screen hardware, as -follows: - -@itemize @bullet - -@item -A screen can be color or gray-scale. - -@item -A screen can have a colormap that is either writable or read-only. - -@item -A screen can have a single colormap or separate colormaps for each of -the red, green, and blue components. With separate colormaps, a pixel -value is decomposed into three parts to determine indexes into each of -the red, green, and blue colormaps. - -@end itemize - -CLX supports the following classes of visual types: -@var{:direct-color}, @var{:gray-scale}, @var{:pseudo-color}, -@var{:static-color}, @var{:static-gray}, and @var{:true-color}. The -following tables show how the characteristics of a screen determine -the class of its visual type. - -For screens with a single colormap: - -@multitable {} {Color} {Gray-Scale} -@item Read-only @tab @var{:static-color} @tab @var{:static-gray} -@item Writable @tab @var{:pseudo-color} @tab @var{:gray-scale} -@end multitable - -For screens with red, green, and blue colormaps: - -@multitable @columnfractions 0.3 0.3 0.3 -@item Read-only @tab @var{:true-color} @tab -@item Writable @tab @var{:direct-color} @tab @var{:gray-scale} -@end multitable - -The visual class also indicates how screen colormaps are -handled. @pxref{Colormaps and Colors}). - -@node Screen Attributes, , Screens and Visuals, Screens -@section Screen Attributes - -In CLX, each display screen is represented by a @var{screen} -structure. The @var{display-roots} function returns the list of -@var{screen} structures for the display. The following paragraphs -discuss the attributes of CLX @var{screen} structures. - -@defun screen-backing-stores screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns a value indicating when the @emph{screen} supports backing -stores, although it may be storage limited in the number of windows it -can support at once. The value returned can be one of @var{:always}, -@var{:never}, or @var{:when-mapped}. - -@table @var -@item backing-stores-type -One of @var{:always}, @var{:never}, or @var{:when-mapped}. -@end table - -@end defun - - -@defun screen-black-pixel screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns the black pixel value for the specified @emph{screen}. - -@table @var -@item black-pixel -Type @var{pixel}. -@end table - -@end defun - - -@defun screen-default-colormap screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns the @emph{default-colormap} for the specified -@emph{screen}. The @emph{default-colormap} is initially associated -with the root window. Clients with minimal color requirements creating -windows of the same depth as the root may want to allocate from this -map by default. Most routine allocations of color should be made out -of this colormap. - -@table @var -@item default-colormap -Type @var{colormap}. -@end table - -@end defun - - -@defun screen-depths screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns an association list that specifies what drawable -depths are supported on the specified @emph{screen}. Elements of the -returned association list have the form (depth @emph{visual}*), where -each @emph{visual} is a @var{visual-info} structure. Pixmaps are -supported for each depth listed, and windows of that depth are -supported if at least one visual type is listed for the depth. A -pixmap depth of one is always supported and listed, but windows of -depth one might not be supported. A depth of zero is never listed, but -zero-depth @var{:input-only} windows are always supported. - -@table @var -@item depths -Type @var{alist}. -@end table - -@end defun - - -@defun screen-event-mask-at-open screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the initial root event mask for the specified -@emph{screen}. - -@table @var -@item event-mask-at-open -Type @var{mask32}. -@end table - -@end defun - - -@defun screen-height screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the @emph{height} of the specified @emph{screen} in -pixel units. - -@table @var -@item height -Type @var{card16}. -@end table - -@end defun - - -@defun screen-height-in-millimeters screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the height of the specified @emph{screen} in -millimeters. The returned height can be used with the width in -millimeters to determine the physical size and the aspect ratio of the -screen. - -@table @var -@item height-in-millimeters -Type @var{card16}. -@end table - -@end defun - - -@defun screen-max-installed-maps screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the maximum number of colormaps that can be -installed simultaneously with @var{install-colormap}. - -@table @var -@item max-installed-colormaps -Type @var{card16}. -@end table - -@end defun - - -@defun screen-min-installed-maps screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns the minimum number of colormaps that can be guaranteed to be -installed simultaneously. - -@table @var -@item min-installed-colormaps -Type @var{card16}. -@end table - -@end defun - - -@defun screen-p screen - -@table @var -@item screen-p -Type @var{boolean}. -@end table - - -Returns non-@code{nil} if the @emph{screen} argument is a -@end defun - - - -@defun screen-plist screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns and (with @code{setf}) sets the property list for the -specified @emph{screen}. This function provides a hook where -extensions can add data. - -@table @var -@item plist -Type @var{list}. -@end table - -@end defun - -@defun screen-root screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the @emph{root-window} for the specified -@emph{screen}. This function is useful with functions that take a -parent window as an argument. The class of the root window is always -@var{:input-output}. - -@table @var -@item root-window -Type @var{window} or @var{null}. -@end table - -@end defun - - -@defun screen-root-depth screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns the depth of the root window for the specified -@emph{screen}. Other depths can also be supported on this -@emph{screen}. - -@table @var -@item root-window-depth -Type @var{image-depth}. -@end table - -@end defun - - -@defun screen-root-visual screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the default visual type for the root window for the -specified @emph{screen}. - -@table @var -@item root-window-visual -Type @var{card29}. -@end table - -@end defun - - -@defun screen-save-unders-p screen - -@table @var -@item screen -A screen. -@end table - - -If true, the server can support the save-under mode in -@var{create-window} and in changing window attributes. - -@table @var -@item save-unders-p -Type @var{boolean}. -@end table - -@end defun - - -@defun screen-white-pixel screen - -@table @var -@item screen -A screen. -@end table - - -Returns the white pixel value for the specified -@emph{screen}. - -@table @var -@item white-pixel -Type @var{pixel}. -@end table - -@end defun - - -@defun screen-width screen - -@table @var -@item screen -A screen. -@end table - - -Returns the width of the specified @emph{screen} in pixel -units. - -@table @var -@item width -Type @var{card16}. -@end table - -@end defun - - -@defun screen-width-in-millimeters screen - -@table @var -@item screen -A screen. -@end table - - -Returns the width of the specified @emph{screen} in millimeters. The -returned width can be used with the height in millimeters to determine -the physical size and the aspect ratio of the screen. - -@table @var -@item width-in-millimeters -Type @var{card16}. -@end table - -@end defun - - -@node Windows and Pixmaps, Graphics Contexts, Screens, Top -@chapter Windows and Pixmaps - -@menu -* Drawables:: -* Creating Windows:: -* Window Attributes:: -* Stacking Order:: -* Window Hierarchy:: -* Mapping Windows:: -* Destroying Windows:: -* Pixmaps:: -@end menu - -@node Drawables, Creating Windows, Windows and Pixmaps, Windows and Pixmaps -@section Drawables - -Both windows and pixmaps can be used as sources and destinations in -graphics operations. These are collectively known as -@emph{drawables}. The following functions apply to both windows and -pixmaps. - -@defun drawable-display drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -Returns the display for the specified @emph{drawable}. - -@end defun - -@defun drawable-equal drawable-1 drawable-2 - -@table @var -@item drawable-1 -@itemx drawable-2 -@var{drawable} objects. -@end table - -Returns true if the two arguments refer to the same server resource, -and @var{nil} if they do not. - -@end defun - - -@defun drawable-id drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -Returns the unique resource ID assigned to the specified -@var{drawable}. - -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - -@defun drawable-p drawable - -@table @var -@item boole -Type @var{boolean}. -@end table - -Returns true if the argument is a @var{drawable} and @var{nil} -otherwise. - -@end defun - -@defun drawable-plist drawable - -@table @var -@item plist -A property list. -@end table - -Returns and (with @code{setf}) sets the property list for the specified -@emph{drawable}. This function provides a hook where extensions can -add data. - -@end defun - -@node Creating Windows, Window Attributes, Drawables, Windows and Pixmaps -@section Creating Windows - - -A window is a @var{drawable} that can also receive input events. CLX -represents a window with a @var{window} object. The -@var{create-window} function creates a new @var{window} object. - -@defun create-window &key :parent :x :y :width :height (:depth 0) (:border-width 0) (:class :copy) (:visual :copy) :background :border :gravity :bit-gravity :backing-store :backing-planes :backing-pixel :save-under :event-mask :do-not-propagate-mask :override-redirect :colormap :cursor -@anchor{create-window} - -@table @var -@item :parent -The parent window. This argument is required. - -@item :x -@itemx :y -@var{int16} coordinates for the outside upper-left corner of the new -window with respect to the origin (inside upper-left corner) of the -@var{:parent}. These arguments are required. - -@item :width -@itemx :height - -@var{card16} values for the size of the new window. These arguments -are required. - -@item :depth - -A @var{card16} specifying the depth of the new window. - -@item :class - -One of @var{:input-outpu}t, @var{:input-only}, or @var{:copy}. - -@item :visual - -A @var{card29} ID specifying the visual type of the new window. - -@item :background -@itemx :backing-pixel -@itemx :backing-planes -@itemx :backing-store -@itemx :bit-gravity -@itemx :border -@itemx :border-width -@itemx :colormap -@itemx :cursor -@itemx :do-not-propagate-mask -@itemx :event -@itemx :gravity -@itemx :override-redirect -@itemx :save-under - -Initial attribute values for the new window. If @var{nil}, the default -value is defined by the X protocol.See paragraph -@end table - -Creates and returns a window. A @var{:parent} window must be -specified; the first window created by a client will have a root -window as its @var{:parent}. The new window is initially unmapped and -is placed on top of its siblings in the stacking order. A -@var{:create-notify} event is generated by the server. - -The @var{:class} of a window can be @var{:input-output} or -@var{:input-only}. Windows of class @var{:input-only} cannot be used -as the destination drawable for graphics output and can never receive -@var{:exposure} events, but otherwise operate the same as -@var{:input-output} windows. The @var{:class} can also be @var{:copy}, -in which case the new window has the same class as its @var{:parent}. - -For an @var{:input-output} window, the @var{:visual} and @var{:depth} -must be a combination supported by the @var{:parent}'s screen, but the -@var{:depth} need not be the same as the @var{:parent}'s. The -@var{:parent} of an @var{:input-output} window must also be -@var{:input-output}. A @var{:depth} of 0 means that the depth of the -@var{:parent} is used. - -For an @var{:input-only} window, the @var{:depth} must be zero, and -the @var{:visual} must be supported by the @var{:parent}'s screen. The -@var{:parent} of an @var{:input-only} window can be of any class. The -only attributes that can be given for an @var{:input-only} window are -@var{:cursor}, @var{:do-not-propagate-mask}, @var{:event-mask}, -@var{:gravity}, and @var{:override-redirect}. - -@table @var -@item window -Type @var{window}. -@end table - -@end defun - -@node Window Attributes, Stacking Order, Creating Windows, Windows and Pixmaps -@section Window Attributes - - -The following paragraphs describe the CLX functions used to return or -change window attributes. Using the @var{with-state} macro improves -the performance of attribute access by batching related accesses in -the minimum number of server requests. - -@defun drawable-border-width drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -Returns the @emph{border-width} of the @emph{drawable} in pixels. It -always returns zero if the @emph{drawable} is a pixmap or an -@var{:input-only} window. Used with @code{setf}, this function also -changes the border width of the @var{:input-only} window. The default -border width of a new window is zero. - -Changing just the border width leaves the outer left corner of a -window in a fixed position but moves the absolute position of the -window's origin. It is an error to make the border width of an -@var{:input-only} window nonzero. - -When changing the border-width of a window, if the override-redirect -attribute of the window is @var{:off} and some other client has -selected @var{:substructure-redirect} on the parent, a -@var{:configure-request} event is generated, and no further processing -is performed. Otherwise, the border-width is changed. - -@table @var -@item border-width -Type @var{card16}. -@end table - -@end defun - - -@defun drawable-depth drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -Returns the depth of the specified @emph{drawable} (bits per pixel). - -@table @var -@item depth -Type @var{card8}. -@end table - -@end defun - - -@defun drawable-height drawable - -@table @var -@item inside-height -Type @var{card16}. -@end table - -@end defun - - -@defun drawable-width drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -These functions return the height or width of the -@emph{drawable}. These coordinates define the inside size of the -@emph{drawable}, in pixels. Used with @code{setf}, these functions also -change the inside height or width of a window. However, the height or -width of a pixmap cannot be changed. - -Changing the width and height resizes a window without changing its -position or stacking priority. - -Changing the size of a mapped window may cause the window to lose its -contents and generate an @var{:exposure} event. If a mapped window is -made smaller, @var{:exposure} events are generated on windows that it -formerly obscured. - -When changing the size of a window, if the override-redirect attribute -of the window is @var{:off} and some other client has selected -@var{:substructure-redirect} on the parent, a @var{:configure-request} -event is generated, and no further processing is performed. Otherwise, -if another client has selected @var{:resize-redirect} on the window, a -@var{:resize-request} event is generated, and the current inside width -and height are maintained. Note that the override-redirect attribute -of the window has no effect on @var{:resize-redirect} and that -@var{:substructure-redirect} on the parent has precedence over -@var{:resize-redirect} on the window. - -When the inside size of the window is changed, the children of the -window can move according to their window gravity. Depending on the -window's bit gravity, the contents of the window can also be moved. - -@table @var -@item inside-width -Type @var{card16}. -@end table - -@end defun - - -@defun drawable-x drawable - -@table @var -@item outside-left -Type @var{int16}. -@end table - -@end defun - - -@defun drawable-y drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -These functions return the x or y coordinate of the specified -@emph{drawable}. They always return zero if the @emph{drawable} is a -pixmap. These coordinates define the location of the top left pixel of -the window's border or of the window, if it has no border. Used with -@code{setf}, these functions also change the x or y coordinate of a -window. However, the x or y coordinate of a pixmap cannot be changed. - -Changing the x and y coordinates moves a window without changing its -size or stacking priority. Moving a mapped window generates -@var{:exposure} events on any formerly obscured windows. - -When changing the position of a window, if the override-redirect -attribute of the window is @var{:off} and some other client has -selected @var{:substructure-redirect} on the parent, a -@var{:configure-request} event is generated, and no further processing -is performed. Otherwise, the window is moved. - -@table @var -@item outside-top -Type @var{int16}. -@end table - -@end defun - - -@defun window-all-event-masks window - -@table @var -@item window -A @var{window}. -@end table - -Returns the inclusive-or of the event masks selected on the -specified @emph{window} by all clients. -@table @var -@item all-event-masks -Type @var{mask32}. -@end table - -@end defun - - -@defun setf (window-background) window background - -@table @var -@item window -A @var{window}. -@item background -Either a @var{pixel}, a @var{pixmap}, @var{:none}, or @var{:parent-relative}. -@end table - -Changes the @emph{background} attribute of the @emph{window} to the -specified value. This operation is not allowed on an @var{:input-only} -window. Changing the background does not cause the window contents to -be changed. Note that the background of a window cannot be returned -from the X server. The default background of a new window is -@var{:none}. - -In general, the server automatically fills in exposed areas of the -window when they are first made visible. A background pixmap is tiled -to fill each area. However, if the background is @var{:none}, the -server will not modify exposed areas. If the background is -@var{:parent-relative}, the window and its parent must have the same -depth. In this case, the window shares the same background as its -parent. The parent's background is not copied and is reexamined -whenever the window's background is required. If the background is -@var{:parent-relative}, the background pixmap tile origin is the same -as the parent's; otherwise, the tile origin is the window origin. - -@table @var -@item background -Either a @var{pixel}, a @var{pixmap}, @var{:none}, or @var{:parent-relative}. -@end table - -@end defun - - -@defun window-backing-pixel window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the backing-pixel -attribute for the specified @emph{window}. Changing the backing-pixel -attribute of a mapped window may have no immediate effect. The default -backing-pixel of a new window is zero. - -@table @var -@item backing-pixel -Type @var{pixel}. -@end table - -@end defun - - -@defun window-backing-planes window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the backing-planes -attribute for the specified @emph{window}. Changing the backing-planes -attribute of a mapped window may have no immediate effect. The default -backing-planes of a new window is all one's. - -@table @var -@item backing-planes -Type @var{pixel}. -@end table - -@end defun - - -@defun window-backing-store window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the backing-store -attribute for the specified @emph{window}. Changing the backing-store -attribute of an obscured window to @var{:when-mapped} or @var{:always} -may have no immediate effect. The default backing-store of a new -window is @var{:not-useful}. - -@table @var -@item backing-store-type -One of @var{:always}, @var{:not-useful}, or @var{:when-mapped}. -@end table - -@end defun - - -@defun window-bit-gravity window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the bit-gravity attribute of the -@emph{window}. If a window is reconfigured without changing its inside -width or height, the contents of the window move with the window and -are not lost. Otherwise, the contents of the resized window are either -moved or lost, depending on its bit-gravity attribute. The default -bit-gravity of a new window is @var{:forget}. - -For example, suppose a window's size is changed by @emph{W} pixels -in width and @emph{H} pixels in height. The following table shows, -for each bit-gravity value, the change in position (relative to the -window origin) that results for each pixel of the window contents. - -@multitable {Bit-Gravity} {X Change} {Y Change} -@item @var{:center} @tab @emph{W/}2 @tab @emph{H/}2 -@item @var{:east} @tab @emph{W} @tab @emph{H/}2 -@item @var{:north} @tab @emph{W/}2 @tab 0 -@item @var{:north-east} @tab @emph{W} @tab 0 -@item @var{:north-west} @tab 0 @tab 0 -@item @var{:south} @tab @emph{W/}2 @tab @emph{H} -@item @var{:south-east} @tab W @tab H -@item @var{:south-west} @tab 0 @tab H -@item @var{:west} @tab 0 @tab H/2 -@end multitable - - -A @var{:static} bit-gravity indicates the contents or window should -not move relative to the origin of the root window. - -A server can choose to ignore the specified bit-gravity attribute -and use @var{:forget} instead. A @var{:forget} bit-gravity -attribute indicates that the window contents are always discarded -after a size change, even if backing-store or save-under attributes -are @var{:on}. The window's background is displayed (unless it is -@var{:none}), and zero or more @var{:exposure} events are -generated. -@table @var -@item bit-gravity -Type @var{bit-gravity}. -@end table - -@end defun - - -@defun setf (window-border) window border - -@table @var -@item window -A @var{window}. -@item border -Either a @var{pixel}, a @var{pixmap}, or @var{:copy}. -@end table - -Changes the @emph{border} attribute of the @emph{window} to the -specified value. This operation is not allowed on an -@var{:input-only} window. Changing the border attribute also causes -the window border to be repainted. Note that the border of a window -cannot be returned from the X server. The default border of a new -window is @var{:copy}. - -A border pixmap is tiled to fill the border. The border pixmap tile -origin is the same as the background tile origin. A border pixmap -and the window must have the same root and depth. If the border is -@var{:copy}, the parent's border is copied and used; subsequent -changes to the parent's border do not affect the window border. -@table @var -@item border -Either a @var{pixel}, a @var{pixmap}, or @var{:copy}. -@end table - -@end defun - - -@defun window-class window - -@table @var -@item window -A @var{window}. -@end table - -Returns the @emph{class} of the specified @emph{window}. -@table @var -@item class -Either @var{:input-output} or @var{:input-only}. -@end table - -@end defun - - -@defun window-colormap window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the colormap -attribute for the specified @emph{window}. A value of @var{:copy} is -never returned, since the parent's colormap attribute is actually -copied, but the attribute can be set to @var{:copy} in a @code{setf} -form. Changing the colormap of a window (defining a new map, not -changing the contents of the existing map) generates a -@var{:colormap-notify} event. Changing the colormap of a visible -window may have no immediate effect on the screen -(@pxref{install-colormap}). The default colormap of a new window is -@var{:copy}. -@table @var -@item colormap -Type @var{colormap} or @var{null}. -@end table - -@end defun - - -@defun window-colormap-installed-p window - -@table @var -@item window -A @var{window}. -@end table - -Returns non-@var{nil} if the colormap associated with this -@emph{window} is installed. Otherwise, this function returns -@var{nil}. -@table @var -@item colormap-installed-p -Type @var{boolean}. -@end table - -@end defun - - -@defun setf (window-cursor) window cursor - -@table @var -@item window -A @var{window}. -@item cursor -Either @var{cursor} or @var{:none}. -@end table - -Changes the @emph{cursor} attribute of the @emph{window} to the -specified value. Changing the cursor of a root window to @var{:none} -restores the default cursor. Note that the cursor of window cannot be -returned from the X server. The default cursor of a new window is -@var{:none}. - -@table @var -@item cursor -Type @var{cursor} or @var{:none}. -@end table - -@end defun - - -@defun window-display window - -@table @var -@item window -A @var{window}. -@end table - -Returns the @var{display} object associated with the specified -@emph{window}. -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun window-do-not-propagate-mask window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the do-not-propagate-mask -attribute for the window. The default do-not-propagate-mask of a new -window is zero. - -If a window receives an event from one of the user input devices, and -if no client has selected to receive the event, the event can instead -be propagated up the window hierarchy to the first ancestor for which -some client has selected it. However, any event type selected by the -do-not-propagate-mask is not be propagated. The types of events that -can be selected by the do-not-propagate-mask are those of type -@var{device-event-mask-class}. @xref{Selecting Events}. -@table @var -@item do-not-propagate-mask -Type @var{mask32}. -@end table - -@end defun - - -@defun window-equal window-1 window-2 - -@table @var -@item window-1 -@itemx window-2 -The windows to compare for equality. -@end table - -Returns non-@var{nil} if the two arguments are the same window, and -@var{nil} if they are not. -@table @var -@item equal-p -Type @var{boolean}. -@end table - -@end defun - - -@defun window-event-mask window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the event-mask -attribute for the @emph{window}. The default event-mask of a new -window is zero. -@table @var -@item event-mask -Type @var{mask32}. -@end table - -@end defun - - -@defun window-gravity window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the gravity attribute of the -@emph{window}. If a parent window is reconfigured without changing its -inside width or height, then all child windows move with the parent -and are not changed. Otherwise, each child of the resized parent is -moved, depending on the child's gravity attribute. The default gravity -of a new window is @var{:north-west}. - -For example, suppose the size of the window's parent is changed by -@emph{W} pixels in width and @emph{H} pixels in height. The following -table shows, for each possible gravity value, the resulting change in -the window's position relative to its parent's origin. When the window -is moved, two events are generated--a @var{:configure-notify} event -followed by a @var{:gravity-notify} event. - -@multitable {Gravity} {X Change} {Y Change} -@item @var{:center} @tab @emph{W/}2 @tab @emph{H/}2 -@item @var{:east} @tab @emph{W} @tab @emph{H/}2 -@item @var{:north} @tab @emph{W/}2 @tab 0 -@item @var{:north-east} @tab @emph{W} @tab 0 -@item @var{:north-west} @tab 0 @tab 0 -@item @var{:south} @tab @emph{W/}2 @tab @emph{H} -@item @var{:south-east} @tab W @tab H -@item @var{:south-west} @tab 0 @tab H -@item @var{:west} @tab 0 @tab H/2 -@end multitable - - -A @var{:static} gravity indicates that the position of the window -should not move relative to the origin of the root window. - -An @var{:unmap} gravity is like @var{:north-west}, except the window -is also unmapped and an @var{:unmap-notify} event is generated. This -@var{:unmap-notify} event is generated after the -@var{:configure-notify} event is generated for the parent. -@table @var -@item gravity -Type @var{win-gravity}. -@end table - -@end defun - - -@defun window-id window - -@table @var -@item window -A @var{window}. -@end table - -Returns the unique ID assigned to @emph{window}. -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun window-map-state window - -@table @var -@item window -A @var{window}. -@end table - -Returns the map state of @emph{window}. A window is @var{:unviewable} -if it is mapped but some ancestor is unmapped. -@table @var -@item map-state -One of @var{:unmapped}, @var{:unviewable}, or @var{:viewable}. -@end table - -@end defun - - -@defun window-override-redirect window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the -override-redirect attribute for @emph{window}. The default -override-redirect of a new window is @var{:off}. - -The override-redirect attribute determines whether or not attempts to -change window geometry or parent hierarchy can be @emph{redirected} by -a window manager or some other client. The functions that might be -affected by the override-redirect attribute are -@var{circulate-window-down}, @var{circulate-window-up}, -@var{drawable-border-width}, @var{drawable-height}, -@var{drawable-width}, @var{drawable-x}, @var{drawable-y}, -@var{map-window}, and @var{window-priority}. -@table @var -@item override-redirect -Either @var{:on} or @var{:off}. -@end table - -@end defun - - -@defun window-p object - -@table @var -@item window-p -Type @var{boolean}. -@end table - -Returns non-@var{nil} if the @emph{object} argument is a window; otherwise, it returns @var{nil}. -@end defun - -@defun window-plist window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) sets the property list for the specified -@emph{window}. This function provides a hook where extensions can hang -data. -@table @var -@item plist -A property list. -@end table - -@end defun - - - -@defun setf (window-priority window) (&optional sibling) mode - -@table @var -@item window -A @var{window}. - -@item sibling -An optional argument specifying that @emph{window} is to be restacked -relative to this sibling @var{window}. - -@item mode -One of @var{:above}, @var{:below}, @var{:bottom-if}, @var{:opposite}, or @var{:top-if}. -@end table - -Changes the stacking priority element of the @emph{window} to the -specified value. It is an error if the @emph{sibling} argument is -specified and is not actually a sibling of the window. Note that the -priority of an existing window cannot be returned from the X server. - -When changing the priority of a window, if the override-redirect -attribute of the window is @var{:off} and some other client has -selected :substructure-redirect on the parent, a :configure-request -event is generated, and no further processing is -performed. Otherwise, the priority is changed. -@table @var -@item mode -One of @var{:above}, @var{:below}, @var{:bottom-if}, @var{:opposite}, or @var{:top-if}. -@end table - -@end defun - - -@defun window-save-under window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the save-under -attribute for the specified @emph{window}. Changing the save-under -attribute of a mapped window may have no immediate effect. -@table @var -@item save-under -Either @var{:on} or @var{:off}. -@end table - -@end defun - -@defun window-visual window - -@table @var -@item window -A @var{window}. -@end table - -Returns the @emph{visual-type} associated with the specified @emph{window}. -@table @var -@item visual-type -Type @var{card29}. -@end table - -@end defun - - - -@defmac with-state drawable &body body -@anchor{with-state} - -Batches successive read and write accesses to window attributes and -drawable geometry, in order to minimize the number of requests sent to -the server. Batching occurs automatically within the dynamic extent of -the @emph{body}. The @emph{body} is not executed within a -@var{with-display} form. - -All window attributes can be returned or changed in a single -request. Similarly, all drawable geometry values can be returned or -changed in a single request. @var{with-state} combines accesses to -these values into the minimum number of server requests necessary to -guarantee that each read access returns the current server state of -the @emph{drawable}. The number of server requests sent depends on -the sequence of calls to reader and @code{setf} functions within the -dynamic extent of the @emph{body}. There are two groups of reader and -@code{setf} functions--the Window Attributes group and the Drawable -Geometry group--as shown in Table 4-1. - -@multitable {Group} {Reader Functions} {Setf Functions} - -@item Window Attributes @tab @var{window-all-event-masks} @tab @var{window-background} - -@item @tab @var{window-backing-pixel} @tab @var{window-backing-pixel} -@item @tab @var{window-backing-planes} @tab @var{window-backing-planes} -@item @tab @var{window-backing-store} @tab @var{window-backing-store} -@item @tab @var{window-bit-gravity} @tab @var{window-bit-gravity} -@item @tab @var{window-class} @tab @var{window-border} -@item @tab @var{window-colormap} @tab @var{window-colormap} -@item @tab @var{window-colormap-installed-p} @tab @var{window-cursor} -@item @tab @var{window-do-not-propagate-mask} @tab @var{window-do-not-propagate-mask} -@item @tab @var{window-event-mask} @tab @var{window-event-mask} -@item @tab @var{window-gravity} @tab @var{window-gravity} -@item @tab @var{window-map-state} @tab -@item @tab @var{window-override-redirect} @tab @var{window-override-redirect} -@item @tab @var{window-save-under} @tab @var{window-save-under} -@item @tab @var{window-visual} @tab - -@item Drawable Geometry @tab @var{drawable-border-width} @tab @var{drawable-border-width} - -@item @tab @var{drawable-depth} @tab @var{drawable-height} -@item @tab @var{drawable-height} @tab @var{drawable-width} -@item @tab @var{drawable-root} @tab @var{drawable-x} -@item @tab @var{drawable-width} @tab @var{drawable-y} -@item @tab @var{drawable-x} @tab @var{window-priority} -@item @tab @var{drawable-y} @tab - -@end multitable - - -The results from a sequence of calls to @code{setf} functions in a -given group are cached and sent in a single server request, either -upon exit from the @emph{body} or when a reader function from the -corresponding group is called. - -@var{with-state} sends a single request to update all its cached -values for the @emph{drawable} before the first call to a reader -function within the @emph{body} and also before the first call to a -reader function following a sequence of calls to @code{setf} functions -from the corresponding group. - -@table @var -@item drawable -A @var{display}. -@item body -The forms in which attributes accesses are batched. -@end table - -@end defmac - - -@node Stacking Order, Window Hierarchy, Window Attributes, Windows and Pixmaps -@section Stacking Order - - -Sibling windows can @emph{stack} on top of each other. Windows above -can @emph{obscure} or @emph{occlude} lower windows. This relationship -between sibling windows is known as the stacking order. The -@var{window-priority} function can be used to change the stacking -order of a single window. CLX also provides functions to raise or -lower children of a window. Raising a mapped window can generate -@var{:exposure} events for the window and any mapped subwindows that -were formerly obscured. Lowering a mapped window can generate -@var{:exposure} events on any windows it formerly obscured. - -@defun circulate-window-down window - -@table @var -@item window -A @var{window}. -@end table - -Lowers the highest mapped child of the specified @emph{window} that -partially or completely occludes another child to the bottom of the -stack. Completely unobscured children are unaffected. Exposure -processing is performed on formerly obscured windows. - -If some other client has selected @var{:substructure-redirect} on the -@emph{window}, a @var{:circulate-request} event is generated, and no -further processing is performed. Otherwise, the child window is -lowered and a @var{:circulate-notify} event is generated if the -@emph{window} is actually restacked. - -@end defun - - -@defun circulate-window-up window - -@table @var -@item window -A @var{window}. -@end table - -Raises the lowest mapped child of the specified @emph{window} that is -partially or completely occluded by another child to the top of the -stack. Completely unobscured children are unaffected. Exposure -processing is performed on formerly obscured windows. - -If another client has selected @var{:substructure-redirect} on the -@emph{window}, a @var{:circulate-request} event is generated, and no -further processing is performed. Otherwise, the child window is raised -and a @var{:circulate-notify} event is generated if the @emph{window} -is actually restacked. - -@end defun - -@node Window Hierarchy, Mapping Windows, Stacking Order, Windows and Pixmaps -@section Window Hierarchy - - -All the windows in X are arranged in a strict hierarchy. At the top of -the hierarchy are the root windows, which cover the display -screens. Each root window is partially or completely covered by its -child windows. All windows, except for root windows, have -parents. Child windows can have their own children. In this way, a -tree of arbitrary depth on each screen can be created. CLX provides -several functions for examining and modifying the window hierarchy. - -@defun drawable-root drawable - -@table @var -@item drawable -A @var{drawable}. -@end table - -Returns the root window of the specified @emph{drawable}. - -@table @var -@item root-window -Type @var{window}. -@end table - -@end defun - -@defun query-tree window &key (:result-type `list) - -@table @var -@item window -A @var{window}. -@item :result-type -A valid type specifier for a sub-type of @var{sequence}. The default is a @var{list}. -@end table - -Returns the @emph{children} windows, the @emph{parent} window, and the -@emph{root} window for the specified @emph{window}. The children are -returned as a sequence of windows in current stacking order, from -bottom-most (first) to top-most (last). The @var{:result-type} -specifies the type of children sequence returned. - -@table @var -@item children -Type @var{sequence} of @var{window}. -@item parent -Type @var{window} or @var{null}. -@item root -Type @var{window}. -@end table - -@end defun - - -@defun reparent-window window parent x y - -@table @var -@item window -A @var{window}. -@item parent -The new parent @var{window}. -@item x -@itemx y -The position (type @var{int16}) of the @emph{window} in its new -@emph{parent}. These coordinates are relative to the @emph{parent}'s -origin, and specify the new position of the upper, left, outer corner -of the @emph{window}. -@end table - -Changes a @emph{window}'s @emph{parent} within a single -screen. There is no way to move a window between screens. - -The specified @emph{window} is reparented by inserting it as a child -of the specified @emph{parent}. If the @emph{window} is mapped, an -@var{unmap-window} operation is automatically performed on the -specified @emph{window}. The @emph{window} is then removed from its -current position in the hierarchy and inserted as the child of the -specified @emph{parent}. The @emph{window} is placed on top in the -stacking order with respect to sibling windows. - -After reparenting the specified @emph{window,} a -@var{:reparent-notify} event is generated. The override-redirect -attribute of the @emph{window} is passed on in this event. Window -manager clients normally should ignore this event if this attribute is -@var{:on}. @xref{Events and Input}, for more information on -@var{:reparent-notify} event processing. Finally, if the specified -@emph{window} was originally mapped, a @var{map-window} operation is -automatically performed on it. - -The X server performs normal exposure processing on formerly obscured -windows. It might not generate @var{:exposure} events for regions from -the initial @var{unmap-window} operation if they are immediately -obscured by the final @var{map-window} operation. - -It is an error if any of the following are true: - -@itemize @bullet - -@item -The new @emph{parent} window is not on the same screen as the old parent window. - -@item -The new @emph{parent} window is the specified @emph{window} or an -inferior of the specified @emph{window}. - -@item -The specified @emph{window} has a @var{:parent-relative} background -attribute and the new @emph{parent} window is not the same depth as -the specified @emph{window}. -@end itemize - - - -@end defun - -@defun translate-coordinates source source-x source-y destination - -@table @var -@item source -A @var{window} defining the source coordinate system. - -@item source-x -@itemx source-y -Coordinates (@var{int16}) relative to the origin of the @emph{source} -@var{window}. - -@item destination -A @var{window} defining the destination coordinate system. - -@end table - -Returns the position defined by @emph{source-x} and @emph{source-y} -(relative to the origin of the @emph{source} window), expressed as -coordinates relative to the origin of the @emph{destination} window. - -@table @var -@item destination-x -Type @var{int16} or @var{null}. -@item destination-y -Type @var{int16} or @var{null}. -@item destination-child -Type @var{window} or @var{null}. -@end table - -@end defun - - -@node Mapping Windows, Destroying Windows, Window Hierarchy, Windows and Pixmaps -@section Mapping Windows - -A window is considered mapped if a @var{map-window} call has been made -on it. When windows are first created, they are not mapped because an -application may wish to create a window long before it is mapped to -the screen. A mapped window may not be visible on the screen for one -of the following reasons: - -@itemize @bullet - -@item It is obscured by another opaque sibling window. -@item One of its ancestors is not mapped. -@item It is entirely clipped by an ancestor. - -@end itemize - - -A subwindow will appear on the screen as long as all of its ancestors -are mapped and not obscured by a sibling or clipped by an -ancestor. Mapping a window that has an unmapped ancestor does not -display the window, but marks it as eligible for display when the -ancestor becomes mapped. Such a window is called unviewable. When all -its ancestors are mapped, the window becomes viewable and remains -visible on the screen if not obscured by any sibling or ancestor. - -Any output to a window not visible on the screen is -discarded. @var{:exposure} events are generated for the window when -part or all of it becomes visible on the screen. A client only -receives the @var{:exposure} events if it has selected them. Mapping -or unmapping a window does not change its stacking order priority. - -@defun map-window window - -@table @var -@item window -A @var{window}. -@end table -@anchor{map-window} - -Maps the @emph{window}. This function has no effect when the -@emph{window} is already mapped. - -If the override-redirect attribute of the @emph{window} is @var{:off} -and another client has selected @var{:substructure-redirect} on the -parent window, the X server generates a @var{:map-request} event and -the @var{map-window} function does not map the -@emph{window}. Otherwise, the @emph{window} is mapped, and the X -server generates a @var{:map-notify} event. - -If the @emph{window} becomes visible and no earlier contents for it -are remembered, @var{map-window} tiles the window with its -background. If no background was defined for the window, the existing -screen contents are not altered, and the X server generates one or -more @var{:exposure} events. If a backing-store was maintained while -the window was unmapped, no @var{:exposure} events are generated. If a -backing-store will now be maintained, a full window exposure is always -generated. Otherwise, only visible regions may be reported. Similar -tiling and exposure take place for any newly viewable inferiors. - -@var{map-window} generates @var{:exposure} events on each -@var{:input-output} window that it causes to become visible. - - - -@end defun - -@defun map-subwindows window - -@table @var -@item window -A @var{window}. -@end table - -Maps all child windows for a specified @emph{window} in top-to-bottom -stacking order. The X server generates an @var{:exposure} event on -each newly visible window. This function is much more efficient than -mapping each child individually. - - - -@end defun - - -@defun unmap-window window - -@table @var -@item window -A @var{window}. -@end table - -Unmaps the specified @emph{window} and causes the X server to generate -an @var{:unmap-notify} event. If the specified @emph{window} is -already unmapped, @var{unmap-window} has no effect. Normal exposure -processing on formerly obscured windows is performed. Any child window -is no longer viewable. Unmapping the @emph{window} generates -@var{:exposure} events on windows that were formerly obscured by -@emph{window} and its children. - - - -@end defun - - -@defun unmap-subwindows window - -@table @var -@item window -A @var{window}. -@end table - -Unmaps all child windows for the specified @emph{window} in bottom to -top stacking order. The X server generates an @var{:unmap-notify} -event on each child and @var{:exposure} events on formerly obscured -windows. Using this function is much more efficient than unmapping -child windows individually. - - - -@end defun - - -@node Destroying Windows, Pixmaps, Mapping Windows, Windows and Pixmaps -@section Destroying Windows - - -CLX provides functions to destroy a window or destroy all children of -a window. Note that by default, windows are destroyed when a -connection is closed. For further information, -@xref{Closing the Display}, and @xref{Client Termination}. - -@defun destroy-window window - -@table @var -@item window -A @var{window}. -@end table - -Destroys the specified @emph{window} as well as all of its -inferiors. The windows should never again be referenced. If the -specified @emph{window} is mapped, it is automatically unmapped. The -window and all of its inferiors are then destroyed, and a -@var{:destroy-notify} event is generated for each window. The ordering -of the @var{:destroy-notify} events is such that for any given window -being destroyed, @var{:destroy-notify} is generated on the window's -inferiors before being generated on the window. The ordering among -siblings and across sub-hierarchies is not otherwise constrained. If -the @emph{window} is a root window, no windows are -destroyed. Destroying a mapped window generates @var{:exposure} events -on other windows that the mapped window obscured. - - - -@end defun - -@defun destroy-subwindows window - -@table @var -@item window -A @var{window}. -@end table - -Destroys all inferiors of the specified @emph{window}, in bottom to -top stacking order. The X server generates a @var{:destroy-notify} -event for each window. This is much more efficient than deleting many -windows individually. The inferiors should never be referenced again. - - -@end defun - - -@node Pixmaps, , Destroying Windows, Windows and Pixmaps -@section Pixmaps - - -A @emph{pixmap} is a three-dimensional array of bits. A pixmap is -normally thought of as a two-dimensional array of pixels, where each -pixel can be a value from 0 to 2@emph{n}-1, where @emph{n} -is the depth of the pixmap. A pixmap can also be thought of as a stack -of @emph{n} bitmaps. A @emph{bitmap} is a single bit pixmap of depth -1. CLX provides functions to: - -@itemize @bullet - -@item Create or free a pixmap - -@item Test if an object is a pixmap - -@item Test if two pixmap objects are equal - -@item Return the pixmap resource ID from a @var{pixmap} object -@end itemize - - - -Note that pixmaps can only be used on the screen where they were -created. Pixmaps are off-screen server resources that are used for a -number of operations. These include defining patterns for cursors or -as the source for certain raster operations. - -@defun create-pixmap &key :width :height :depth :drawable - -@table @var -@item :width -@itemx :height -The nonzero width and height (type @var{card16}). - -@item :depth -The depth (type @var{card8}) of the pixmap. - -@item :drawable -A @var{drawable} which determines the screen where the pixmap will be used. -@end table - -Creates a pixmap of the specified @var{:width}, @var{:height}, and -@var{:depth}. It is valid to pass a window whose class is -@var{:input-only} as the @var{:drawable} argument. The @var{:width} -and @var{:height} arguments must be nonzero. The @var{:depth} must be -supported by the screen of the specified @var{:drawable}. - -@table @var -@item pixmap -Type @var{pixmap}. -@end table - -@end defun - - -@defun free-pixmap pixmap - -@table @var -@item pixmap -A @var{pixmap}. -@end table - -Allows the X server to free the pixmap storage when no other server -resources reference it. The pixmap should never be referenced again. - - - -@end defun - - -@defun pixmap-display pixmap - -@table @var -@item pixmap -A @var{pixmap}. -@end table - -Returns the @var{display} object associated with the specified @emph{pixmap}. - -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun pixmap-equal pixmap-1 pixmap-2 - -@table @var -@item pixmap-1 -@itemx pixmap-2 -A three-dimensional array of bits to be tested. -@end table - -Returns true if the two arguments refer to the same server resource, -and @var{nil} if they do not. - - - -@end defun - - -@defun pixmap-id pixmap - -@table @var -@item pixmap -A @var{pixmap}. -@end table - -Returns the unique resource ID that has been assigned to the specified -@emph{pixmap}. - -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun pixmap-p object - -@table @var -@item pixmap -Type @var{boolean}. -@end table - -Returns true if the argument is a @var{pixmap} object and @var{nil} -otherwise. - -@end defun - -@defun pixmap-plist pixmap - -@table @var -@item pixmap -A @var{pixmap}. -@end table - -Returns and (with @code{setf}) sets the property list for the specified -@emph{pixmap}. This function provides a hook where extensions can add -data. - -@table @var -@item plist -A property list. -@end table - -@end defun - - -@node Graphics Contexts, Graphic Operations, Windows and Pixmaps, Top -@chapter Graphics Contexts - -Clients of the X Window System specify the visual attributes of -graphical output primitives by using @emph{graphics contexts}. A -graphics context is a set of graphical attribute values such as -foreground color, font, line style, and so forth. Like a window, a -graphics context is another kind of X server resource which is created -and maintained at the request of a client program. The client program, -which may use several different graphics contexts at different times, -is responsible for specifying a graphics context to use with each -graphical output function. - -CLX represents a graphics context by an object of type @var{gcontext} -and defines functions to create, modify, and manipulate @var{gcontext} -objects. By default, CLX also records the contents of graphics -contexts in a cache associated with each display. This local caching -of graphics contexts has two important advantages: - -@enumerate - -@item -Communication efficiency -- Changes to attribute values in a -@var{gcontext} are first made only in the local cache. Just before a -@var{gcontext} is actually used, CLX automatically sends any changes -to the X server, batching all changes into a single request. - -@item -Inquiring @var{gcontext} contents -- Accessor functions can be used -to return the value of any individual @var{gcontext} component by -reading the copy of the @var{gcontext} from the cache. This kind of -inquiry is not supported by the basic X protocol. There is no way for -a client program to request an X server to return the contents of a -@var{gcontext}. -@end enumerate - - -Caching graphics contexts can result in a synchronization problem if -more than one client program modifies a graphics context. However, -this problem is unusual. Sharing a graphics context among several -clients, while possible, is not expected to be useful and is not very -easy to do. At any rate, a client program can choose to not cache a -@var{gcontext} when it is created. - -Each client program must determine its own policy for creating and -using graphics contexts. Depending on the display hardware and the -server implementation, creating a new graphics context can be more or -less expensive than modifying an existing one. In general, some amount -of graphics context information can be cached in the display hardware, -in which case modifying the hardware cache is faster than replacing -it. Typical display hardware can cache only a small number of graphics -contexts. Graphics output is fastest when only a few graphics contexts -are used without heavy modifications. - -This section explains the CLX functions used to: - -@itemize @bullet - -@item Create a graphics context - -@item Return the contents of a graphics context - -@item Change the contents of a graphics context - -@item Copy a graphics context - -@item Free a graphics context -@end itemize - - -@menu -* Creating Graphics Contexts:: -* Graphics Context Attributes:: -* Copying Graphics Contexts:: -* Destroying Graphics Contexts:: -* Graphics Context Cache:: -@end menu - -@node Creating Graphics Contexts, Graphics Context Attributes, Graphics Contexts, Graphics Contexts -@section Creating Graphics Contexts - -To create a graphics context, use @var{create-gcontext}. - -@defun create-gcontext &key :arc-mode :background (:cache-p t) :cap-style :clip-mask :clip-ordering :clip-x :clip-y :dash-offset :dashes :drawable :exposures :fill-rule :fill-style :font :foreground :function :join-style :line-style :line-width :plane-mask :stipple :subwindow-mode :tile :ts-x :ts-y - -@table @var -@item :cache-p -Specifies if this graphics context should be cached locally by CLX. If -@var{nil} then the state is not cached, otherwise a local cache is -kept. -@item :drawable -The @var{drawable} whose root and depth are to be associated with -this graphics context. This is a required keyword argument. -@item :arc-mode -@itemx :background -@itemx :cap-style -@itemx :clip-mask -@itemx :clip-ordering -@itemx :clip-x -@itemx :clip-y -@itemx :dash-offset -@itemx :dashes -@itemx :exposures -@itemx :fill-rule -@itemx :fill-style -@itemx :font -@itemx :foreground -@itemx :function -@itemx :join-style -@itemx :line-style -@itemx :line-width -@itemx :plane-mask -@itemx :stipple -@itemx :subwindow-mode -@itemx :tile -@itemx :ts-x -@itemx :ts-y -Initial attribute values for the graphics context. -@end table - -Creates, initializes, and returns a graphics context -(@var{gcontext}). The graphics context can only be used with -destination drawables having the same root and depth as the specified -@var{:drawable}. If @var{:cache-p} is non-@var{nil}, the graphics -context state is cached locally, and changing a component has no -effect unless the new value differs from the cached value. Changes to -a graphics context (@code{setf} and @var{with-gcontext}) are always -deferred regardless of the cache mode and sent to the server only when -required by a local operation or by an explicit call to -@var{force-gcontext-changes}. - -All of the graphics context components are set to the values that are -specified by the keyword arguments, except that a value of @var{nil} -causes the default value to be used. These default values are as -follows: - -@multitable {Component} {Default Value} -@item @var{arc-mode} @tab @var{:pie-slice} -@item @var{background} @tab 1 -@item @var{cap-style} @tab @var{:butt} -@item @var{clip-mask} @tab @var{:none} -@item @var{clip-ordering} @tab @var{:unsorted} -@item @var{clip-x} @tab 0 -@item @var{clip-y} @tab 0 -@item @var{dash-offset} @tab 0 -@item @var{dashes} @tab 4 (that is, the list '(4, 4)) -@item @var{exposures} @tab @var{:on} -@item @var{fill-rule} @tab @var{:even-odd} -@item @var{fill-style} @tab @var{:solid} -@item @var{font} @tab server dependent -@item @var{foreground} @tab 0 -@item @var{function} @tab @var{boole-1} -@item @var{join-style} @tab @var{:miter} -@item @var{line-style} @tab @var{:solid} -@item @var{line-width} @tab 0 -@item @var{plane-mask} @tab A bit mask of all ones -@item @var{stipple} @tab Pixmap of unspecified size filled with ones -@item @var{subwindow-mode} @tab @var{:clip-by-children} -@item @var{tile} @tab Pixmap of an unspecified size filled with the foreground pixel (that is, the client-specified pixel if any, or else 0) -@item @var{ts-x} @tab 0 -@item @var{ts-y} @tab 0 -@end multitable - - -Note that foreground and background do not default to any values that -are likely to be useful on a color display. Since specifying a -@var{nil} value means use the default, this implies for clip-mask that -an empty rectangle sequence cannot be specified as an empty list; -@var{:none} must be used instead. Specifying a @var{stringable} for -font causes an implicit @var{open-font} call to occur. - -@table @var -@item gcontext -Type @var{gcontext}. -@end table - -@end defun - - -@node Graphics Context Attributes, Copying Graphics Contexts, Creating Graphics Contexts, Graphics Contexts -@section Graphics Context Attributes - -The following paragraphs describe the CLX functions used to return or -change the attributes of a @var{gcontext}. Functions that return the -contents of a @var{gcontext} return @var{nil} if the last value stored -is unknown (for example, if the @var{gcontext} was not cached or if -the @var{gcontext} was not created by the inquiring client). - -@defun gcontext-arc-mode gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the arc-mode attribute of the -specified graphics context. - -The arc-mode attribute of a graphics context controls the kind of -filling, if any, to be done by the @var{draw-arcs} function. A value -of @var{:chord} specifies that arcs are filled inward to the chord -between the end points of the arc. @var{:pie-slice} specifies that -arcs are filled inward to the center point of the arc, creating a pie -slice effect. - -@table @var -@item arc-mode -Either @var{:chord} or @var{:pie-slice}. -@end table - -@end defun - - -@defun gcontext-background gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the background attribute of the -specified graphics context. - -The background attribute specifies the pixel value drawn for pixels -that are not set in a bitmap and for pixels that are cleared by a -graphics operation, such as the gaps in dashed lines. - -@table @var -@item background -Type @var{card32}. -@end table - -@end defun - - -@defun gcontext-cache-p gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the local cache mode for the -@emph{gcontext}. If true, the state of the @emph{gcontext} is cached -by CLX and changes to its attributes have no effect unless the new -value differs from its cached value. - -@table @var -@item cache-p -Type @var{boolean}. -@end table - -@defun gcontext-cap-style gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the cap-style attribute of the -specified graphics context. - -The cap-style attribute of a graphics context defines how the end -points of a path are drawn. The possible values and their -interpretations are as follows: -@multitable {Cap-Style} {Interpretations} -@item @var{:butt} -@tab Square at the end point (perpendicular to the slope of the line) with no projection beyond. - -@item @var{:not-last} -@tab -Equivalent to @var{:butt}, except that for a line-width of zero or one -the final end point is not drawn. - -@item @var{:projecting} -@tab -Square at the end, but the path continues beyond the end point for a -distance equal to half the line-width. This is equivalent to -@var{:butt} for line-width zero or one. - -@item @var{:round} -@tab -A circular arc with the radius equal to 1/2 of the line-width, -centered on the end point. This is equivalent to @var{:butt} for -line-width zero or one. -@end multitable - -The following table describes what happens when the end points of a -line are identical. The effect depends on both the cap style and line -width. - -@multitable {Cap-Style} {Line-Width} {Effect} -@item @var{:butt} @tab thin -@tab -Device dependent, but the desired effect is that a single pixel is -drawn. - -@item @var{:butt} @tab wide -@tab -Nothing is drawn. - -@item @var{:not-last} @tab thin -@tab -Device dependent, but the desired effect is that nothing is drawn. - -@item @var{:projecting} @tab thin -@tab -Same as @var{:butt} with thin line-width. - -@item @var{:projecting} @tab wide -@tab -The closed path is a square, aligned with the coordinate axes, -centered at the end point, with sides equal to the line-width. - -@item @var{:round} @tab wide -@tab -The closed path is a circle, centered at the end point, with diameter equal to the line-width. - -@item @var{:round} @tab thin -@tab -Same as @var{:butt} with thin line-width. - -@end multitable - -@table @var -@item cap-style -One of @var{:butt}, @var{:not-last}, @var{:projecting}, or @var{:round}. -@end table - -@end defun - - -@defun gcontext-clip-mask gcontext &optional ordering - -@table @var -@item gcontext -A @var{gcontext}. -@item ordering -One of @var{:unsorted}, @var{:y-sorted}, @var{:yx-banded}, @var{:yx-sorted}, or @var{nil}. -@end table - -Returns and (with @code{setf}) changes the clip-mask attribute of the -graphics context. - -When changing the clip-mask attribute, the new clip-mask can be -specified as a pixmap or a @var{rect-seq} or as the values @var{:none} -or @var{nil}. The ordering argument can be specified only with -@code{setf} when the new clip-mask is a @var{rect-seq}. - -The clip-mask attribute of a graphics context affects all graphics -operations and is used to restrict output to the destination -drawable. The clip-mask does not clip the source of a graphics -operation. A value of @var{:none} for clip-mask indicates that no -clipping is to be done. - -If a pixmap is specified as the clip-mask, it must have depth one and -the same root as the specified graphics context. Pixels where the -clip-mask has a one bit are drawn. Pixels outside the area covered by -the clip-mask or where the clip-mask has a zero bit are not drawn. - -If a sequence of rectangles is specified as the clip-mask, the output -is clipped to remain contained within the rectangles. The rectangles -should be non-intersecting, or the results of graphics operations will -be undefined. The rectangle coordinates are interpreted relative to -the clip origin. Note that the sequence of rectangles can be empty, -which effectively disables output. This is the opposite of setting the -clip-mask to @var{:none}. - -If known by the client, the ordering of clip-mask rectangles can be -specified to provide faster operation by the server. A value of -@var{:unsorted} means the rectangles are in arbitrary order. A value -of @var{:y-sorted} means that the rectangles are non-decreasing in -their Y origin. A @var{:yx-sorted} value is like @var{:y-sorted} with -the additional constraint that all rectangles with an equal Y origin -are non-decreasing in their X origin. A @var{:yx-banded} value -additionally constrains @var{:yx-sorted} by requiring that, for every -possible Y scan line, all rectangles that include that scan line have -an identical Y origins and Y extents. If incorrect ordering is -specified, the X server may generate an error, but it is not required -to do so. If no error is generated, the results of the graphics -operations are undefined. - - - -@end defun - - -@defun gcontext-clip-x gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the clip-x attribute of the -specified graphics context. - -The clip-x and clip-y attributes specify the origin for the clip-mask, -whether it is a pixmap or a sequence of rectangles. These coordinates -are interpreted relative to the origin of whatever destination -drawable is specified in a graphics operation. - -@table @var -@item clip-x -Type @var{int16}. -@end table - -@end defun - -@defun gcontext-clip-y gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the clip-y attribute of the -specified graphics context. - -The clip-x and clip-y attributes specify the origin for the clip-mask, -whether it is a pixmap or a sequence of rectangles. These coordinates -are interpreted relative to the origin of whatever destination -drawable is specified in a graphics operation. -@table @var -@item clip-y -Type @var{int16}. -@end table - -@end defun - - -@defun gcontext-dash-offset gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the dash-offset attribute of the -specified graphics context. - -The dash-offset attribute of a graphics context defines the phase of -the pattern contained in the dashes attribute. This phase specifies -how many elements (pixels) into the path the pattern should actually -begin in any single graphics operation. Dashing is continuous through -path elements combined with a join-style, but is reset to the -dash-offset each time a cap-style is applied at a line end point. -@table @var -@item dash-offset -Type @var{card16}. -@end table - -@end defun - - -@defun gcontext-dashes gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the dashes attribute of the -specified graphics context. The sequence must be non-empty and the -elements must be non-zero @var{card8} values. - -The dashes attribute in a graphics context specifies the pattern that -is used for graphics operations which use the dashed line styles. It -is a non-@var{nil} sequence with each element representing the length -of a single dash or space. The initial and alternating elements of the -dashes are the even dashes, while the others are the odd dashes. An -odd length sequence is equivalent to the same sequence concatenated -with itself to produce an even length sequence. All of the elements of -a dashes sequence must be non-zero. - -Specifying a single integer value, @emph{N}, for the dashes attribute -is an abbreviated way of specifying a two element sequence with both -elements equal to the specified value [@emph{N}, @emph{N}]. - -The unit of measure for dashes is the same as in the ordinary -coordinate system. Ideally, a dash length is measured along the slope -of the line, but server implementations are only required to match -this ideal for horizontal and vertical lines. -@table @var -@item dashes -Type @var{sequence} or @var{card8}. -@end table - -@end defun - - -@defun gcontext-display gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @var{display} object associated with the specified -@emph{gcontext}. -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun gcontext-equal gcontext-1 gcontext-2 - -@table @var -@item gcontext-1 -@itemx gcontext-2 -A @var{gcontext}. -@end table - -Returns true if the two arguments refer to the same server resource, -and @var{nil} if they do not. -@table @var -@item equal-p -Type @var{boolean}. -@end table - -@end defun - - -@defun gcontext-exposures gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the exposures attribute of the -specified graphics context. - -The exposures attribute in a graphics context controls the generation -of @var{:graphics-exposure} events for calls to the @var{copy-area} -and @var{copy-plane} functions. If @var{:on}, -@var{:graphics-exposure} events will be reported when calling the -@var{copy-area} and @var{copy-plane} functions with this graphics -context. Otherwise, if @var{:off}, the events will not be reported. -@table @var -@item exposures -Either @var{:off} or @var{:on}. -@end table - -@end defun - - -@defun gcontext-fill-rule gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the fill-rule attribute of the -specified graphics context. - -The fill-rule attribute in a graphics context specifies the rule used -to determine the interior of a filled area. It can be specified as -either @var{:even-odd} or @var{:winding}. - -The @var{:even-odd} rule defines a point to be inside if any infinite -ray starting at the point crosses the border an odd number of -times. Tangencies do not count as a crossing. - -The @var{:winding} rule defines a point to be inside if any infinite -ray starting at the point crosses an unequal number of clockwise and -counterclockwise directed border segments. A clockwise directed border -segment crosses the ray from left to right as observed from the -point. A counterclockwise segment crosses the ray from right to left -as observed from the point. The case where a directed line segment is -coincident with the ray is uninteresting because you can simply choose -a different ray that is not coincident with a segment. - -For both @var{:even-odd} and @var{:winding}, a point is infinitely small, and the border is an -infinitely thin line. A pixel is inside if the center point of the pixel is inside, and the center -point is not on the border. If the center point is on the border, the pixel is inside if, and -only if, the polygon interior is immediately to its right (x increasing direction). Pixels -with centers along a horizontal edge are a special case and are inside if, and only if, the -polygon interior is immediately below (y increasing direction). -@table @var -@item fill-rule -Either @var{:even-odd} or @var{:winding}. -@end table - -@end defun - -@defun gcontext-fill-style gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the fill-style attribute of the -specified graphics context. - -The fill-style attribute of a graphics context defines the contents of -the source for line, text, and fill graphics operations. It determines -whether the source image is drawn with a solid color, a tile, or a -stippled tile. The possible values and their meanings are as follows: - -@table @var -@item :opaque-stippled -Filled with a tile with the same width and height as stipple, but with -the background value used everywhere stipple has a zero and the -foreground pixel value used everywhere stipple has a one. - -@item :solid -Filled with the foreground pixel value. - -@item :stippled -Filled with the foreground pixel value masked by stipple. - -@item :tiled -Filled with tile. -@end table - - -When drawing lines with line-style @var{:double-dash}, the filling of -the odd dashes are controlled by the fill-style in the following -manner: - -@table @var -@item :opaque-stippled -Same as for even dashes. - -@item :solid -Filled with the background pixel value. - -@item :stippled -Filled with the background pixel value masked by stipple. - -@item :tiled -Filled the same as the even dashes. -@end table - -@table @var -@item fill-style -One of @var{:opaque-stippled}, @var{:solid}, @var{:stippled}, or @var{:tiled}. -@end table - -@end defun - - -@defun gcontext-font gcontext &optional metrics-p - -@table @var -@item gcontext -A @var{gcontext}. - -@item metrics-p -Specifies whether a pseudo-font is returned when the real font stored -in the graphics context is not known. The default is @var{nil}, which -means do not return a pseudo-font. -@end table - -Returns and (with @code{setf}) changes the @emph{font} attribute of the -specified graphics context. If the stored font is known, it is -returned. If it is not known and the @emph{metrics-p} argument is -@var{nil}, then @var{nil} is returned. If the font is not known and -@emph{metrics-p} is true, then a pseudo-font is constructed and -returned. For a constructed pseudo-font, full metric and property -information can be obtained, but it does not have a name or a resource -ID, and attempts to use it where a resource ID is required results in -an invalid-font error. - -The font attribute in a graphics context defines the default text font -used in text drawing operations. When setting the value of the font -attribute, either a @var{font} object or a font name can be used. If a -font name is passed, @var{open-font} is call automatically to get the -@var{font} object. - -@table @var -@item font -Type @var{font} or @var{null}. -@end table -@end defun - -@end defun - - - -@defun gcontext-foreground gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the foreground attribute of the -specified graphics context. - -The foreground attribute of a graphics context specifies the pixel -value drawn for set bits in a bitmap and for bits set by a graphics -operation. -@table @var -@item foreground -Type @var{card32}. -@end table - -@end defun - - -@defun gcontext-function gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{function} of the specified graphics context. - -In all graphic operations, given a source pixel and a corresponding -destination pixel, the resulting pixel drawn is computed bitwise on -the bits of the source and destination pixels. That is, a logical -operation is used to combine each bit plane of corresponding source -and destination pixels. The graphics context function attribute -specifies the logical operation used via one of the 16 operation codes -defined by Common Lisp for the @var{boole} function. - -The following table shows each of the logical operation codes that can -be given by the function attribute. For each operation code, its -result is shown as a logical function of a source pixel @emph{S} and a -destination pixel @emph{D}. - -@multitable {Symbol} {Result} -@item @var{boole-1} -@tab @emph{S} -@item @var{boole-2} -@tab @emph{D} -@item @var{boole-andc1} -@tab (logandc1 @emph{S D}) -@item @var{boole-andc2} -@tab (logandc2 @emph{S D}) -@item @var{boole-and} -@tab (logand @emph{S D}) -@item @var{boole-c1} -@tab (lognot @emph{S}) -@item @var{boole-c2} -@tab (lognot @emph{D}) -@item @var{boole-clr} -@tab 0 -@item @var{boole-eqv} -@tab (logeqv @emph{S D}) -@item @var{boole-ior} -@tab (logior @emph{S D}) -@item @var{boole-nand} -@tab (lognand @emph{S D}) -@item @var{boole-nor} -@tab (lognor @emph{S D}) -@item @var{boole-orc1} -@tab (logorc1 @emph{S D}) -@item @var{boole-orc2} -@tab (logorc2 @emph{S D}) -@item @var{boole-set} -@tab 1 -@item @var{boole-xor} -@tab (logxor @emph{S D}) -@end multitable - -@table @var -@item function -Type @var{boole-constant}. -@end table - -@end defun - - -@defun gcontext-id gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the unique ID that has been assigned to the specified graphics -context. -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun gcontext-join-style gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the join-style attribute of the -specified graphics context. - -The join-style attribute of a graphics context defines how the segment -intersections are drawn for wide polylines. The possible values and -their interpretations are as follows: - -@table @var -@item :bevel -Uses @var{:butt} end point styles with the triangular notch filled. -@item :miter -The outer edges of two lines extend to meet at an angle. -@item :round -A circular arc with diameter equal to the line-width, centered on the join point. -@end table - -When the end points of a polyline segment are identical, the effect is -as if the segment was removed from the polyline. When a polyline is a -single point, the effect is the same as when the cap-style is applied -at both end points. - -@table @var -@item join-style -One of @var{:bevel}, @var{:miter}, or @var{:round}. -@end table - -@end defun - - -@defun gcontext-line-style gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the line-style attribute of the -specified graphics context. - -The line-style attribute of a graphics context specifies how (which -sections of) lines are drawn for a path in graphics operations. The -possible values and their meanings are as follows: - -@table @var -@item :solid -The full path is drawn. - -@item :double-dash -The full path is drawn, but the even dashes are filled differently -than the odd dashes. The @var{:butt} style is used where even and odd -dashes meet (see paragraph 5.4.7, Fill-Rule and -Fill-Style). - -@item :on-off-dash -Only the even dashes are drawn, with cap-style applied to all internal -ends of the individual dashes, except @var{:not-last} is treated as -@var{:butt}. -@end table - -@table @var -@item line-style -One of @var{:dash}, @var{:double-dash}, or @var{:solid}. -@end table - -@end defun - - -@defun gcontext-line-width gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{line-width} of the specified graphics context. - -The line-width is measured in pixels and can be greater than or equal -to one (wide line) or can be the special value zero (thin line). - -Wide lines are drawn centered on the path described by the graphics -operation. Unless otherwise specified by the join-style or cap-style, -the bounding box of a wide line with end points [x1, y1], [x2, y2], -and width w is a rectangle with vertices at the following real -coordinates: - -[x1 - (w*@emph{sin}/2), y1 + (w*@emph{cos}/2)], [x1+ (w*@emph{sin}/2), y1 - (w*@emph{cos}/2)],@* -[x2 - (w*@emph{sin}/2), y2 + (w*@emph{cos}/2)], [x2 + (w*@emph{sin}/2), y2 - (w*@emph{cos}/2)] - -where @emph{sin} is the sine of the angle of the line and @emph{cos} -is the cosine of the angle of the line. A pixel is part of the line -and, hence, is drawn if the center of the pixel is fully inside the -bounding box (which is viewed as having infinitely thin edges). If the -center of the pixel is exactly on the bounding box, it is part of the -line if, and only if, the interior is immediately to its right (x -increasing direction). Pixels with centers on a horizontal edge are a -special case and are part of the line if, and only if, the interior is -immediately below (y increasing direction). - -Thin lines (zero line-width) are always one pixel wide lines drawn -using an unspecified, device dependent algorithm. There are only two -constraints on this algorithm. - -@enumerate -@item -If a line is drawn unclipped from [x1,y1] to [x2,y2] and if another -line is drawn unclipped from [x1+dx,y1+dy] to [x2+dx,y2+dy], a point -[x,y] is touched by drawing the first line if, and only if, the -point [x+dx,y+dy] is touched by drawing the second line. - -@item -The effective set of points comprising a line cannot be affected by -clipping. That is, a point is touched in a clipped line if, and only -if, the point lies inside the clipping region and the point would be -touched by the line when drawn unclipped. -@end enumerate - - -A wide line drawn from [x1,y1] to [x2,y2] always draws the same pixels -as a wide line drawn from [x2,y2] to [x1,y1], not counting cap-style -and join-style. Implementors are encouraged to make this property true -for thin lines, but it is not required. A line-width of zero may -differ from a line-width of one in which pixels are drawn. This -permits the use of many manufacturer's line drawing hardware, which -may run much faster than the more precisely specified wide lines. - -In general, drawing a thin line is faster than drawing a wide line of -width one. However, because of their different drawing algorithms, -thin lines may not mix well, aesthetically speaking, with wide -lines. If it is desirable to obtain precise and uniform results across -all displays, a client should always use a line-width of one, rather -than a line-width of zero. -@table @var -@item line-width -Type @var{card16}. -@end table - -@end defun - - -@defun gcontext-p gcontext - -@table @var -@item gcontext -Type @var{boolean}. -@end table - - - -Returns non-@var{nil} if the argument is a graphics context and - -@end defun - - - - -@defun gcontext-plane-mask gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{plane-mask} of the specified graphics context. - -The plane-mask attribute of a graphics context specifies which bit -planes of the destination drawable are modified during a graphic -operation. The plane-mask is a pixel value in which a 1 bit means that -the corresponding bit plane will be modified and a 0 bit means that -the corresponding bit plane will not be affected during a graphic -operations. Thus, the actual result of a graphic operation depends on -both the function and plane-mask attributes of the graphics context -and is given by the following expression: - -@lisp -(logior (logand - (boole function source destination) - plane-mask) - - (logandc2 - destination - plane-mask)) -@end lisp - -@table @var -@item plane-mask -Type @var{card32}. -@end table - -@end defun - - -@defun gcontext-plist gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - - - -Returns and (with @code{setf}) sets the property list for the specified -@emph{gcontext}. This function provides a hook where extensions can -add data. - -@table @var -@item gcontext-p -Type @var{list}. -@end table - -@end defun - - -@defun gcontext-stipple gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{stipple} of the specified graphics context. - -The stipple attribute of a graphics context is a bitmap used to -prevent certain pixels in the destination of graphics operations from -being affected by tiling. - -The stipple and tile have the same origin. This origin point is -interpreted relative to the origin of whatever destination drawable is -specified in a graphics request. The stipple pixmap must have depth -one and must have the same root as the graphics context. The tile -pixmap must have the same root and depth as the graphics context. For -stipple operations where the fill-style is @var{:stippled} (but not -@var{:opaque-stippled}), the stipple pattern is tiled in a single -plane and acts as an additional clip mask to be @var{and}ed with the -clip-mask. Any size pixmap can be used for stipple or tile, although -some sizes may be faster to use than others. - -Specifying a pixmap for stipple or tile in a graphics context might or -might not result in a copy being made. If the pixmap is later used as -the destination for a graphics operation, the change might or might -not be reflected in the graphics context. If the pixmap is used both -as the destination for a graphics operation and as a stipple or tile, -the results are not defined. - -Some displays have hardware support for tiling or stippling with -patterns of specific sizes. Tiling and stippling operations that -restrict themselves to those sizes may run much faster than such -operations with arbitrary size patterns. CLX provides functions to -determine the best size for stipple or tile (see -@var{query-best-stipple} and @var{query-best-tile}). - -@table @var -@item stipple -Type @var{pixmap}. -@end table - -@end defun - - -@defun gcontext-subwindow-mode gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the subwindow-mode attribute of -the specified graphics context. - -The subwindow-mode attribute of a graphics context specifies whether -subwindows obscure the contents of their parent window during a -graphics operation. For a value of @var{:clip-by-children}, both -source and destination windows are clipped by all viewable -@var{:input-output} class children. This clipping is in addition to -the clipping provided by the clip-mode attribute. For a value of -@var{:include-inferiors}, neither the source nor destination window -is clipped by its inferiors. This results in the inclusion of -subwindow contents in the source and the drawing through of subwindow -boundaries of the destination. The use of @var{:include-inferiors} on -a window of one depth with mapped inferiors of differing depth is not -illegal, but the semantics are not defined by the core protocol. -@table @var -@item subwindow-mode -One of @var{:clip-by-children} or @var{:include-inferiors}. -@end table - -@end defun - - -@defun gcontext-tile gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{tile} of the specified graphics context. - -The tile attribute is a pixmap used to fill in areas for graphics -operations. It is so named because copies of it are laid out side by -side to fill the area. - -The stipple and tile have the same origin. This origin point is -interpreted relative to the origin of whatever destination drawable is -specified in a graphics request. The stipple pixmap must have depth -one and must have the same root as the graphics context. The tile -pixmap must have the same root and depth as the graphics context. For -stipple operations where the fill-style is @var{:stippled} (but not -@var{:opaque-stippled}), the stipple pattern is tiled in a single -plane and acts as an additional clip mask to be @var{and}ed with the -clip-mask. Any size pixmap can be used for stipple or tile, although -some sizes may be faster to use than others. - -Specifying a pixmap for stipple or tile in a graphics context might or -might not result in a copy being made. If the pixmap is later used as -the destination for a graphics operation, the change might or might -not be reflected in the graphics context. If the pixmap is used both -as the destination for a graphics operation and as a stipple or tile, -the results are not defined. - -Some displays have hardware support for tiling or stippling with -patterns of specific sizes. Tiling and stippling operations that -restrict themselves to those sizes may run much faster than such -operations with arbitrary size patterns. CLX provides functions to -determine the best size for stipple or tile (see -@var{query-best-stipple} and @var{query-best-tile}). -@table @var -@item tile -Type @var{pixmap}. -@end table - -@end defun - - -@defun gcontext-ts-x gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{ts-x} attribute of the specified graphics context. - -The ts-x and ts-y attributes of a graphics context are the coordinates -of the origin for tile pixmaps and the stipple. -@table @var -@item ts-x -Type @var{int16}. -@end table - -@end defun - - -@defun gcontext-ts-y gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{ts-y} attribute of the specified graphics context. - -The ts-x and ts-y attributes of a graphics context are the coordinates -of the origin for tile pixmaps and the stipple. -@table @var -@item ts-y -Type @var{int16}. -@end table - -@end defun - - -@defun query-best-stipple width height drawable - -@table @var -@item width -@itemx height -Specifies the width and height of the desired stipple pattern. -@item drawable -A @var{drawable}. -@end table - -Returns the @emph{best-width} and @emph{best-height} for stipple -pixmaps on the @emph{drawable}. - -The @emph{drawable} indicates the screen and possibly the window class -and depth. An @var{:input-only} window cannot be specified as the -@emph{drawable}. The size is returned as width and height values. - -@table @var -@item best-width -@itemx best-height -Type @var{card16}. -@end table - -@end defun - - -@defun query-best-tile width height drawable - -@table @var -@item width -@itemx height -Specifies the width and height of the desired tile pattern. -@item drawable -A @var{drawable}. -@end table - -Returns the @emph{best-width} and @emph{best-height} for tile pixmaps -on the @emph{drawable}. - -The @emph{drawable} indicates the screen and possibly the window class -and depth. An @var{:input-only} window cannot be specified as the -@emph{drawable}. The size is returned as width and height values. - -@table @var -@item best-width -@itemx best-height -Type @var{card16}. -@end table - -@end defun - - -@node Copying Graphics Contexts, Destroying Graphics Contexts, Graphics Context Attributes, Graphics Contexts -@section Copying Graphics Contexts - -CLX provides functions to copy some or all attribute values from one -graphics context to another. These functions are generally more -efficient than using @code{setf} to copy @var{gcontext} attributes -individually. - -@defun copy-gcontext source destination - -@table @var -@item source -The source @var{gcontext}. -@item destination -The destination @var{gcontext}. -@end table - -Copies all the values of the attributes of the source graphics context -into the destination graphics context. The source and destination -graphics contexts must have the same root and depth. - - - -@end defun - - -@defun copy-gcontext-components source destination &rest keys - -@table @var -@item source -The source @var{gcontext}. -@item destination -The destination @var{gcontext}. - -@item keys -The remaining arguments are keywords, of type @var{gcontext-key}, -which specify which attributes of the graphics context are to be -copied. -@end table - -Copies the values of the specified attributes of the source graphics -context to the destination graphics context. The source and -destination graphics contexts must have the same root and depth. - - -@end defun - - -@node Destroying Graphics Contexts, Graphics Context Cache, Copying Graphics Contexts, Graphics Contexts -@section Destroying Graphics Contexts - -To destroy a graphics context, use @var{free-gcontext.} - -@defun free-gcontext gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Deletes the association between the assigned resource ID and the -specified graphics context, and then destroys the graphics context. - - -@end defun - - -@node Graphics Context Cache, , Destroying Graphics Contexts, Graphics Contexts -@section Graphics Context Cache - -CLX provides a set of functions to control the automatic graphics context -caching mechanism. - - -@defun force-gcontext-changes gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Forces any delayed changes to the specified graphics context to be -sent out to the server. Note that @var{force-gcontext-changes} is -called by all of the graphics functions. - - - -@end defun - -@defmac with-gcontext gcontext &key :arc-mode :background :cap-style :clip-mask :clip-ordering :clip-x :clip-y :dashes :dash-offset :exposures :fill-rule :fill-style :font :foreground :function :join-style :line-style :line-width :plane-mask :stipple :subwindow-mode :tile :ts-x :ts-y &allow-other-keys &body body -@anchor{with-gcontext} - -Changes the indicated graphics context components to the specified -values only within the dynamic extent of the body. @var{with-gcontext} -works on a per-process basis in a multiprocessing environment. The -@emph{body} is not surrounded by a @var{with-display} form. If there -is no local cache for the specified graphics context, or if some of -the component states are unknown, @var{with-gcontext} does the save -and restore by creating a temporary graphics context and copying -components to and from it using @var{copy-gcontext-components}. - -@table @var -@item gcontext -A @var{gcontext}. -@item :arc-mode -@itemx :background -@itemx :cap-style -@itemx :clip-mask -@itemx :clip-ordering -@itemx :clip-x -@itemx :clip-y -@itemx :dashes -@itemx :dash-offset -@itemx :exposures -@itemx :fill-rule -@itemx :fill-style -@itemx :font -@itemx :foreground -@itemx :function -@itemx :join-style -@itemx :line-style -@itemx :line-width -@itemx :plane-mask -@itemx :stipple -@itemx :subwindow-mode -@itemx :tile -@itemx :ts-x -@itemx :ts-y -These keyword arguments and associated values specify which graphics -context components are to be changed. Any components not specified are -left unmodified. @xref{Creating Graphics Contexts}, for more information. -@item body -The body of code which will have access to the altered graphics context. -@end table - -@end defmac - -@node Graphic Operations, Images, Graphics Contexts, Top -@chapter Graphic Operations - -Once connected to an X server, a client can use CLX functions to -perform graphic operations on drawables. - -This section describes CLX functions to: - -@itemize @bullet - -@item Operate on areas and planes - -@item Draw points - -@item Draw lines - -@item Draw rectangles - -@item Draw arcs - -@item Draw text - -@end itemize - - -@menu -* Area and Plane Operations:: -* Drawing Points:: -* Drawing Lines:: -* Drawing Rectangles:: -* Drawing Arcs:: -* Drawing Text:: -@end menu - -@node Area and Plane Operations, Drawing Points, Graphic Operations, Graphic Operations -@section Area and Plane Operations - - -@var{clear-area} clears an area or an entire window to the background. -Since pixmaps do not have backgrounds, they cannot be filled by using -the functions described in the following paragraphs. Instead, you -should use @var{draw-rectangle}, which sets the pixmap to a known -value. @xref{Drawing Rectangles}, for information on -@var{draw-rectangle}. - -@defun clear-area window &key (:x 0) (:y 0) :width :height :exposures-p - -@table @var -@item window -A @var{window}. - -@item :x -@itemx :y -Upper-left corner of the area to be cleared. These coordinates are -relative to the @emph{window} origin. Type is @var{int16}. - -@item :width -The width of the area to clear or @var{nil} to clear to the remaining -width of the window. Type is @var{card16} or @var{null}. - -@item :height -The height of the area to clear or @var{nil} to clear to the remaining -height of the window. Type is @var{card16} or @var{null}. - -@item :exposures-p -Specifies if @var{:exposure} events should be generated for the -affected areas. Type @var{boolean}. -@end table - -Draws a rectangular area in the specified @emph{window} with the -background pixel or pixmap of the @emph{window}. The @var{:x} and -@var{:y} coordinates are relative to the @emph{window} origin, and -specify the upper-left corner of the rectangular area that is to be -cleared. A @var{nil} or zero value for @var{:height} or @var{:width} -clears the remaining area (height - y or width - x). If the -@emph{window} has a defined background tile, the rectangle is tiled by -using a plane-mask of all ones and a function of @var{:copy}. If the -@emph{window} has background @var{:none}, the contents of the -@emph{window} are not changed. In either case, if @var{:exposures-p} -is non-@var{nil}, then one or more @var{:exposure} events are -generated for regions of the rectangle that are either visible or are -being retained in a backing store. - -To clear the entire area in a specified @emph{window}, use -(@var{clear-area} @emph{window}). - - -@end defun - -@defun copy-area source gcontext source-x source-y width height destination destination-x destination-y - -@table @var -@item source -Source @var{drawable}. - -@item gcontext -The graphics context to use during the copy operation. - -@item source-x -@itemx source-y -The x and y coordinates of the upper-left corner of the area in the -@emph{source} @var{drawable}. These coordinates are relative to the -@emph{source} @var{drawable} origin. Type is @var{int16}. - -@item width -@itemx height -The width and height of the area being copied. These apply to both the -@emph{source} and @emph{destination} areas. Type is @var{card16}. - -@item destination -The destination @var{drawable}. - -@item destination-x -@itemx destination-y -The x and y coordinates of the upper left corner of the area in the -@emph{destination} @var{drawable}. These coordinates are relative to -the @emph{destination} @var{drawable} origin. Type is @var{int16}. -@end table - -Copies the specified rectangular area from the @emph{source} -@var{drawable} to the specified rectangular area of the -@emph{destination} @var{drawable}, combining them as specified in the -supplied graphics context (@emph{gcontext}). The @emph{x} and @emph{y} -coordinates are relative to their respective drawable origin, with -each pair specifying the upper left corner of the area. - -If either regions of the @emph{source} area are obscured and have not -been retained in backing store, or regions outside the boundaries of -the @emph{source} @var{drawable} are specified, those regions are not -copied. Instead, the following occurs on all corresponding -@emph{destination} regions that are either visible or are retained in -backing store: - -@itemize @bullet - -@item -If the @emph{destination} rectangle is a window with a background -other than @var{:none}, these corresponding regions of the -@emph{destination} are tiled, using plane-mask of all ones and -function of @var{boole-1} (copy source), with that background. - -@item -If the exposures attribute of the graphics context is @var{:on}, -then @var{:graphics-exposure} events for all corresponding -@emph{destination} regions are generated (regardless of tiling or -whether the @emph{destination} is a window or a pixmap). - -@item -If exposures is @var{:on} but no regions are exposed, a -@var{:no-exposure} event is generated. Note that by default, -exposures is @var{:on} for new graphics contexts. @xref{Graphics Contexts}, for further information. - -@end itemize - - -@end defun - -@defun copy-plane source gcontext plane source-x source-y width height destination destination-x destination-y - -@table @var -@item source -The source @var{drawable}. -@item gcontext -The graphics context to use during the copy operation. -@item plane -Specifies the bit-plane of the @emph{source} @var{drawable}. Exactly one bit must be set. -Type is @var{pixel}. -@item source-x -@itemx source-y -The @emph{x} and @emph{y} coordinates of the upper-left corner of the -area in the @emph{source} @var{drawable}. These coordinates are -relative to the @emph{source} @var{drawable} origin. Type is -@var{int16}. - -@item width -@itemx height -The width and height of the area being copied. These apply to both the -@emph{source} and @emph{destination} areas. Type is @var{card16}. - -@item destination -The destination @var{drawable}. - -@item destination-x -@itemx destination-y - -The x and y coordinates of the upper-left corner of the destination -area in the @emph{destination} @var{drawable}. These coordinates are -relative to the @emph{destination} @var{drawable} origin. Type is -@var{int16}. -@end table - -Uses a single bit plane of the specified rectangular area of the -@emph{source} @var{drawable} along with the specified graphics context -(@emph{gcontext}) to modify the specified rectangle area of the -@emph{destination} @var{drawabl}e. The drawables specified by the -@emph{source} and @emph{destination} arguments must have the same root -but need not have the same depth. - -Effectively, this operation forms a pixmap of the same depth as -@emph{destination} and with a size specified by the @emph{source} -area. It then uses the foreground and background from the graphics -context (foreground where the bit-plane in @emph{source} contains a -one bit, background where the bit-plane in @emph{source} contains a -zero bit), and the equivalent of a @var{copy-area} operation is -performed with all the same exposure semantics. This can also be -thought of as using the specified region of the @emph{source} -bit-plane as a stipple with a fillstyle of @var{:opaque-stippled} for -filling a rectangular area of the @emph{destination}. - - - -@end defun - -@node Drawing Points, Drawing Lines, Area and Plane Operations, Graphic Operations -@section Drawing Points - -The @var{draw-point} and @var{draw-points} functions make use of the following graphics -context components: function, plane-mask, foreground, subwindow-mode, clip-x, -clip-y, clip-ordering, clip-region and clip-mask. - -The @var{draw-point} function uses the foreground pixel and function components of the -graphics context to draw a single point into the specified drawable, while @var{draw-points} -draws multiple points into the specified drawable. These functions are not affected by -the tile or stipple in the graphics context. - - -@defun draw-point drawable gcontext x y - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing the point. -@item x -@itemx y -The @emph{x} and @emph{y} coordinates of the point drawn. Type is @var{int16}. -@end table -Combines the foreground pixel in the @emph{gcontext} with the pixel in -the @emph{drawable} specified by the @emph{x} and @emph{y} -coordinates. - - -@end defun - -@defun draw-points drawable gcontext points &optional relative-p - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing the points. -@item points -A list of points to be drawn in the order listed. The first point is always relative -to the @emph{drawable}'s origin; if @emph{relative-p}, the rest of the points are drawn relative to the -previous point, else they are drawn relative to the @emph{drawable}'s origin. Type is -@var{point-seq}. -@item relative-p -Specifies the coordinate mode used for drawing the pixels either relative to -the origin or to the previous point. Type @var{boolean}. -@end table - -Combines the foreground pixels in the graphics context with the pixels -at each point in the @emph{drawable}. The points are drawn in the -order listed. - -@var{draw-points} requires a mode argument, @emph{relative-p} that -indicates whether the points are relative to the destination origin or -to the previous point. In either case, the first point is always -relative to the destination origin. The rest of the points are -relative either to the @emph{drawable}'s origin or to the previous -point, depending on the value of @emph{relative-p}. - - -@end defun - - -@node Drawing Lines, Drawing Rectangles, Drawing Points, Graphic Operations -@section Drawing Lines - - -The @var{draw-line}, @var{draw-lines}, and @var{draw-segments} functions use the following -graphics context components: background, cap-style, clip-x-origin, clip-y-origin, -clip-mask, dash-list, dash-offset, fill-style, foreground, function, plane-mask, line-width, -line-style, stipple, subwindow-mode, tile, ts-x-origin, and ts-y-origin. - -The @var{draw-lines} function also uses the join-style graphics context component. - -@defun draw-line drawable gcontext x1 y1 x2 y2 &optional relative-p - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing the line. -@item x1 -@itemx y1 -@itemx x2 -@itemx y2 -The end points of the line. -@item relative-p -Specifies the coordinate mode used for drawing the line either relative to -the origin or the previous point. In either case, the first point is always drawn -relative to the @emph{drawable}'s origin. -@end table - -Draws a line from the point @emph{x1},@emph{y1} to the point -@emph{x2},@emph{y2}. When @emph{relative-p} is true, the first point -is relative to the destination origin but the second point is relative -to the first point. When @emph{relative-p} is @var{nil}, both points -are relative to the destination origin. - - -@end defun - - -@defun draw-lines drawable gcontext points &key :relative-p :fill-p (:shape :complex) - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing the lines. -@item points -A list of points that define the lines. Type is @var{point-seq}. -@item :relative-p -The coordinate mode of the points. -@item :fill-p -When true, a filled polygon is drawn instead of a polyline. -@item :shape -A hint that allows the server to use the most efficient area fill algorithm. -Either @var{:convex}, @var{:non-convex}, or @var{:complex}. -@end table - -Draws a line between each pair of @emph{points} in the points -list. The lines are drawn in the order listed and join correctly at -all intermediate points. The join-style graphics context component -defines the type of joint to use. When the first and last points -coincide, the first and last lines also join correctly to produce a -hollow polygon. - -When @var{:relative-p} is true, the first point is always relative to -the destination origin, but the rest are relative to the previous -point. When @var{:relative-p} is @var{nil}, the rest of the points -are drawn relative to the destination origin. - -When @var{:fill-p} is true, the polygon defined by the @emph{points} -list is filled. The @var{:shape} keyword provides the server with a -hint about how to fill the polygon. @var{:shape} can be either -@var{:complex} (by default), @var{:convex}, or @var{:non-convex}. - -The @var{:convex} operand is the simplest type of area and the -fastest to fill. A fill area is convex if every straight line -connecting any two interior points is entirely inside the area. For -example, triangles and rectangles are convex polygons. - -The @var{:non-convex} operand is for filling an area that is not -convex and is also not self-intersecting. Filling this type of area is -harder than filling a convex area, but easier than filling one that is -self-intersecting. For example, the shape of the letter "T" is -non-convex and non-self-intersecting. - -The @var{:complex} operand is the most general (and therefore the -hardest) type of fill area. A complex fill area can be non-convex and -self-intersecting. For example, draw the outline of a bow tie, without -lifting your pencil or tracing over an edge twice. This shape is -non-convex and intersects itself at the knot in the middle. - -@var{NOTE:} Unless you are sure that a shape is @var{:convex} or -@var{:non-convex}, it should always be drawn as a @var{:complex} -shape. If @var{:convex} or @var{:non-convex} is specified -incorrectly, the graphics result is undefined. - - -@end defun - - -@defun draw-segments drawable gcontext segments - -@table @var -@item drawable -The destination @var{drawable} to receive the line segments. -@item gcontext -Specifies the graphics context for drawing the lines. -@item segments -The points list for the segments to draw. Type is @var{seq}. -@end table - -Draws multiple lines, not necessarily connected. @emph{segments} is a -sequence of the form @{x1 y1 x2 y2@}*, in which each subsequence -specifies the end points of a line segment. Line segments are drawn in -the order given by @emph{segments}. Unlike @var{draw-lines}, no -joining is performed at coincident end points. - - -@end defun - - -@node Drawing Rectangles, Drawing Arcs, Drawing Lines, Graphic Operations -@section Drawing Rectangles - - -The @var{draw-rectangle} and @var{draw-rectangles} functions draw -hollow or filled outlines of the specified rectangle or rectangles as -if a five-point polyline were specified for each rectangle, as -follows: - -@display -[x,y,] [x+width,y] [x+width,y+height] [x,y+height] [x,y] -@end display - -@var{draw-rectangle} and @var{draw-rectangles} use the following -graphics context components: background, function, plane-mask, -foreground, subwindow-mode, cap-style, clip-x, clip-y, clip-ordering, -clip-region and clip-mask, dash-list, dash-offset, fill-style, -join-style, line-width, line-style, stipple, tile, ts-x-origin, and -ts-y-origin. - -@defun draw-rectangle drawable gcontext x y width height &optional fill-p - -@table @var -@item drawable -The destination @var{drawable}. - -@item gcontext -The graphics context for drawing the rectangle. - -@item x -@itemx y -The x and y coordinates that define the upper left corner of the rectangle. The -coordinates are relative to the destination origin. Type is @var{int16}. - -@item width -@itemx height -Specifies the width and height that define the outline of the rectangle. -Type is @var{card16}. - -@item fill-p -Specifies whether the rectangle is filled or not. Type @var{boolean}. -@end table - -Draws a rectangle defined by the @emph{x}, @emph{y}, @emph{width}, and - -@emph{height} arguments. - - - -@end defun - - -@defun draw-rectangles drawable gcontext rectangles &optional fill-p - -@table @var -@item drawable -The destination @var{drawable}. - -@item gcontext -The graphics context. - -@item rectangles -A list specifying the upper left corner x and y, width and height of the -rectangles. Type is @var{rect-seq}. - -@item fill-p -Specified if the rectangles are filled or not. Type is @var{boolean}. -@end table - -Draws the rectangles in the order listed in @emph{rectangles}. For the -specified @emph{rectangle} or @emph{rectangles}, no pixel is drawn -more than once. The x and y coordinates of each rectangle are relative -to the destination origin and define the upper left corner of the -rectangle. If rectangles intersect, the intersecting pixels are drawn -multiple times. - - - -@end defun - -@node Drawing Arcs, Drawing Text, Drawing Rectangles, Graphic Operations -@section Drawing Arcs - -@var{draw-arc} draws a single circular or an elliptical arc, while -@var{draw-arcs} draws multiple circular or elliptical -arcs. @var{draw-arc} and @var{draw-arcs} use the following graphics -context components: arc-mode, background, cap-style, clip-x, clip-y, -clip-mask, dash-list, dash-offset, fill-style, foreground, join-style, -function, plane-mask, line-width, line-style, stipple, subwindow-mode, -tile, ts-x-origin, and ts-y-origin. - -@defun draw-arc drawable gcontext x y width height angle1 angle2 &optional fill-p - -@table @var -@item drawable -The destination @var{drawable}. - -@item gcontext -The graphics context for drawing the arc. - -@item x -@itemx y -The x and y coordinates of the arc rectangle relative to the origin of the @emph{drawable}. -Type is @var{int16}. - -@item width -@itemx height -Specifies the width and height of the rectangle. These are the major and -minor axes of the arc. Type is @var{card16}. - -@item angle1 -Specifies the start of the arc in radians. Type is @var{angle}. - -@item angle2 -Specifies the direction and end point of the arc. Type is @var{angle}. - -@item fill-p -Specifies whether the arc is filled or not. Type @var{boolean}. -@end table - -Draws either a circular or an elliptical arc. Also, outlined or filled -arcs can be drawn. Each arc is specified by a rectangle (@emph{x}, -@emph{y}, @emph{width}, and @emph{height}) and two angles -(@emph{angle1} and @emph{angle2}). The angles are signed integers in -radians, with positive indicating counterclockwise motion and negative -indicating clockwise motion. The start of the arc is specified by -@emph{angle1}, and the path and extent of the arc is specified by -@emph{angle2} relative to the start of the arc. If the magnitude of -@emph{angle2} is greater than 360 degrees, it is truncated to 360 -degrees. The @emph{x} and @emph{y} coordinates of the rectangle are -relative to the @emph{drawable}'s origin. - -For example, an arc specified as -[@emph{x},@emph{y},@emph{width},@emph{height},@emph{angle1},@emph{angle2}] -has the origin of the major and minor axes at: - -@display -[@emph{x}+(@emph{width}/2),@emph{y}+(@emph{height}/2)] -@end display - -The infinitely thin path describing the entire circle/ellipse -intersects the horizontal axis at: - -@display -[@emph{x},@emph{y}+(@emph{height}/2)] and [@emph{x}+@emph{width},@emph{y}+(@emph{height}/2)] -@end display - -The intersection of the vertical axis is at: - -@display -[@emph{x}+(@emph{width}/2),@emph{y}] and [@emph{x}+(@emph{width}/2),@emph{y}+@emph{height}] -@end display - -These coordinates can be fractional; that is, they are not truncated -to discrete coordinates. Note that the angle values are slightly -different in CLX than in the X protocol specification. - -If @emph{fill-p} is @var{nil}, then only the outline of the arc is -drawn. Otherwise, if @emph{fill-p} is true, @var{draw-arc} fills the -area bounded by the arc outline and one or two line segments, -depending on the arc-mode. If the arc-mode is @var{:chord}, the -filled area is bounded by the arc outline and the line segment joining -the arc end points. If the arc-mode is @var{:pie-slice}, the filled -area is bounded by the arc outline and the two line segments joining -each arc end point with the center point. - - - -@end defun - - -@defun draw-arcs drawable gcontext arcs &optional fill-p - -@table @var -@item drawable -Specifies the @var{drawable} where you want the arcs drawn. -@item gcontext -Specifies the graphics context for drawing the arc. -@item arcs -A sequence containing the width, height, angle1, and angle2 arguments defining -the arcs. See @var{draw-arc} for more detail. Type is @var{arc-seq}. -@item fill-p -Specifies whether the arcs are filled or not. Type is @var{boolean}. -@end table - -Draws circular or elliptical, outlined or filled arcs. Each arc is -specified by a rectangle and two angles. For a more detailed -description, see @var{draw-arc}. - -The arcs are filled in the order listed. For any given arc, no pixel is drawn more than -once. If regions intersect, the intersecting pixels are drawn multiple times. - - -@end defun - - -@node Drawing Text, , Drawing Arcs, Graphic Operations -@section Drawing Text - -CLX provides functions for drawing text using text fonts provided by -the X server. An X font is array of character bit maps indexed by -integer codes. @xref{Font and Characters}, for a complete discussion -of the CLX functions used to manage fonts and characters. - -Since Common Lisp programs typically represent text as sequences of -characters (that is, strings), CLX text functions must be prepared to -convert a Common Lisp character into the integer code used to index the -appropriate character bitmap in a given font. The @var{:translate} -argument to a text function is a function which performs this -conversion. The default @var{:translate} function handles all -characters that satisfy @var{graphic-char-p} by converting each -character into its ASCII code. Note that the assumption made by the -default @var{:translate} function--that is, that an X font indexes -bitmaps by ASCII codes--is often valid, but other encodings are -possible. In general, a @var{:translate} function can perform complex -transformations. It can be used to convert non-character input, to -handle non-ASCII character encodings, and to change the fonts used to -access character bitmaps. The complete behavior of a @var{:translate} -function is given below by describing a prototypical -@var{translate-function}. - -CLX offers two different ways to draw text--filled text and block -text. The @var{draw-glyph} and @var{draw-glyphs} functions create -filled text, in which each character image is treated as an area to be -filled according to the fill-style of the given graphics context, -without otherwise disturbing the surrounding background. In addition, -filled text sends a complex type of server request which allows a series -of font indices, font changes, and horizontal position changes to be -compiled into a single request. Filled text functions use the following -graphics context attributes: background, clip-mask, clip-x-origin, -clip-y-origin, fill-style, font, foreground, function, plane-mask, -stipple, subwindow-mode, tile, ts-x-origin, ts-y-origin. - -Block text is a rendering style commonly used by display terminals, in -which each character image appears in the foreground pixel inside a -rectangular character cell drawn in the graphics context background -pixel. The @var{draw-image-glyph} and @var{draw-image-glyphs} -functions create block text. Block text functions use the following -graphics context attributes: background, clip-mask, clip-x-origin, -clip-y-origin, font, foreground, plane-mask, stipple, subwindow-mode, -tile, ts-x-origin, ts-y-origin. - - -@defun draw-glyph drawable gcontext x y element &key :translate :width (:size :default) - -@table @var -@item drawable -The destination @var{drawable}. - -@item gcontext -The graphics context for drawing text. - -@item x -@itemx y -The left baseline position for the character drawn. - -@item element -A character or other object to be translated into a font index. - -@item :translate -A function to translate text to font indexes. Default is @var{#'translate-default}. - -@item :width -The total pixel width of the character actually drawn, if known. - -@item :size -Specifies the element size of the destination buffer given to @var{:translate} (8, 16, or -@var{:default}). -@end table - -Draws a single character of filled text represented by the given -@emph{element}. The given @emph{x} and @emph{y} specify the left -baseline position for the character. The first return value is true if -the character is successfully translated and drawn, or @var{nil} if -the @var{:translate} function did not translate it. The second return -value gives the total pixel width of the character actually drawn, if -known. - -Specifying a @var{:width} is a hint to improve performance. The -@var{:width} is assumed to be the total pixel width of the character -actually drawn. Specifying @var{:width} permits appending the output -of subsequent calls to the same protocol request, provided -@emph{gcontext} has not been modified in the interim. If @var{:width} -is not specified, appending of subsequent output might not occur -(unless @var{:translate} returns the character width). - -The @var{:size} specifies the element size of the destination buffer -given to @var{:translate} (either 8, 16, or @var{:default}). If -@var{:default} is specified, the size is based on the current font, -if known; otherwise, 16 is used. - -@table @var -@item output-p -Type @var{boolean}. -@item width -Type @var{int32} or @var{null}. -@end table - -@end defun - -@defun draw-glyphs drawable gcontext x y sequence &key (:start 0) :end :translate :width (:size :default) - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing text. -@item x -@itemx y -The left baseline position for the character drawn. -@item sequence -A sequence of characters or other objects to be translated into font indexes. -@item :start -@itemx :end -Start and end indexes defining the elements to draw. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@item :width -The total total pixel width of the character actually drawn, if known. -@item :size -The element size of the destination buffer given to @var{:translate} (8, 16, or -@var{:default}). -@end table - - -Draws the filled text characters represented by the given -sequence. @var{:start} and @var{:end} define the elements of the -sequence which are drawn. The given @emph{x} and @emph{y} specify the -left baseline position for the first character. The first return value -is @var{nil} if all characters are successfully translated and drawn; -otherwise, the index of the first untranslated sequence element is -returned. The second return value gives the total pixel width of the -characters actually drawn, if known. - -Specifying a @var{:width} is a hint to improve performance. The -@var{:width} is assumed to be the total pixel width of the character -sequence actually drawn. Specifying @var{:width} permits appending -the output of subsequent calls to the same protocol request, provided -@emph{gcontext} has not been modified in the interim. If @var{:width} -is not specified, appending of subsequent output might not occur -(unless @var{:translate} returns the character width). - -The @var{:size} specifies the element size of the destination buffer -given to@var{ :translate} (either 8, 16, or @var{:default}). If -@var{:default} is specified, the size is based on the current font, -if known; otherwise, 16 is used. -@table @var -@item new-start -Type @var{array-index} or @var{null}. -@item width -Type @var{int32} or @var{null}. -@end table - -@end defun - - -@defun draw-image-glyph drawable gcontext x y element &key :translate :width (:size :default) - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing text. -@item x -@itemx y -The left baseline position for the character drawn. -@item element -A character or other object to be translated into a font index. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@item :width -The total pixel width of the character actually drawn, if known. -@item :size -Specifies the element size of the destination buffer given to @var{:translate} (8, 16, or -@var{:default}). -@end table - - -Draws a single character of block text represented by the given -@emph{element}. The given @emph{x} and @emph{y} specify the left -baseline position for the character. The first return value is true if -the character is successfully translated and drawn, or @var{nil} if -the @var{:translate} function did not translate it. The -@var{:translate} function is allowed to return an initial font -change. The second return value gives the total pixel width of the -character actually drawn, if known. - -The @var{:translate} function may not return a horizontal position -change, since @var{draw-image-glyph} does not generate complex output -requests. - -Specifying a @var{:width} is a hint to improve performance. The -@var{:width} is assumed to be the total pixel width of the character -actually drawn. Specifying @var{:width} permits appending the output -of subsequent calls to the same protocol request, provided -@emph{gcontext} has not been modified in the interim. If @var{:width} -is not specified, appending of subsequent output might not occur -(unless @var{:translate} returns the character width). - -The @var{:size} specifies the element size of the destination buffer -given to @var{:translate} (either 8, 16, or @var{:default}). If -@var{:default} is specified, the size is based on the current font, -if known; otherwise, 16 is used. -@table @var -@item output-p -Type @var{boolean}. -@item width -Type @var{int32} or @var{null}. -@end table - -@end defun - - - -@defun draw-image-glyphs drawable gcontext x y sequence &key (:start 0) :end :translate :width (:size :default) -@anchor{draw-image-glyphs} - -@table @var -@item drawable -The destination @var{drawable}. -@item x -@itemx y -The left baseline position for the character drawn. -@item gcontext -The graphics context for drawing text. -@item sequence -A sequence of characters or other objects to be translated into font indexes. -@item :start -@itemx :end -Start and end indexes defining the elements to draw. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@item :width -The total total pixel width of the character actually drawn, if known. -@item :size -The element size of the destination buffer given to @var{:translate} (8, 16, or -@var{:default}). -@end table - - -Draws the block text characters represented by the given -@var{sequence}. @var{:start} and @var{:end} define the elements of -the @emph{sequence} which are drawn. The given @emph{x} and @emph{y} -specify the left baseline position for the first character. The first -return value is @var{nil} if all characters are successfully -translated and drawn; otherwise, the index of the first untranslated -sequence element is returned. The @var{:translate} function is -allowed to return an initial font change. The second return value -gives the total pixel width of the characters actually drawn, if -known. - -The @var{:translate} function may not return a horizontal position -change, since @var{draw-image-glyphs} does not generate complex -output requests. - -Specifying a @var{:width} is a hint to improve performance. The -@var{:width} is assumed to be the total pixel width of the character -sequence actually drawn. Specifying @var{:width} permits appending -the output of subsequent calls to the same protocol request, provided -@emph{gcontext} has not been modified in the interim. If @var{:width} -is not specified, appending of subsequent output might not occur -(unless @var{:translate} returns the character width). - -The @var{:size} specifies the element size of the destination buffer -given to @var{:translate} (either 8, 16, or @var{:default}). If -@var{:default} is specified, the size will be based on the current -font, if known; otherwise, 16 is used. - -@table @var -@item new-start -Type @var{array-index} or @var{null}. -@item width -Type @var{int32} or @var{null}. -@end table - -@end defun - - -@defun translate-function source source-start source-end font destination destination-start - -@table @var -@item source -A sequence of characters or other objects to be translated. -@item source-start -An array-index specifying the first @emph{source} element to be translated. -@item source-end -An array-index specifying the end of the @emph{source} subsequence to be -translated. -@item font -The font indexed by translated @emph{source} elements. -@item destination -A vector where translated @emph{source} elements are stored. -@item destination-start -An array-index specifying the position to begin storing -translated @emph{source} elements. -@end table - - -A function used as the @var{:translate} argument for text -functions. Converts elements of the @emph{source} (sub)sequence -into font indexes for the given @emph{font} and stores them into -the @emph{destination} vector. - -The @emph{destination} vector is created automatically by -CLX. @emph{destination} is guaranteed to have room for (- -@emph{source-end source-star}t) integer elements, starting at -@emph{destination-start}. Elements of @emph{destination} can be -either @var{card8} or @var{card16} integers, depending on the -context. @emph{font} is the current font, if known, or @var{nil} -otherwise. Starting with the element at @emph{source-start}, -@var{translate-function} should translate as many elements of -@emph{source} as possible (up to the @emph{source-end} element) -into indexes in the current @emph{font}, and store them into -@emph{destination}. The first return value should be the source -index of the first untranslated element. - -The second return value indicates the changes which should be made -to the current text output request before translating the -remaining @emph{source} elements. If no further elements need to -be translated, the second return value should be @var{nil}. If a -horizontal motion is required before further translation, the -second return value should be the change in x position. If a font -change is required for further translation, the second return -value should be the new font. - -If known, the pixel width of the translated text can be returned as the third value; this can -allow for appending of subsequent output to the same protocol request, if no overall -width has been specified at the higher level. -@table @var -@item first-not-done -Type @var{array-index}. -@item to-continue -Type @var{int16}, @var{font}, or @var{null}. -@item current-width -Type @var{int32} or @var{null}. -@end table - -@end defun - - - -@node Images, Font and Characters, Graphic Operations, Top -@chapter Images - -The X protocol provides for the transfer of images (two-dimensional -arrays of pixel data) between a client program and a -@var{drawable}. The format for image data can vary considerably. In -order to present a uniform data representation for the manipulation of a -variety of images, CLX defines a special @var{image} data -type. Additional @var{image} subtypes -- @var{image-xy} and -@var{image-z} -- allow for the representation of an image either as a -sequence of bit planes or as an array of pixels. CLX includes functions -for accessing @var{image} objects; for transferring image data between -@var{image} objects, @var{drawables}, and files; and also for direct -transfer of raw image data. - -@menu -* Image Types:: -* Image Functions:: -* Image Files:: -* Direct Image Transfer:: -@end menu - -@node Image Types, Image Functions, Images, Images -@section Image Types - - -The @var{image} data type is the base type for all @var{image} -objects. @var{image-xy} and @var{image-z} are subtypes of the -@var{image} type which furnish accessors specialized for different -image representations. - -@menu -* Basic Images:: -* XY-Format Images:: -* Z-Format Images:: -@end menu - -@node Basic Images, XY-Format Images, Image Types, Image Types -@subsection Basic Images - -The following paragraphs describe the CLX functions that can be used to -access all types of @var{image} objects. - -@defun image-blue-mask image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns (and with @code{setf}) changes the @emph{mask} that -selects the pixel subfield for blue intensity values. The -@emph{mask} is non-@var{nil} only for images for -@var{:direct-color} or @var{:true-color} visual types. - -@table @var -@item mask -Type @var{pixel} or @var{null}. -@end table - -@end defun - - -@defun image-depth image - -@table @var -@item image -An @var{image} object. -@end table - -Returns the @emph{depth} (that is, the number of bits per pixel) -for the @emph{image}. -@table @var -@item depth -Type @var{card8}. -@end table - -@end defun - - -@defun image-green-mask image - -@table @var -@item image -An @var{image} object. -@end table - -Returns (and with @code{setf}) changes the mask that selects the -pixel subfield for green intensity values. The mask is -non-@var{nil} only for images for @var{:direct-color} or -@var{:true-color} visual types. -@table @var -@item mask -Type @var{pixel} or @var{null}. -@end table - -@end defun - - -@defun image-height image - -@table @var -@item image -An @var{image} object. -@end table - -Returns the @emph{height} of the @emph{image} in pixels. -@table @var -@item height -Type @var{card16}. -@end table - -@end defun - -@defun image-name image - -@table @var -@item image -An @var{image} object. -@end table - -Returns and (with @code{setf}) changes the @emph{name} string -optionally associated with the @emph{image}. -@table @var -@item name -Type @var{stringable} or @var{null}. -@end table - -@end defun - - -@defun image-plist image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns and (with @code{setf}) changes the @emph{image} property -list. The property list is a hook for added application -extensions. -@table @var -@item plist -Type @var{list}. -@end table - -@end defun - - -@defun image-red-mask image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns (and with @code{setf}) changes the @emph{mask} which -selects the pixel subfield for red intensity values. The -@emph{mask} is non-@var{nil} only for images for -@var{:direct-color} or @var{:true-color} visual types. -@table @var -@item mask -Type @var{pixel} or @var{null}. -@end table - -@end defun - - -@defun image-width image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns the @emph{width} of the @emph{image} in pixels. -@table @var -@item width -Type @var{card16}. -@end table - -@end defun - - -@defun image-x-hot image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns and (with @code{setf}) changes the x position of the hot -spot for an image used as a cursor glyph. The hot spot position is -specified relative to the upper-left origin of the @emph{image}. -@table @var -@item x-position -Type @var{card16} or @var{null}. -@end table - -@end defun - - -@defun image-y-hot image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns and (with @code{setf}) changes the y position of the hot -spot for an image used as a cursor glyph. The hot spot position is -specified relative to the upper-left origin of the @emph{image}. -@table @var -@item y-position -Type @var{card16} or @var{null}. -@end table - -@end defun - - -@node XY-Format Images, Z-Format Images, Basic Images, Image Types -@subsection XY-Format Images - - -The @var{image-xy} subtype represents an image as a sequence of -bitmaps, one for each plane of the image, in most-significant to -least-significant bit order. The following paragraphs describe the -additional CLX functions that can be used to access @var{image-xy} -objects. - -@defun image-xy-bitmap-list image - -@table @var -@item image -An @var{image-xy} object. -@end table - - -Returns and (with @code{setf}) changes the list of bitmap planes -for the @emph{image}. -@table @var -@item bitmaps -Type @var{list} of @var{bitmap}. -@end table - -@end defun - - -@node Z-Format Images, , XY-Format Images, Image Types -@subsection Z-Format Images - - -The @var{image-z} subtype represents an image as a two-dimensional -array of pixels, in scanline order. The following paragraphs describe -the additional CLX functions that can be used to access @var{image-z} -objects. - -@defun image-z-bits-per-pixel image - -@table @var -@item image -An @var{image-z} object. -@end table - - -Returns and (with @code{setf}) changes the number of bits per data -unit used to contain a pixel value for the @emph{image}. Depending -on the storage format for image data, this value can be larger -than the actual @emph{image} depth. -@table @var -@item pixel-data-size -One of 1, 4, 8, 16, 24, or 32. -@end table - -@end defun - - -@defun image-z-pixarray image - -@table @var -@item image -An @var{image-z} object. -@end table - -Returns and (with @code{setf}) changes the two-dimensional array -of pixel data for the @emph{image}. -@table @var -@item pixarray -Type @var{pixarray}. -@end table - -@end defun - - - -@node Image Functions, Image Files, Image Types, Images -@section Image Functions - -The following paragraphs describe the CLX functions used to: - -@itemize @bullet -@item Create an @var{image} object. - -@item Copy an image or a subimage. - -@item Read an image from a @var{drawable}. - -@item Display an image to a @var{drawable}. -@end itemize - - -@defun create-image &key :bit-lsb-first-p :bits-per-pixel :blue-mask :byte-lsb-first-p :bytes-per-line :data :depth :format :green-mask :height :name :plist :red-mask :width :x-hot :y-hot Function - -@table @var -@item :bit-lsb-first-p -For a returned image, true if the order of bits in each @var{:data} -byte is least-significant bit first. -@item :bits-per-pixel -One of 1, 4, 8, 16, 24, or 32. -@item :blue-mask -For @var{:true-color} or @var{:direct-color} images, a pixel mask. -@item :byte-lsb-first-p -For a returned @emph{image}, true if the @var{:data} byte order is -least-significant byte first. -@item :bytes-per-line -For a returned @emph{image}, the number of @var{:data} bytes per scanline. -@item :data -Either a @var{list} of @var{bitmaps}, a @var{pixarray}, or an array of @var{card8} bytes. -@item :depth -The number of bits per displayed pixel. -@item :format -One of @var{:bitmap}, @var{:xy-format}, or @var{:z-format}. -@item :green-mask -For @var{:true-color} or @var{:direct-color} images, a pixel mask. -@item :height -A @var{card16} for the image height in pixels. -@item :name -An optional @var{stringable} for the image name. -@item :plist -An optional image property list. -@item :red-mask -For @var{:true-color} or @var{:direct-color} images, a pixel mask. -@item :width -A @var{card16} for the image width in pixels. -@item :x-hot -For a @var{cursor} image, the x position of the hot spot. -@item :y-hot -For a cursor image, the y position of the hot spot. -@end table - -Creates an @var{image} object from the given @var{:data} and -returns either an @var{image}, @var{image-xy}, or an -@var{image-z}, depending on the type of image @var{:data}. If the -@var{:data} is a list, it is assumed to be a @var{list} of -@var{bitmaps} and an @var{image-xy} is created. If the -@var{:data} is a @var{pixarray}, an @var{image-z} is -created. Otherwise, the @var{:data} must be an array of bytes -(@var{card8}), in which case a basic @var{image} object is -created. - -If the @var{:data} is a list, each element must be a bitmap of -equal size. @var{:width} and @var{:height} default to the bitmap -width -- (@var{array-dimension bitmap} 1) -- and the bitmap height --- (@var{array-dimension bitmap} 0) -- respectively. @var{:depth} -defaults to the number of bitmaps. - -If the @var{:data} is a @var{pixarray}, @var{:width} and -@var{:height} default to the @var{pixarray} width -- -(@var{array-dimension pixarray} 1), and the pixarray height -- -(@var{array-dimension pixarray} 0), respectively. @var{:depth} -defaults to (@var{pixarray-depth} @var{:data}). The -@var{:bits-per-pixel} is rounded to a valid size, if necessary. By -default, the @var{:bits-per-pixel} is equal to the @var{:depth}. - -If the @var{:data} is an array of @var{card8}, the @var{:width} -and @var{:height} are required to interpret the image data -correctly. The @var{:bits-per-pixel} defaults to the @var{:depth}, -and the @var{:depth} defaults to 1. @var{:bytes-per-line} defaults -to: - -@lisp -(@var{floor} (@var{length :data}) (* @var{:bits-per-pixel :height})) -@end lisp - -The @var{:format} defines the storage format of image data bytes -and can be one of the following values: - -@table @var -@item :xy-pixmap -The @var{:data} is organized as a set of bitmaps representing image -bit planes, appearing in most-significant to least-significant bit -order. - -@item :z-pixmap -The @var{:data} is organized as a set of pixel values in scanline -order. - -@item :bitmap -Similar to @var{:xy-pixmap}, except that the @var{:depth} must be 1, -and 1 and 0 bits represent the foreground and background pixels, -respectively. -@end table - -By default, the @var{:format} is @var{:bitmap} if @var{:depth} is -1; otherwise, @var{:z-pixmap}. - -@table @var -Type @var{image}. -@end table - -@end defun - - -@defun copy-image image &key (:x 0) (:y 0) :width :height :result-type - -@table @var -@item image -An @var{image} object. -@item :x -@itemx :y -@var{card16} values defining the position of the upper-left corner of the subimage -copied. -@item :width -@itemx :height -@var{card16} values defining the size of subimage copied. -@item :result-type -One of @var{'image-x}, @var{'image-xy}, or @var{'image-z}. -@end table - - -Returns a new image, of the given @var{:result-type}, containing a -copy of the portion of the @emph{image} defined by @var{:x}, -@var{:y}, @var{:width}, and @var{:height}. By default, -@var{:width} is: - -@lisp -(- (@var{image-width} @emph{image}) @var{:x}) -@end lisp - -and @var{:height} is: - -@lisp -(- (@var{image-height} @emph{image}) @var{:y}) -@end lisp - -If necessary, the new image is converted to the @var{:result-type}, -that can be one of the following values: - -@table @code -@item 'image-x -A basic @var{image} object is returned. -@item 'image-xy -An @var{image-xy} is returned. -@item 'image-z -An @var{image-z} is returned. -@end table - -@table @var -@item new-image -Type @var{image}. -@end table - -@end defun - - -@defun get-image drawable &key :x :y :width :height :plane-mask (:format :z-format) :result-type Function - -@table @var -@item drawable -A @var{drawable}. -@item :x -@itemx :y -@var{card16} values defining the upper-left @var{drawable} pixel returned. These -arguments are required. -@item :width -@itemx :height -@var{card16} values defining the size of the @emph{image} returned. These -arguments are required. -@item :plane-mask -A pixel mask. -@item :format -Either @var{:xy-pixmap} or @var{:z-pixmap}. -@item :result-type -One of @var{'image-x}, @var{'image-xy}, or @var{'image-z}. -@end table - - -Returns an @emph{image} containing pixel values from the region of -the @emph{drawable} given by @var{:x}, @var{:y}, @var{:width}, -and @var{:height}. The bits for all planes selected by 1 bits in -the @var{:plane-mask} are returned as zero; the default -@var{:plane-mask} is all 1 bits. The @var{:format} of the returned -pixel values may be either @var{:xy-format} or @var{:z-format}. - -The @var{:result-type} defines the type of image object returned: - -@table @code -@item 'image-x -A basic @var{image} object is returned. -@item 'image-xy -An @var{image-xy} is returned. -@item 'image-z -An @var{image-z} is returned. -@end table - - -By default, @var{:result-type} is @var{'image-z} if @var{:format} -is @var{:z-format} and @var{'image-xy} if @var{:format} is -@var{:xy-format}. -@table @var -Type @var{image}. -@end table - -@end defun - -@defun put-image drawable gcontext image &key (:src-x 0) (:src-y 0) :x :y :width :height :bitmap-p - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context used to display the @emph{image}. -@item image -An @var{image} object. -@item :src-x -@itemx :src-y -@var{card16} values defining the upper-left position of the @emph{image} region to -display. -@item :x -@itemx :y -The position in the @emph{drawable} where the @emph{image} region is displayed. These -arguments are required. -@item :width :height -@var{card16} values defining the size of the @emph{image} region displayed. -@item :bitmap-p -If @emph{image} is depth 1, then if true, foreground and background pixels are -used to display 1 and 0 bits of the @emph{image}. -@end table - -Displays a region of the @emph{image} defined by @var{:src-x}, -@var{:src-y}, @var{:width}, and @var{:height} on the destination -d@emph{rawable}, with the upper-left pixel of the @emph{image} -region displayed at the @emph{drawable} position given by @var{:x} -and @var{:y}. By default, @var{:width} is: - -@lisp -(- (@var{image-width} @emph{image}) @var{:src-x}) -@end lisp - -and @var{:height} is: - -@lisp -(- (@var{image-height} @emph{image}) @var{:src-y}) -@end lisp - -The following attributes of the @emph{gcontext} are used to display -the @var{image}: clip-mask, clip-x, clip-y, function, plane-mask, -and subwindow-mode. - -The @var{:bitmap-p} argument applies only to images of depth 1. In -this case, if @var{:bitmap-p} is true or if the @emph{image} is a -basic @var{image} object created with @var{:format :bitmap}, the -@emph{image} is combined with the foreground and background pixels -of the @var{gcontext}. 1 bits of the @emph{image} are displayed in -the foreground pixel and 0 bits are displayed in the background -pixel. - - -@end defun - - -@node Image Files, Direct Image Transfer, Image Functions, Images -@section Image Files - - -CLX provides functions that allow images to be written to a file in a standard X -format. The following paragraphs describe the CLX functions used to: - -@itemize @bullet -@item Read an image from a file. - -@item Write an image to a file. -@end itemize - - -@defun read-bitmap-file pathname - -@table @var -@item pathname -An image file pathname. -@end table - - -Reads an image file in standard X format and returns an -@var{image} object. The returned @emph{image} can have -depth greater than one. -@table @var -@item image -Type @var{image}. -@end table - -@end defun - - -@defun write-bitmap-file pathname image &optional name - -@table @var -@item pathname -An image file pathname. -@item image -An @var{image} object. -@item name -A @var{stringable} image name. -@end table - -Writes the @emph{image} to an image file in standard X -format. The @emph{image} can have depth greater than -one. The @emph{name} is an image identifier written to the -file; the default @emph{name} is (@var{or} -(@var{image-name} @emph{image}) @var{'image}). - - -@end defun - - -@node Direct Image Transfer, , Image Files, Images -@section Direct Image Transfer - - -For cases where the @var{image} representation is not needed, -CLX provides functions to read and display image data -directly. -@defun get-raw-image drawable &key :data (:start 0) :x :y :width :height :plane-mask (:format :z-format) (:result-type '(vector card8)) - -@table @var -@item drawable -A @var{drawable}. -@item :data -An optional @var{sequence} of @var{card8}. -@item :start -The index of the first @var{:data} element modified. -@item :x -@itemx :y -@var{card16} values defining the size of the @var{image} returned. These arguments are -required. -@item :width -@itemx :height -@var{card16} values defining the size of the image returned.These -arguments are required. -@item :plane-mask -A pixel mask. -@item :format -Either @var{:xy-pixmap} or @var{:z-pixmap}. This argument is required. -@item :result-type -The type of image data sequence to return. -@end table - - -Returns a sequence of image data from the region of the -@emph{drawable} given by @var{:x}, @var{:y}, -@var{:width}, and @var{:height}. If @var{:data} is -given, it is modified beginning with the element at the -@var{:start} index and returned. The @emph{depth} and -@emph{visua}l type ID of the @emph{drawable} are also -returned. - -The bits for all planes selected by 1 bits in the -@var{:plane-mask} are returned as zero; the default -@var{:plane-mask} is all 1 bits. The @var{:format} of -the returned pixel values may be either -@var{:xy-format} or @var{:z-format}. The -@var{:result-type} defines the type of image data -returned. - -The calling program is responsible for handling the -byte-order and bit-order returned by the server for the -@emph{drawable}'s display (see @var{display-byte-order} -and @var{display-image-lsb-first-p}). -@table @var -@item data -Type @var{sequence} or @var{card8}. -@item depth -Type @var{card8}. -@item visual -Type @var{card29}. -@end table - -@end defun - - -@defun put-raw-image drawable gcontext data &key (:start 0) :depth :x :y :width :height (:left-pad 0) :format - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context used to display the image. -@item data -A sequence of integers. -@item :start -The index of the first element of @emph{data} displayed. -@item :depth -The number of bits per pixel displayed. This argument is required. -@item :x -@itemx :y -The position in the @emph{drawable} where the image region is displayed. These -arguments are required. -@item :width -@itemx :height -@var{card16} values defining the size of the image region displayed. These -arguments are required. -@item :left-pad -A @var{card8} specifying the number of leading bits to discard for each image -scanline. -@item :format -One of @var{:bitmap}, @var{:xy-pixmap}, or @var{:z-pixmap}. -@end table - -Displays a region of the image data defined by @var{:start}, -@var{:left-pad}, @var{:width}, and @var{:height} on the -destination @emph{drawable}, with the upper-left pixel of the image -region displayed at the @emph{drawable} position given by @var{:x} -and @var{:y}. - -The @var{:format} can be either @var{:xy-pixmap}, -@var{:z-pixmap}, or @var{:bitmap}. If @var{:xy-pixmap} or -@var{:z-pixmap} formats are used, @var{:depth} must match the -depth of the destination @emph{drawable}. For @var{:xy-pixmap}, the -data must be in XY format. For @var{:z-pixmap}, the data must be in -Z format for the given @var{:depth}. - -If the @var{:format} is @var{:bitmap}, the @var{:depth} must be -1. In this case, the image is combined with the foreground and -background pixels of the @emph{gcontext}. 1 bits of the image are -displayed in the foreground pixel and 0 bits are displayed in the -background pixel. - -The @var{:left-pad} must be zero for @var{:z-pixmap} format. For -@var{:bitmap} and @var{:xy-pixmap} formats, the @var{:left-pad} -must be less than the bitmap-scanline-pad for the @emph{drawable}'s -display (@pxref{display-bitmap-format}). The first -@var{:left-pad} bits in every scanline are to be ignored by the -server; the actual image begins that many bits into the data. - -The following attributes of the @emph{gcontext} are used to display -the @var{image}: clip-mask, clip-x, clip-y, function, plane-mask, -and subwindow-mode. - -The calling program is responsible for handling the byte-order and -bit-order required by the server for the @emph{drawable}'s display -(see @var{display-byte-order} and -@var{display-image-lsb-first-p}). - - -@end defun - - -@node Font and Characters, Colors, Images, Top -@chapter Font and Characters - -An X server maintains a set of fonts used in the text operations -requested by client programs. An X font is an array of character bit -maps (or @emph{glyphs}) indexed by integer codes. In fact, font glyphs -can also represent cursor shapes or other images and are not limited to -character images. X supports both linear and matrix encoding of font -indexes. With linear encoding, a font index is interpreted as a single -16-bit integer index into a one-dimensional array of glyphs. With matrix -encoding, a font index is interpreted as a pair of 8-bit integer indexes -into a two-dimensional array of glyphs. The type of index encoding used -is font-dependent. - -In order to access or use a font, a client program must first open it -using the @var{open-font} function, sending a font name string as an -identifier. @var{open-font} creates a CLX @var{font} object used to -refer to the font in subsequent functions. Afterward, calling -@var{open-font} with the same font name returns the same @var{font} -object. When a font is no longer in use, a client program can call -@var{close-font} to destroy the @var{font} object. - -A font has several attributes which describe its geometry and its -glyphs. CLX provides functions to return the attributes of a font, as -well functions for accessing the attributes of individual font -glyphs. Glyph attributes are referred to as @emph{character attributes}, -since characters are the most common type of font glyphs. A font also -has a property list of values recorded by the X server. However, the set -of possible font properties and their values are not standardized and -are implementation-dependent. Typically, CLX maintains a cache of font -and character attributes, in order to minimize server requests. -However, the font cache mechanism is implementation-dependent and cannot -be controlled by the client. In some cases, CLX may create a -@emph{pseudo-font} object solely for the purpose of accessing font -attributes. A pseudo-font is represented by a special type of -@var{font} object that cannot be used in a @var{gcontext}. If -necessary, CLX can automatically convert a pseudo-font into a true font, -if the name of the pseudo-font is known. - -The set of available fonts is server-dependent; that is, font names are -not guaranteed to be portable from one server to the next. However, the -public X implementation from MIT includes a set of fonts that are -typically available with most X servers. - -The following paragraphs describe CLX functions to: - -@itemize @bullet -@item Open and close fonts. -@item List available fonts. -@item Access font attributes. -@item Access character attributes. -@item Return the size of a text string. -@end itemize - -@menu -* Opening Fonts:: -* Listing Fonts:: -* Font Attributes:: -* Chracter Attributes:: -* Querying Text Size:: -@end menu - -@node Opening Fonts, Listing Fonts, Font and Characters, Font and Characters -@section Opening Fonts - - -The following paragraphs discuss the CLX functions for opening and -closing fonts. - -@defun open-font display name - -@table @var -@item display -A @var{display} object. -@item name -A font name string. -@end table - -Opens the font with the given @emph{name} and returns a -@var{font} object. The name string should contain only ISO -Latin-1 characters; case is not significant. - -@table @var -@item font -Type @var{font}. -@end table - -@end defun - - -@defun close-font font - -@table @var -@item font -A @var{font} object. -@end table - -Deletes the association between the resource ID and the -@emph{font}. The @emph{font} is freed when no other server -resource references it. The @emph{font} can be unloaded by the X -server if this is the last reference to the @emph{font} by any -client. In any case, the @emph{font} should never again be -referenced because its resource ID is destroyed. This might not -generate a protocol request if the @emph{font} is -reference-counted locally or if it is a pseudo-font. - -@end defun - - -@defun discard-font-info fonts - -@table @var -@item font -A @var{font} object. -@end table - -Discards any state that can be re-obtained with -@var{open-font}. This is simply a performance hint for -memory-limited systems. - -@end defun - -@node Listing Fonts, Font Attributes, Opening Fonts, Font and Characters -@section Listing Fonts - - -The following paragraphs describe CLX functions that return fonts or -font names that match a given pattern string. Such pattern strings -should contain only ISO Latin-1 characters; case is not significant. The -following pattern characters can be used for @emph{wildcard} matching: - -@table @code -@item #\* -Matches any sequence of zero or more characters. -@item #\? -Matches any single character. -@end table - -For example, the pattern "T?mes Roman" matches the name "Times Roman" -but not the name "Thames Roman". However, the pattern "T*mes Roman" -matches both names. - -@defun font-path display &key (:result-type 'list) - -@table @var -@item display -A @var{display} object. -@item :result-type -Specifies the type of resulting sequence. -@end table - -Returns a @var{list} (by default) of names containing the current -search path for fonts. With @code{setf}, this function sets the -search path for font lookup. There is only one search path per -server, not one per client. The interpretation of the names is -server-dependent, but they are intended to specify directories to be -searched in the order listed. - -Setting the path to the empty list restores the default path -defined for the server. Note that as a side-effect of -executing this request, the server is guaranteed to flush -all cached information about fonts for which there are -currently no explicit resource IDs allocated. -@table @var -@item paths -Type @var{sequence} of either @var{string} or @var{pathname}. -@end table - -@end defun - - -@defun list-font-names display pattern &key (:max-fonts 65535) (:result-type 'list) - -@table @var -@item display -A @var{display} object. -@item pattern -A string used to match font names. Only font names that match the pattern are -returned. -@item :max-fonts -The maximum number of font names returned. Default is 65535. -@item :result-type -The type of sequence to return. Default is '@var{list}. -@end table - -Returns a sequence of strings containing the font names that match -the @emph{pattern}. The fonts available are determined by the font -search path; see @var{font-path}). The maximum number of font names -returned is determined by @var{:max-fonts}. - -@table @var -@item font-name -Type @var{sequence} of @var{string}. -@end table - -@end defun - - -@defun list-fonts display pattern &key (:max-fonts 65535) (:result-type 'list) - -@table @var -@item display -A @var{display} object. -@item pattern -A string used to match font names. Only fonts whose name matches the -pattern are returned. -@item :max-fonts -The maximum number of fonts returned. Default is 65535. -@item :result-type -The type of sequence to return. Default is @var{'list}. -@end table - -Returns a sequence of pseudo-fonts corresponding to the available -fonts whose names match the @emph{pattern}. The fonts available are -determined by the font search path; see @var{font-path}). The -maximum number of @var{font} objects returned is determined by -@var{:max-fonts}. - -@table @var -@item font -Type @var{sequence} of @var{font}. -@end table - -@end defun - - -@node Font Attributes, Chracter Attributes, Listing Fonts, Font and Characters -@section Font Attributes - - -The following paragraphs describe the CLX functions used to access font -attributes. - -@defun font-all-chars-exist-p font - -@table @var -@item exists-p -Type @var{boolean}. -@end table - - -Returns true if glyphs exist for all indexes in the range returned -by @var{font-min-char} and @var{font-max-char}. Returns -@var{nil} if an index in the range corresponds to empty glyph. - -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-ascent font - -@table @var -@item ascent -Type @var{int16}. -@end table - - -Returns the vertical @emph{ascent} of the @emph{font} used for -interline spacing. The @emph{ascent} defines the nominal distance -in pixels from the baseline to the bottom of the previous line of -text. Some font glyphs may actually extend beyond the font -@emph{ascent}. -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-default-char font - -@table @var -@item index -Type @var{card16}. -@end table - - -Returns the @emph{index} of the glyph drawn when an invalid or -empty glyph index is specified. If the default index specifies an -invalid or empty glyph, an invalid or empty index has no effect. -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-descent font - -@table @var -@item descent -Type @var{int16}. -@end table - - -Returns the vertical @emph{descent} of the @emph{font} used for -interline spacing. The @emph{descent} defines the nominal distance -in pixels from the baseline to the top of the next line of -text. Some font glyphs may actually extend beyond the font -@emph{descent}. -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-direction font - -@table @var -@item direction -Type @var{draw-direction}. -@end table - - -Returns the nominal drawing @emph{direction} for the -@emph{font}. The font drawing direction is only a hint that -indicates whether the @emph{char-width} of most font glyphs is -positive (@var{:left-to-right} direction) or negative -(@var{:right-to-left} direction). Note that X does not provide -any direct support for vertical text. -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-display font - -@table @var -@item font -A @var{font} object. -@end table - -Returns the @var{display} object associated with the specified -@emph{font}. - -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun font-equal font-1 font-2 - -@table @var -@item font-1 -@itemx font-2 -The @var{font} objects. -@end table - -Returns true if the two arguments refer to the same server -resource and @var{nil} if they do not. - - -@end defun - - -@defun font-id font - -@table @var -@item font -A @var{font} object. -@end table - -Returns the unique resource ID assigned to the specified @emph{font}. - -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun font-max-byte1 font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns zero if the @emph{font} uses linear index -encoding. Otherwise, if the @emph{font} uses matrix index -encoding, a value between 1 and 255 is returned that specifies the -maximum value for the most significant byte of font indexes. -@table @var -@item max-byte1 -Type @var{card8}@emph{.} -@end table - -@end defun - - -@defun font-max-byte2 font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns zero if the @emph{font} uses linear index -encoding. Otherwise, if the @emph{font} uses matrix index -encoding, a value between 1 and 255 is returned that specifies the -maximum value for the least significant byte of font indexes. -@table @var -@item max-byte2 -Type @var{card8}@emph{.} -@end table - -@end defun - - -@defun font-max-char font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum valid value used for linear encoded -indexes. This function is not meaningful for fonts that use matrix -index encoding. -@table @var -@item index -Type @var{card16}. -@end table - -@end defun - - -@defun font-min-byte1 font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns zero if the @emph{font} uses linear index -encoding. Otherwise, if the @emph{font} uses matrix index -encoding, a value between 1 and 255 is returned that specifies the -minimum value for the most significant byte of font indexes. -@table @var -@item min-byte1 -Type @var{card8}. -@end table - -@end defun - - -@defun font-min-byte2 font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns zero if the @emph{font} uses linear index -encoding. Otherwise, if the @emph{font} uses matrix index -encoding, a value between 1 and 255 is returned that specifies the -minimum value for the least significant byte of font indexes. -@table @var -@item min-byte2 -Type @var{card8}. -@end table - -@end defun - - -@defun font-min-char font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum valid value used for linear encoded -indexes. This function is not meaningful for fonts that use matrix -index encoding. -@table @var -@item index -Type @var{card16}. -@end table - -@end defun - - -@defun font-name font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the name of the @emph{font}, or @var{nil} if @emph{font} -is a pseudo-font. -@table @var -@item name -Type @var{string} or @var{null}. -@end table - -@end defun - - -@defun font-p font - -Returns true if the argument is a @var{font} object and -@var{nil} otherwise. - -@table @var -@item font-p -Type @var{boolean}. -@end table - -@end defun - - -@defun font-plist font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns and (with @code{setf}) sets the property list for the -specified @emph{font}. This function provides a hook where -extensions can add data. -@table @var -@item plist -Type @var{list}. -@end table - -@end defun - - -@defun font-properties font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the list of font @emph{properties} recorded by the X -server. The returned list is a property list of keyword/value -pairs. The set of possible font property keywords is -implementation-dependent. -@table @var -@item properties -Type @var{list}. -@end table - -@end defun - - -@defun font-property font name - -@table @var -@item font -A @var{font} object. -@item name -A font property keyword. -@end table - - -Returns the value of the font @emph{property} specified by the -@emph{name} keyword. The property value, if it exists, is returned -as an uninterpreted 32-bit integer. -@table @var -@item property -Type @var{int32} or @var{null}. -@end table - -@end defun - - -@defun max-char-ascent font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-ascent} value for all characters in -@emph{font}. -@table @var -@item ascent -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-attributes font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-attributes} value for all -characters in @emph{font}. -@table @var -@item attributes -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-descent font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-descent} value for all characters -in @emph{font}. -@table @var -@item descent -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-left-bearing font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-left-bearing} value for all characters in @emph{font}. -@table @var -@item left-bearing -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-right-bearing font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-right-bearing} value for all -characters in @emph{font}. -@table @var -@item right-bearing -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-width font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-width} value for all characters in -@emph{font}. -@table @var -@item width -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-ascent font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-ascent} for all characters in -@emph{font}. -@table @var -@item ascent -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-attributes font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-attributes} for all characters in @emph{font}. -@table @var -@item attributes -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-descent font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-descent} for all characters in @emph{font}. -@table @var -@item descent -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-left-bearing font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-left-bearing} for all characters in -@emph{font}. -@table @var -@item left-bearing -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-right-bearing font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-right-bearing} for all characters -in @emph{font}. -@table @var -@item right-bearing -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-width font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-width} for all characters in -@emph{font}. -@table @var -@item width -Type @var{int16}. -@end table - -@end defun - - -@node Chracter Attributes, Querying Text Size, Font Attributes, Font and Characters -@section Chracter Attributes - - -The following paragraphs describe the CLX functions used to access the -attributes of individual font glyphs. - -@defun char-ascent font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns the vertical distance in pixels from the baseline to the top -of the given font glyph. Returns @var{nil} if the index is invalid -or specifies an empty glyph, or if the @emph{font} is a pseudo-font. -@table @var -@item ascent -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-attributes font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns font-specific @emph{attributes} of the given glyph. The -interpretation of such attributes is server-dependent. Returns -@var{nil} if the @emph{index} is invalid or specifies an empty -glyph, or if the @emph{font} is a pseudo-font. -@table @var -@item attributes -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-descent font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns the vertical distance in pixels from the baseline to the -bottom of the given font glyph. Returns @var{nil} if the -@emph{index} is invalid or specifies an empty glyph, or if the -@emph{font} is a pseudo-font. -@table @var -@item descent -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-left-bearing font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns the left side bearing of the given font glyph. If -@var{draw-glyph} is called with horizontal position @emph{x}, -the leftmost pixel of the glyph is drawn at the position -(+ @emph{x left-bearing}). Returns @var{nil} if the -@emph{index} is invalid or specifies an empty glyph, or if the -@emph{font} is a pseudo-font. -@table @var -@item left-bearing -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-right-bearing font index - -@table @var -@item font -A @emph{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns the right side bearing of the given font glyph. If -n@var{draw-glyph} is called with horizontal position @emph{x}, -the rightmost pixel of the glyph is drawn at the position (+ -@emph{x rightbearing}). Returns @var{nil} if the -@emph{index} is invalid or specifies an empty glyph, or if the -@emph{font} is a pseudo-font. - -@table @var -@item right-bearing -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-width font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - -Returns the @emph{width} of the given font glyph. The @emph{width} -is defined to be equal to (- @emph{rightbearing -left-bearing}). Returns @var{nil} if the @emph{index} is invalid -or specifies an empty glyph, or if the @emph{font} is a pseudo-font. - -@table @var -@item width -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@node Querying Text Size, , Chracter Attributes, Font and Characters -@section Querying Text Size - - -CLX defines functions to return the size of text drawn in a specified -font. @xref{Drawing Text}, for a description of the -@var{:translate} function used by the functions in the following -paragraphs. - -@defun text-extents font sequence &key (:start 0) :end :translate -@anchor{text-extents} - -@table @var -@item font -The font (or @var{gcontext}) used for measuring characters. -@item sequence -A sequence of characters or other objects to be translated into font indexes. -@item :start -@itemx :end -Start and end indexes defining the elements to draw. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@end table - -Returns the complete geometry of the given @emph{sequence} when -drawn in the given @emph{fon}t. The @emph{font} can be a -@var{gcontext}, in which case the font attribute of the given -graphics context is used. @var{:start} and @var{:end} define the -elements of the @emph{sequence} which are used. - -The returned @emph{width} is the total pixel width of the -translated character sequence. The returned @emph{ascent} and -@emph{descent} give the vertical ascent and descent for characters -in the translated @emph{sequence}. The returned @emph{left} gives -the left bearing of the leftmost character. The returned -@emph{right} gives the right bearing of the rightmost -character. The returned @emph{font-ascent} and @emph{font-descent} -give the maximum vertical ascent and descent for all characters in -the @emph{fon}t. If @var{:translate} causes font changes, then -@emph{font-ascent} and @emph{font-descent} will be the maximums -over all fonts used. The @emph{direction} returns the preferred -draw direction for the font. If @var{:translate} causes font -changes, then the @emph{direction} will be @var{nil}. The -@emph{first-not-done} value returned is @var{nil} if all elements -of the @emph{sequence} were successfully translated; otherwise the -index of the first untranslated element is returned. - -@table @var -@item width -Type @var{int32}. -@item ascent -Type @var{int16}. -@item descent -Type @var{int16}. -@item left -Type @var{int32}. -@item right -Type @var{int32}. -@item font-ascent -Type @var{int16}. -@item direction -Type @var{draw-direction}. -@item first-not-done -Type @var{array-index} or @var{null}. -@end table - -@end defun - - -@defun text-width font sequence &key (:start 0) :end :translate - -@table @var -@item font -The font (or @var{gcontext}) used for measuring characters. -@item sequence -A sequence of characters or other objects to be translated into font indexes. -@item :start -@item :end -Start and end indexes defining the elements to draw. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@end table - - -Returns the total pixel width of the given @emph{sequence} when -drawn in the given @emph{font}. The @emph{font} can be a -@var{gcontext}, in which case the font attribute of the given -graphics context is used. @var{:start} and @var{:end} define the -elements of the @emph{sequence} which are used. The second value -returned is @var{nil} if all elements of the @emph{sequence} were -successfully translated; otherwise the index of the first -untranslated element is returned. -@table @var -@item width -Type @var{int32}. -@item first-not-done -Type @var{array-index} or @var{null}. -@end table - -@end defun - - -@node Colors, Cursors, Font and Characters, Top -@chapter Colors - -@menu -* Colormaps and Colors:: -* Color Functions:: -* Colormap Functions:: -@end menu - -@node Colormaps and Colors, Color Functions, Colors, Colors -@section Colormaps and Colors - - -In X, a @emph{color} is defined by a set of three numeric values, -representing intensities of red, green, and blue. Red, green, and blue -are referred to as the @emph{primary} hues. A @emph{colormap} is a list -of colors, each indexed by an integer @emph{pixel} value. Each entry in -a colormap is called a color @emph{cell}. Raster graphics displays store -pixel values in a special screen hardware memory. As the screen hardware -scans this memory, it reads each pixel value, looks up the color in the -corresponding cell of a colormap, and displays the color on its screen. - -The colormap abstraction applies to all classes of visual types -supported by X, including those for screens which are actually -monochrome. For example, @var{:gray-scale} screens use colormaps in -which colors actually specify the monochrome intensity. A typical -black-and-white monochrome display has a @var{:static-gray} screen with -a two-cell colormap. - -The following list describes how pixel values and colormaps are handled -for each visual class. - -@table @var -@item :direct-color -A pixel value is decomposed into separate red, green, and blue -subfields. Each subfield indexes a separate colormap. Entries in all colormaps can -be changed. -@item :gray-scale -A pixel value indexes a single colormap that contains monochrome -intensities. Colormap entries can be changed. -@item :pseudo-color -A pixel value indexes a single colormap that contains color -intensities. Colormap entries can be changed. -@item :static-color -Same as @var{:pseudo-color}, except that the colormap entries are -predefined by the hardware and cannot be changed. -@item :static-gray -Same as @var{:gray-scale}, except that the colormap entries are -predefined by the hardware and cannot be changed. -@item :true-color -Same as @var{:direct-color}, except that the colormap entries are -predefined by the hardware and cannot be changed. Typically, each of -the red, green, and blue colormaps provides a (near) linear ramp of -intensity. -@end table - -CLX provides functions to create colormaps, access and modify colors and -color cells, and install colormaps in screen hardware. - -@node Color Functions, Colormap Functions, Colormaps and Colors, Colors -@section Color Functions - - -A color is represented by a CLX color object, in which each of the red, -green, and blue values is specified by an @var{rgb-val} -- a floating -point number between 0.0 and 1.0. (@pxref{Data Types}). The -value 0.0 represents the minimum intensity, while 1.0 represents the -maximum intensity. CLX automatically converts @var{rgb-val} values into -16-bit integers when sending colors to an X server. The X server, in -turn, scales 16-bit color values to match the actual intensity range -supported by the screen. - -Colors used on @var{:gray-scale} screens must have the same value for -each of red, green, and blue. Only one of these values is used by screen -hardware to determine intensity; however, CLX does not define which of -red, green, or blue is actually used. - -The following paragraphs describe the CLX functions used to create, -access, and modify colors. - -@defun make-color &key (:blue 1.0) (:green 1.0) (:red 1.0) &allow-other-keys - -@table @var -@item :blue -@itemx :green -@itemx :red -@var{rgb-val} values that specify the saturation for each primary. -@end table - - -Creates, initializes, and returns a new @var{color} object with the -specified values for red, green, and blue. -@table @var -@item color -Type @var{color}. -@end table - -@end defun - - -@defun color-blue color - -@table @var -@item color -A @var{color} object. -@end table - - -Returns and (with @code{setf}) sets the value for blue in the -@emph{color}. -@table @var -@item blue-intensity -Type @var{rgb-val}. -@end table - -@end defun - - -@defun color-green color - -@table @var -@item color -A @var{color} object. -@end table - - -Returns and (with @code{setf}) sets the value for green in the -@emph{color}. -@table @var -@item green-intensity -Type @var{rgb-val}. -@end table - -@end defun - - -@defun color-p color - -Returns non-@var{nil} if the argument is a @var{color} object and -@var{nil} otherwise. - -@table @var -@item color-p -Type @var{boolean}. -@end table - -@end defun - -@defun color-red color - -@table @var -@item color -A @var{color} object. -@end table - - -Returns and (with @code{setf}) sets the value for red in the -@emph{color}. -@table @var -@item red-intensity -Type @var{rgb-val}. -@end table - -@end defun - - -@defun color-rgb color - -@table @var -@item color -A @var{color} object. -@end table - - -Returns the values for red, green, and blue in the @emph{color}. -@table @var -@item red -@itemx green -@itemx blue -Type @var{rgb-val}. -@end table - -@end defun - - -@node Colormap Functions, , Color Functions, Colors -@section Colormap Functions - - -A colormap is represented in CLX by a @var{colormap} object. A CLX -program can create and manipulate several @var{colormap} -objects. However, the colors contained in a @var{colormap} are made -visible only when the @var{colormap} is @emph{installed}. Each window -is associated with a @var{colormap} that is used to translate window -pixels into colors (see @var{window-colormap}). However, a window will -appear in its true colors only if its associated @var{colormap} is -installed. - -The total number of colormaps that can be installed depends on the -screen hardware. Most hardware devices allow exactly one -@var{colormap} to be installed at any time. That is, -@var{screen-min-installed-maps} and @var{screen-max-installed-maps} -are both equal to 1. Installing a new @var{colormap} can cause a -previously installed @var{colormap} to be uninstalled. It is important -to remember that the set of installed @var{colormaps} is a hardware -resource shared cooperatively among all client programs connected to an -X server. - -A CLX program can control the contents of @var{colormaps} by allocating -color cells in one of two ways: read-only or read-write. Allocating a -read-only color cell establishes a color value for a specified pixel -value that cannot be changed. However, read-only color cells can be -shared among all client programs. Read-only allocation is the best -strategy for making use of limited @var{colormap} hardware in a -multi-client environment. - -Alternatively, allocating a read-write color cell allows a client the -exclusive right to set the color value stored in the cell. A cell -allocated read-write by one client cannot be allocated by another -client, not even as a read-only cell. Note that read-write allocation is -not allowed for screens whose visual type belongs to one of the -@var{:static-gray}, @var{:static-color}, or @var{:true-color} -classes. For screens of these classes, @var{colormap} cells cannot be -modified. - -Two entries of the default colormap, typically containing the colors -black and white, are automatically allocated read-only. The pixel values -for these entries can be returned by the functions -@var{screen-black-pixel} and @var{screen-white-pixel}. Applications -that need only two colors and also need to operate on both monochrome -and color screens should always use these pixel values. The names -@emph{black} and @emph{white} are intended to reflect relative intensity -levels and need not reflect the actual colors displayed for these pixel -values. - -Each screen has a default @var{colormap}, which is initially -installed. By conventions, clients should allocate only read-only cells -from the default @var{colormap}. - -@menu -* Creating Colormaps:: -* Installing Colormaps:: -* Allocating Colors:: -* Finding Colors:: -* Changing Colors:: -* Colormap Attributes:: -@end menu - -@node Creating Colormaps, Installing Colormaps, Colormap Functions, Colormap Functions -@subsection Creating Colormaps - - -CLX provides functions for creating and freeing new @var{colormap} -objects. - -@defun create-colormap visual window &optional alloc-p - -@table @var -@item visual -A @var{visual} type ID. -@item window -A @var{window}. -@item alloc-p -Specifies whether @var{colormap} cells are permanently allocated read-write. -@end table - - -Creates and returns a @emph{colormap} of the specified -@emph{visual} type for the screen containing the -@emph{window}. The @emph{visual} type must be one of those -supported by the screen. - -Initial color cell values are undefined for visual types belonging -to the @var{:gray-scale}, @var{:pseudo-color}, and -@var{:direct-color} classes. Color cell values for visual types -belonging to the @var{:static-gray}, @var{:static-color}, and -@var{:true-color} classes have initial values defined by the -visual type. However, X does not define the set of possible visual -types or their initial color cell values. - -If @emph{alloc-p} is true, all colormap cells are permanently -allocated read-write and cannot be freed by @var{free-colors}. It -is an error for @emph{alloc-p} to be true when the visual type -belongs to the @var{:static-gray}, @var{:static-color}, or -@var{:true-color} classes. - -@table @var -@item colormap -Type @var{colormap}. -@end table - -@end defun - - -@defun copy-colormap-and-free colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - -Creates and returns a new @var{colormap} by copying, then -freeing, allocated cells from the specified @emph{colormap}. - -All color cells allocated read-only or read-write in the original -@var{colormap} have the same color values and the same allocation -status in the @emph{new-colormap}. The values of unallocated color -cells in the @emph{new-colormap} are undefined. After copying, all -allocated color cells in the original @var{colormap} are freed, -as if @var{free-colors} was called. The unallocated cells of the -original @var{colormap} are not affected. - -If @emph{alloc-p} was true when the original @var{colormap} was -created, then all color cells of the @emph{new-colormap} are -permanently allocated read-write, and all the color cells of the -original @var{colormap} are freed. - -@table @var -@item new-colormap -Type @var{colormap}. -@end table - -@end defun - - -@defun free-colormap colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - -Destroys the @emph{colormap} and frees its server resource. If the -@emph{colormap} is installed, it is uninstalled. For any window -associated with the @emph{colormap}, the window is assigned a -@var{nil} @var{colormap}, and a @var{:colormap-notify} event is -generated. The colors displayed for a window with a @var{nil -colormap} are undefined. - -However, this function has no effect if the @emph{colormap} is a -screen default @var{colormap}. - -@end defun - - -@node Installing Colormaps, Allocating Colors, Creating Colormaps, Colormap Functions -@subsection Installing Colormaps - - -The following paragraphs describe the CLX functions to install and -uninstall colormaps and to return the set of installed colormaps. - -Initially, the default @var{colormap} for a screen is installed (but is -not in the required list). - -@defun install-colormap colormap -@anchor{install-colormap} - -@table @var -@item colormap -A @var{colormap}. -@end table - -Installs the @emph{colormap.} All windows associated with this -@emph{colormap} immediately display with true colors. As a -side-effect, additional colormaps might be implicitly uninstalled by -the server. - -If the specified @emph{colormap} is not already installed, a -@var{:colormap-notify} event is generated on every window -associated with this @emph{colormap}. In addition, for every other -colormap that is implicitly uninstalled, a @var{:colormap-notify} -event is generated on every associated window. - - -@end defun - - -@defun installed-colormaps window &key (:result-type 'list) - -@table @var -@item window -A @var{window}. -@item :result-type -A sub-type of @var{sequence} that indicates the type of sequence to return. -@end table - - -Returns a sequence containing the installed @var{colormaps} for the -screen of the specified @emph{window}. The order of the colormaps is -not significant. -@table @var -@item colormap -Type @var{sequence} of @var{colormap}. -@end table - -@end defun - - -@defun uninstall-colormap colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - -Uninstalls the @emph{colormap}. However, the @emph{colormap} is not -actually uninstalled if this would reduce the set of installed -colormaps below the value of @var{screen-min-installed-maps}. If -the @emph{colormap} is actually uninstalled, a -@var{:colormap-notify} event is generated on every associated -window. - - -@end defun - - -@node Allocating Colors, Finding Colors, Installing Colormaps, Colormap Functions -@subsection Allocating Colors - - -The following paragraphs describe the functions for allocating read-only -and read-write color cells, allocating color planes, and freeing color -cells. - -@defun alloc-color colormap color - -@table @var -@item colormap -A @var{colormap}. -@item color -A @var{color} object or a @var{stringable} containing a color name. -@end table - - -Returns a @emph{pixel} for a read-only color cell in the -@emph{colormap}. The color in the allocated cell is the closest -approximation to the requested @emph{color} possible for the screen -hardware. The other values returned give both the approximate color -stored in the cell and the exact color requested. - -The requested @emph{color} can be either a @var{color} object or a -@var{stringable} containing a color name. If a color name is -given, a corresponding color value is looked up (see -@var{lookup-color}) and used. Color name strings must contain only -ISO Latin-1 characters; case is not significant. - -@table @var -@item pixel -Type @var{pixel}. -@item screen-color -@itemx exact-color -Type @var{color}. -@end table - -@end defun - - -@defun alloc-color-cells colormap colors &key (:planes 0) :contiguous-p (:result-type 'list) - -@table @var -@item colormap -A @var{colormap}. -@item colors -A positive number defining the length of the pixels sequence returned. -@item :planes -A non-negative number defining the length of the masks sequence returned. -@item :contiguous-p -If true, the masks form contiguous sets of bits. -@item :result-type -A subtype of @var{sequence} that indicates the type of sequences returned. -@end table - - -Returns a @var{sequence} of @emph{pixels} for read-write color -cells in the @emph{colormap}. The allocated cells contain undefined -color values. The visual type class of the @var{colormap} must be -either @var{:gray-scale}, @var{:pseudo-color}, or -@var{:direct-color}. - -The @emph{colors} argument and the @var{:planes} argument define -the number of pixels and the number of masks returned, -respectively. The number of colors must be positive, and the number -of planes must be non-negative. A total of (* @emph{colors} -(@var{expt} 2 @emph{planes})) color cells are allocated. The pixel -values for the allocated cells can be computed by combining the -returned pixels and masks. - -The length of the returned masks sequence is equal to -@var{:planes}. Each mask of the returned masks sequence defines a -single bitplane. None of the masks have any 1 bits in common. Thus, -by selectively combining masks with @var{logior}, (@var{expt} 2 -@emph{planes}) distinct combined plane masks can be computed. - -The length of the returned @emph{pixels} sequence is equal to -@emph{colors}. None of the pixels have any 1 bits in common with -each other or with any of the returned masks. By combining pixels -and plane masks with @var{logior}, (* @emph{colors} (@var{expt} 2 -@emph{planes})) distinct pixel values can be produced. - -If the @emph{colormap} class is @var{:gray-scale} or -@var{:pseudo-color}, each @emph{mask} will have exactly one bit -set. If the @var{colormap} class is @var{:direct-color}, each -@emph{mask} will have exactly three bits set. If -@var{:contiguous-p} is true, combining all masks with @var{logior} -produces a plane mask with either one set of contiguous bits (for -@var{:gray-scale} and @var{:pseudo-color}) or three sets of -contiguous bits (for @var{:direct-color}). - -@table @var -@item pixels -@itemx mask -Type @var{sequence} of @var{pixels}. -@end table - -@end defun - - -@defun alloc-color-planes colormap colors &key (:reds 0) (:greens 0) (:blues 0) :contiguous-p (:result-type 'list) - -@table @var -@item colormap -A @var{colormap}. -@item colors -A positive number defining the length of the pixels sequence returned. -@item :planes -A non-negative number defining the length of the masks sequence returned. -@item :contiguous-p -If true, then the masks form contiguous sets of bits. -@item :result-type -A subtype of @var{sequence} that indicates the type of sequences returned. -@end table - - -Returns a @var{sequence} of @emph{pixels} for read-write color -cells in the @emph{colormap}. The allocated cells contain undefined -color values. The visual type class of the @emph{colormap} must be -either @var{:gray-scale}, @var{:pseudo-color}, or -@var{:direct-color}. - -The @emph{colors} argument defines the number of pixels -returned. The @var{:reds}, @var{:greens}, and @var{:blues} -arguments define the number of bits set in the returned red, green, -and blue masks, respectively. The number of colors must be positive, -and the number of bits for each mask must be non-negative. A total -of (* @emph{colors} (@var{expt} 2 (+ @emph{reds greens} -@emph{blues}))) color cells are allocated. The pixel values for the -allocated cells can be computed by combining the returned -@emph{pixels} and masks. - -Each mask of the returned masks defines a pixel subfield for the -corresponding primary. None of the masks have any 1 bits in -common. By selectively combining subsets of the red, green, and blue -masks with @var{logior}, (@var{expt} 2 (+ @emph{reds greens -blues}) distinct combined plane masks can be computed. - -The length of the returned @emph{pixels} @var{sequence} is equal to -@emph{colors}. None of the pixels have any 1 bits in common with -each other or with any of the returned masks. By combining pixels -and plane masks with @var{logior}, (* @emph{colors} (@var{expt} 2 -(+ @emph{reds greens blues})) distinct pixel values can be produced. - -If @var{:contiguous-p} is true, each of returned masks consists of -a set of contiguous bits. If the @var{colormap} class is -@var{:direct-color}, each returned mask lies within the pixel -subfield for its primary. - -@table @var -@item pixels -Type @var{sequence} of @var{pixel}. -@item red-mask -@itemx green-mask -@itemx blue-mask -Type @var{pixel}. -@end table - -@end defun - - -@defun free-colors colormap pixels &optional (plane-mask 0) - -@table @var -@item colormap -A @var{colormap}. -@item pixels -A @var{sequence} of pixel values. -@item plane-mask -A pixel value with no bits in common with any of the @emph{pixels}. -@end table - -Frees a set of allocated color cells from the @emph{colormap}. The -pixel values for the freed cells are computed by combining the given -@emph{pixels} sequence and @var{:plane-mask}. The total number of -cells freed is: - -@lisp -(* (@var{length} @emph{pixels}) (@var{expt} 2 (@var{logcount} @emph{plane-mask}))) -@end lisp - -The @var{:plane-mask} must not have any bits in common with any of -the given @emph{pixels}. The pixel values for the freed cells are -produced by using @var{logior} to combine each of the given pixels -with all subsets of the @var{:plane-mask}. - -Note that freeing an individual pixel allocated by -@var{alloc-color-planes} may not allow it to be reused until all -related pixels computed from the same plane mask are also freed. - -A single error is generated if any computed pixel is invalid or if -its color cell is not allocated by the client. Even if an error is -generated, all valid pixel values are freed. - - -@end defun - - -@node Finding Colors, Changing Colors, Allocating Colors, Colormap Functions -@subsection Finding Colors - - -A CLX program can ask the X server to return the colors stored in -allocated color cells. The server also maintains a dictionary of color -names and their associated color values. CLX provides a function to look -up the values for common colors by names such as "red", "purple", and so -forth. The following paragraphs describe the CLX functions for returning -the color values associated with color cells or with color names. - -@defun lookup-color colormap name - -@table @var -@item colormap -A @var{colormap}. -@item name -A @var{stringable} color name. -@end table - - -Returns the color associated by the X server with the given color -@emph{name}. The @emph{name} must contain only ISO Latin-1 -characters; case is not significant. The first value returned is the -closest approximation to the requested color possible on the screen -hardware. The second value returned is the true color value for the -requested color. - -@table @var -@item screen-color -@itemx exact-color -Type @var{color}. -@end table - -@end defun - - -@defun query-colors colormap pixels &key (:result-type 'list) - -@table @var -@item colormap -A @var{colormap}. -@item pixels -A @var{sequence} of @var{pixel} values. -@item :result-type -A subtype of @var{sequence} that indicates the type of sequences returned. -@end table - - -Returns a @var{sequence} of the colors contained in the allocated -cells of the @emph{colormap} specified by the given -@emph{pixels}. The values returned for unallocated cells are -undefined. -@table @var -@item colors -Type @var{sequence} of @var{color}. -@end table - -@end defun - - -@node Changing Colors, Colormap Attributes, Finding Colors, Colormap Functions -@subsection Changing Colors - - -The following paragraphs describe the CLX functions to change the colors -in colormap cells. - -@defun store-color colormap pixel color &key (:red-p t) (:green-p t) (:blue-p t) - -@table @var -@item colormap -A @var{colormap}. -@item pixel -A @var{pixel}. -@item color -A color @var{object} or a @var{stringable} containing a color name. -@item :red-p -@itemx :green-p -@itemx :blue-p -@var{boolean} values indicating which color components to -store. -@end table - -Changes the contents of the @emph{colormap} cell indexed by the -@emph{pixel}. Components of the given @emph{color} are stored in the -cell. The @var{:red-p}, @var{:green-p}, and @var{:blue-p} -arguments indicate which components of the given @emph{color} are -stored. - -The @emph{color} can be either a @var{color} object or a -@var{stringable} containing a color name. If a color name is given, -a corresponding color value is looked up (see @var{lookup-color}) -and used. Color name strings must contain only ISO Latin-1 -characters; case is not significant. - - -@end defun - - -@defun store-colors colormap pixel-colors &key (:red-p t) (:green-p t) (:blue-p t) - -@table @var -@item colormap -A @var{colormap}. -@item pixel-colors -A list of the form (@{@emph{pixel color}@}*). -@item :red-p -@itemx :green-p -@itemx :blue-p -@var{boolean} values indicating which color components to -store. -@end table - -Changes the contents of multiple @emph{colormap} -cells. @emph{pixel-colors} is a list of the form (@{ @emph{pixel -color}@}*), indicating a set of pixel values and the colors to store -in the corresponding cells. The @var{:red-p}, @var{:green-p}, and -@var{:blue-p} arguments indicate which components of the given colors -are stored. - -Each color can be either a @var{color} object or a -@var{stringable} containing a color name. If a color name is given, -a corresponding color value is looked up (see @var{lookup-color}) -and used. Color name strings must contain only ISO Latin-1 -characters; case is not significant. - - -@end defun - - -@node Colormap Attributes, , Changing Colors, Colormap Functions -@subsection Colormap Attributes - - -The complete set of colormap attributes is discussed in the following -paragraphs. - -@defun colormap-display colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - - -Returns the @var{display} object associated with the specified -@emph{colormap}. -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun colormap-equal colormap-1 colormap-2 - -@table @var -@item colormap-1 -@itemx colormap-2 -A @var{colormap}. -@end table - -Returns true if the two arguments refer to the same server resource -and @var{nil} if they do not. - - -@end defun - - -@defun colormap-id colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - -Returns the unique ID assigned to the specified @emph{colormap}. - -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun colormap-p colormap - -Returns non-@var{nil} if the argument is a @var{colormap} and -@var{nil} otherwise. - -@table @var -@item map-p -Type @var{boolean}. -@end table - -@end defun - -@defun colormap-plist colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - - - - -Returns and (with @code{setf}) sets the property list for the -specified @emph{colormap}. This function provides a hook where -extensions can add data. - -@table @var -@item colormap-p -Type @var{boolean}. -@end table - -@end defun - - -@node Cursors, Atoms, Colors, Top -@chapter Cursors - -A @emph{cursor} is a visible shape that appears at the current position -of the pointer device. The cursor shape moves with the pointer to -provide continuous feedback to the user about the current location of -the pointer. Each window can have a cursor attribute that defines the -appearance of the pointer cursor when the pointer position lies within -the window. See @var{window-cursor}. - -A cursor image is composed of a source bitmap, a mask bitmap, a @emph{hot -spot}, a foreground color, and a background color. Either 1-bit -pixmaps or font glyphs can be used to specify source and mask -bitmaps. The source bitmap identifies the foreground and background -pixels of the cursor image; the mask bitmap identifies which source -pixels are actually drawn. The mask bitmap thus allows a cursor to -assume any shape. The hot spot defines the position within the cursor -image that is displayed at the pointer position. - -In CLX, a cursor is represented by a @var{cursor} object. This section -describes the CLX functions to: - -@itemize @bullet -@item Create and free cursor objects - -@item Change cursor colors - -@item Inquire the best cursor size - -@item Access cursor attributes -@end itemize - -@menu -* Creating Cursors:: -* Cursor Functions:: -* Cursor Attributes:: -@end menu - -@node Creating Cursors, Cursor Functions, Cursors, Cursors -@section Creating Cursors - - -The following paragraphs describe the CLX functions used to create and -free @var{cursor} objects. - -@defun create-cursor &key :source :mask :x :y :foreground :background - -@table @var -@item :source -The source pixmap. This argument is required. -@item :mask -The mask pixmap. -@item :x -@itemx :y -The hot spot position in the @var{:source}. This argument is required. -@item :foreground -A @var{color} object specifying the foreground color. This argument is required. -@item :background -A @var{color} object specifying the background color. This argument is required. -@end table - - -Creates and returns a cursor. @var{:x} and @var{:y} define the -position of the hot spot relative to the origin of the -@var{:source. :foreground} and @var{:background} colors must be -specified, even if the server only has a @var{:static-gray} or -@var{:gray-scale} screen. The @var{:source}, @var{:x}, and -@var{:y} arguments must also be specified. - -The cursor image is drawn by drawing a pixel from the @var{:source} -bitmap at every position where the corresponding bit in the -@var{:mask} bitmap is 1. If the corresponding @var{:source} bit is -1, a pixel is drawn in the @var{:foreground} color; otherwise, a -pixel is drawn in the @var{:back-ground} color. If the @var{:mask} -is omitted, all @var{:source} pixels are drawn. If given, the -@var{:mask} must be the same size as the @var{:source}. - -An X server may not be able to support every cursor size. A server -is free to modify any component of the cursor to satisfy hardware or -software limitations. - -The @var{:source} and @var{:mask} can be freed immediately after -the cursor is created. Subsequent drawing in the @var{:source} or -@var{:mask} pixmap has an undefined effect on the cursor. - -@table @var -@item cursor -Type @var{cursor}. -@end table - -@end defun - - -@defun create-glyph-cursor &key :source-font :source-char :mask-font (:mask-char 0) :foreground :background - -@table @var -@item :source-font -The source font. This is a required argument. -@item :source-char -An index specifying a glyph in the source font. This is a required argument. -@item :mask-font -The mask font. -@item :mask-char -An index specifying a glyph in the mask font. -@item :foreground -A @var{color} object specifying the foreground color. This is a required argument. -@item :background -A @var{color} object specifying the background color. This is a required argument. -@end table - - -Creates and returns a cursor defined by font glyphs. The source -bitmap is defined by the @var{:source-font} and -@var{:source-char}. The mask bitmap is defined by the -@var{:mask-font} and @var{:mask-char}. It is an error if the -@var{:source-char} and @var{:mask-char} are not valid indexes for -the @var{:source-font} and @var{:mask-font}, respectively. The hot -spot position is defined by the "character origin" of the source -glyph, that is, the position [- @emph{char-left-bearing}, -@emph{char-ascent}] relative to the upper left corner of the source -glyph bitmap. - -Source and mask bits are compared after aligning the character -origins of the source and mask glyphs. The source and mask glyphs -need not have the same size or character origin position. If the -@var{:mask-font} is omitted, all source pixels are drawn. - -An X server may not be able to support every cursor size. A server -is free to modify any component of the cursor to satisfy hardware or -software limitations. - -Either of the @var{:source-font} or @var{:mask-font} can be closed -after the cursor is created. - -@table @var -@item cursor -Type @var{cursor}. -@end table - -@end defun - - -@defun free-cursor cursor - -@table @var -@item cursor -A @var{cursor} object. -@end table - -Destroys the @var{cursor} object. Cursor server resources are freed -when no other references remain. - - -@end defun - - -@node Cursor Functions, Cursor Attributes, Creating Cursors, Cursors -@section Cursor Functions - - -The following paragraphs describe the CLX functions used to operate on -@var{cursor} objects. - -@defun query-best-cursor width height display - -@table @var -@item display -A @var{display} object. -@item width -@itemx height -The requested cursor size. -@end table - -Returns the cursor size closest to the requested @emph{width} and -@emph{height} that is best suited to the display. The @emph{width} -and @emph{height} returned define the largest cursor size supported -by the X server. Clients should always be prepared to limit cursor -sizes to those supported by the server. - -@table @var -@item width -@itemx height -Type @var{card16}. -@end table - -@end defun - - -@defun recolor-cursor cursor foreground background - -@table @var -@item cursor -A @var{cursor} object. -@item foreground -A @var{color} object specifying the new foreground color. -@item background -A @var{color} object specifying the new background color. -@end table - -Changes the color of the specified @emph{cursor}. If the cursor is -displayed on a screen, the change is visible immediately. - - -@end defun - - -@node Cursor Attributes, , Cursor Functions, Cursors -@section Cursor Attributes - - -The complete set of cursor attributes is discussed in the following -paragraphs. - -@defun cursor-display cursor - -@table @var -@item cursor -A @var{cursor} object. -@end table - - -Returns the @var{display} object associated with the specified -@emph{cursor}. - -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun cursor-equal cursor-1 cursor-2 - -@table @var -@item cursor-1 -@itemx cursor-2 -@var{cursor} objects. -@end table - -Returns true if the two arguments refer to the same server resource -and @var{nil} if they do not. - - -@end defun - - -@defun cursor-id cursor - -@table @var -@item cursor -A @var{cursor} object. -@end table - - -Returns the unique resource ID that has been assigned to the -specified @emph{cursor}. - -@table @var -@item id -Type @var{resource-id.} -@end table - -@end defun - - -@defun cursor-p cursor - -@table @var -@item cursor-p -Type @var{boolean}. -@end table - -Returns true if the argument is a @var{cursor} object and -@var{nil} otherwise. - -@end defun - -@defun cursor-plist cursor - -@table @var -@item cursor -A @var{cursor} object. -@end table - - -Returns and (with @code{setf}) sets the property list for the -specified @emph{cursor}. This function provides a hook where -extensions can add data. - -@table @var -@item plist -A property list. -@end table - -@end defun - - -@node Atoms, Events and Input, Cursors, Top -@chapter Atoms, Properties and Selections - -@menu -* Atoms (Atoms):: -* Properties:: -* Selections:: -@end menu - -@node Atoms (Atoms), Properties, Atoms, Atoms -@section Atoms - - -In X, an @emph{atom} is a unique ID used as the name for certain server -resources -- properties and selections. - -In CLX, an atom is represented by a keyword symbol. For convenience, CLX -functions also allow atoms to be specified by strings and non-keyword -symbols. @var{xatom} is a CLX data type that permits either string or -symbol values. A string is equivalent to the @var{xatom} given by -(@var{intern} @emph{string} @var{'keyword}). A symbol is equivalent to -the @var{xatom} given by ( @var{intern} (@var{symbol-name} -@emph{symbol}) @var{'keyword}). The symbol name string of an -@var{xatom} must consist only of ISO Latin characters. Note that the -case of @var{xatom} strings is important; the @var{xatom} "Atom" is -not the same as the @var{xatom} "ATOM". - -Certain atoms are already predefined by every X server. Predefined atoms -are designed to represent common names that are likely to be useful for -many client applications. Note that these atoms are predefined only in -the sense of having @var{xatom} and @var{card29} values, not in the -sense of having required semantics. No interpretation is placed on the -meaning or use of an atom by the server. The @var{xatom} objects -predefined by CLX are listed below. - -@multitable @columnfractions 0.3 0.3 0.3 -@item @var{:arc} @tab @var{:italic_angle} @tab @var{:string} -@item @var{:atom} @tab @var{:max_space} @tab @var{:subscript_x} -@item @var{:bitmap} @tab @var{:min_space} @tab @var{:subscript_y} -@item @var{:cap_height} @tab @var{:norm_space} @tab @var{:superscript_x} -@item @var{:cardinal} @tab @var{:notice} @tab @var{:superscript_y} -@item @var{:colormap} @tab @var{:pixmap} @tab @var{:underline_position} -@item @var{:copyright} @tab @var{:point} @tab @var{:underline_thickness} -@item @var{:cursor} @tab @var{:point_size} @tab @var{:visualid} -@item @var{:cut_buffer0} @tab @var{:primary} @tab @var{:weight} -@item @var{:cut_buffer1} @tab @var{:quad_width} @tab @var{:window} -@item @var{:cut_buffer2} @tab @var{:rectangle} @tab @var{:wm_class} -@item @var{:cut_buffer3} @tab @var{:resolution} @tab @var{:wm_client_machine} -@item @var{:cut_buffer4} @tab @var{:resource_manager} @tab @var{:wm_command} -@item @var{:cut_buffer5} @tab @var{:rgb_best_map} @tab @var{:wm_hints} -@item @var{:cut_buffer6} @tab @var{:rgb_blue_map} @tab @var{:wm_icon_name} -@item @var{:cut_buffer7} @tab @var{:rgb_color_map}@tab @var{:wm_icon_size} -@item @var{:drawable} @tab @var{:rgb_default_map} @tab @var{:wm_name} -@item @var{:end_space} @tab @var{:rgb_gray_map} @tab @var{:wm_normal_hints} -@item @var{:family_name} @tab @var{:rgb_green_map}@tab @var{:wm_size_hints} -@item @var{:font} @tab @var{:rgb_red_map} @tab @var{:wm_transient_for} -@item @var{:font_name} @tab @var{:secondary} @tab @var{:wm_zoom_hints} -@item @var{:full_name} @tab @var{:strikeout_ascent} @tab @var{:x_height} -@item @var{:integer} @tab @var{:strikeout_descent} @tab -@end multitable - - -When creating a new atom, the following conventions should be obeyed in -order to minimize the conflict between atom names: - -@itemize @bullet -@item -Symbol names beginning with an underscore should be used for atoms -that are private to a particular vendor or organization. An additional -prefix should identify the organization. - -@item -Symbol names beginning with two underscores should be used for atoms -that are private to a single application or end user. -@end itemize - - -CLX provides functions to convert between an @var{xatom} and its -corresponding ID integer. The data type of an atom ID is -@var{card29}. The @var{xatom} representation is usually sufficient for -most CLX programs. However, it is occasionally useful to be able to -convert an atom ID returned in events or properties into its -corresponding @var{xatom}. - -@defun atom-name display atom-id - -@table @var -@item display -A @var{display} object. -@item atom-id -A @var{card29}. -@end table - -Returns the atom keyword for the @emph{atom-id} on the given -@emph{display} server. - -@table @var -@item atom-name -Type @var{keyword}. -@end table - -@end defun - - -@defun find-atom display atom-name - -@table @var -@item display -A @var{display} object. -@item atom-name -An @var{xatom}. -@end table - -Returns the atom ID for the given @emph{atom-name}, if it exists. If -no atom of that name exists for the display server, @var{nil} is -returned. - -@table @var -@item atom-id -Type @var{card29} or @var{null}. -@end table - -@end defun - - -@defun intern-atom display atom-name - -@table @var -@item display -A @var{display} object. -@item atom-name -An @var{xatom}. -@end table - -Creates an atom with the given name and returns its atom ID. The -atom can survive the interning client; it exists until the last -server connection has been closed and the server resets itself. - -@table @var -@item atom-id -Type @var{card29} or @var{null}. -@end table - -@end defun - - -@node Properties, Selections, Atoms (Atoms), Atoms -@section Properties - - -For each window, an X server can record a set of -@emph{properties}. Properties are a general mechanism for clients to -associate arbitrary data with a window, and for clients to communicate -window data to each other via the server. No interpretation is placed on -property data by the server itself. - -A property consists of a name, a type, a data format, and data. The name -of a property is given by an atom. The property type is another atom -used to denote the intended interpretation of the property data. The -property formats specifies whether the property data should be treated -as a set of 8-, 16-, or 32-bit elements. The property format must be -specified so that the X server can communicate property data with the -correct byte order. - -CLX provides functions to: - -@itemize @bullet -@item Create or change a property - -@item Return property data - -@item List window properties - -@item Delete a property -@end itemize - - -@defun change-property window property data type format &key (:mode :replace) (:start 0) :end :transform - -@table @var -@item window -A @var{window}. -@item property -A property name @var{xatom}. -@item data -A sequence of property data elements. -@item type -The property type @var{xatom}. -@item format -One of 8, 16, or 32. -@item :mode -One of @var{:replace}, @var{:append}, or @var{:prepend}. -@item :start -@itemx :end -Specify the subsequence of previous data replaced when @var{:mode} is @var{:replace}. -@item :transform -A function that transforms each data element into a data value to store. -@end table - -Creates a new window property or changes an existing property. A -@var{:property-notify} event is generated for the @emph{window}. - -If the @var{:mode} is @var{:replace}, the new @emph{data}, -@emph{type}, and @emph{format} replace any previous values. The -subsequence of previous data elements that are replaced is defined -by the @var{:start} and @var{:end} indexes. - -If the @var{:mode} is @var{:prepend} or @var{:append}, no -previous data is changed, but the new @emph{data} is added at the -beginning or the end, respectively. For these modes, if the -@emph{property} already exists, the new @emph{type} and -@emph{format} must match the previous values. - -The @var{:transform}, if given, is a function used to compute the -actual property data stored. The @var{:transform}, which must -accept a single data element and return a single transformed data -element, is called for each data element. If the @emph{data} is a -string, the default @var{:transform} function transforms each -character into its ASCII code; otherwise, the default is to store -the @emph{data} unchanged. - - -@end defun - - -@defun delete-property window property - -@table @var -@item window -A @var{window}. -@item property -A property name @var{xatom}. -@end table - -Deletes the @emph{window property}. If the @emph{property} already -exists, a @var{:property-notify} event is generated for the -@emph{window}. - - -@end defun - - -@defun get-property window property &key :type (:start 0) :end :delete-p (:result-type 'list) :transform -@anchor{get-property} - -@table @var -@item window -A @var{window}. -@item property -A property name @var{xatom}. -@item :type -The requested type @var{xatom} or @var{nil}. -@item :start -@itemx :end -Specify the subsequence of property @emph{data} returned. -@item :transform -A function that transforms each data element into a data value to return. -@item :delete-p -If true, the existing @emph{property} can be deleted. -@item :result-type -The t@emph{ype} of data sequence to return. Default is @var{'list}. -@end table - -Returns a subsequence of the data for the window property. The -@var{:start} and @var{:end} indexes specify the property -@emph{data} elements returned. The @var{:transform} function is -called for elements of the specified subsequence to compute the -@emph{data} sequence returned. The property @emph{type} and -@emph{format} are also returned. The final return value gives the -actual number of data bytes (not elements) following the last data -element returned. - -If the @emph{property} does not exist, the returned @emph{data} and -@emph{type} are @var{nil} and the returned @emph{format} and -@emph{bytes-after} are zero. - -If the given @var{:type} is non-@var{nil} but does not match the -actual property type, then the @emph{data} returned is @var{nil}, -the @emph{type} and @emph{format} returned give the actual property -values, and the @emph{bytes-after} returned gives the total number -of bytes (not elements) in the property data. - -If the given @var{:type} is @var{nil} or if it matches the actual -property type, then: - -@itemize @bullet -@item -The @emph{data} returned is the transformed subsequence of the -property data. - -@item -The @emph{type} and @emph{format} returned give the actual -property values. - -@item -The @emph{bytes-after} returned gives the actual number of data -bytes (not elements) following the last data element returned. -@end itemize - - -In this case, the @var{:delete-p} argument is also examined. If -@var{:delete-p} is true and @emph{bytes-after} is zero, the -property is deleted and a @var{:property-notify} event is generated -for the @emph{window}. - -@table @var -@item data -Type @var{sequence}. -@item type -Type @var{xatom}. -@item format -Type (@var{member 8 16 32}). -@item bytes-after -Type @var{card32}. -@end table - -@end defun - - -@defun list-properties window &key (:result-type 'list) - -@table @var -@item window -A @var{window}. -@item :result-type -The type of sequence to return. Default is @var{'list}. -@end table - - -Returns a sequence containing the names of all @emph{window -properties}. -@table @var -@item properties -Type @var{sequence} of @var{keyword}. -@end table - -@end defun - - -@defun rotate-properties window properties &optional (delta 1) - -@table @var -@item window -A @var{window}. -@item properties -A sequence of @var{xatom} values. -@item delta -The index interval between source and destination elements of @emph{properties}. -@end table - -Rotates the values of the given @emph{window properties}. The value -of property @emph{i} in the given sequence is changed to the value -of the property at index (@var{mod} (+ @emph{i delta}) -(@var{length} @emph{properties})). This function operates much like -the @var{rotatef} macro in Common Lisp. - -If (@var{mod} @emph{delta} (@var{length} @emph{properties})) is -non-zero, a @var{:property-notify} event is generated on the window -for each property, in the same order as they appear in the -@emph{properties} sequence. - - -@end defun - - -@node Selections, , Properties, Atoms -@section Selections - - -A selection is an atom used to identify data that can be shared among -all client programs connected to an X server. Unlike properties, the -data represented by a selection is stored by some client program, not by -the server. - -The data named by a selection is associated with a client window, which -is referred to as the @emph{selection owner}. The server always knows -which window is the owner of a selection. Selections can be created -freely by clients using @var{intern-atom} to create an atom. CLX -provides functions to inquire or change the owner of a selection and to -@emph{convert} a selection. - -Conversion is the key to the use of selections for inter-client -communication. Suppose Client A wants to paste the contents of the data -named by selection @emph{S} into his window @emph{WA}. Client A calls -@var{convert-selection} on selection atom @emph{S}, sending a -conversion request to the server. The server, in turn, sends a -@var{:selection-request} event to the current owner of @emph{S}, which -is window @emph{WB} belonging to Client B. The @var{:selection-request} -event contains the @emph{requestor} window (@emph{WA}), the selection -atom (@emph{S}), an atom identifying a requested data type, and the name -of a property of @emph{WA} into which the value of @emph{S} will be -stored. - -Since @emph{WB} is the owner of @emph{S}, it must be associated with the -data defined by Client B as the value of @emph{S}. When @emph{WB} gets -the @var{:selection-request} event, Client B is expected to convert the -value of @emph{S} to the requested data type (if possible) and store the -converted value in the given requestor property. Client B is then -expected to send a @var{:selection-notify} event to the requestor -window @emph{WA}, informing the requestor that the converted value for -@emph{S} is ready. Upon receiving the @var{:selection-notify} event, -Client A can call @var{get-property} to retrieve the converted value -and to paste it into @emph{WA}. - -@var{NOTE:} Clients using selections must always be prepared to handle -@var{:selection-request} events and/or @var{:selection-notify} -events. There is no way for a client to ask not to receive these types -of events. - -Type atoms used in selection conversion can represent arbitrary -client-defined interpretations of the selection data. For example, if -the value of selection @emph{S} is a text string, Client A might request -its typeface by requesting conversion to the @var{:font} type. A type -@var{atom} can also represent a request to the selection owner to -perform some action as a side-effect of conversion (for example, -@var{:delete}). Some of the predefined atoms of an X server are -intended to be used as selection types (for example, @var{:colormap}, -@var{:bitmap}, @var{:string}, and so forth) However, X does not impose -any requirements on the interpretation of type atoms. - -When multiple clients negotiate for ownership of a selection, certain -race conditions might be possible. For example, two clients might each -receive a user command to assert ownership of the @var{:primary} -selection, but the order in which the server processes these client -requests is unpredictable. As a result, the ownership request initiated -most recently by the user might be incorrectly overridden by the other -earlier ownership request. To prevent such anomalies, the server records -a @emph{last-changed} timestamp for each change of selection ownership. - -Although inter-client communication via selections is rather complex, it -offers important benefits. Since selection communication is mediated by -an X server, clients can share data even though they are running on -different hosts and using different networking protocols. Data storage -and conversion is distributed among clients so that the server is not -required to provide all possible data types or to store multiple forms -of selection data. - -Certain predefined atoms are used as standard selections, as described -in the X11 Inter-client Communications Conventions Manual. Some of the -standard selections covered by these conventions are: - -@table @var -@item :primary -The @emph{primary selection}. The main vehicle for inter-client cut -and paste operations. -@item :secondary -The @emph{secondary selection}. In some environments, clients can use -this as an auxiliary to @var{:primary}. -@item :clipboard -Analogous to akill ring. Represents the most recently deleted data -item. -@end table - - -@defun convert-selection selection type requestor &optional property time - -@table @var -@item selection -The @var{xatom} for the selection name. -@item type -The @var{xatom} for the requested data type. -@item requestor -The @var{window} to receive the converted @emph{selection} value. -@item property -The @var{xatom} for the requestor property to receive the converted value. -@item time -A @var{timestamp}. -@end table - -Requests that the value of the @emph{selection} be converted to the -specified @emph{type} and stored in the given @emph{property} of the -@emph{requestor} window. - -If the @emph{selection} has an owner, the X server sends a -@var{:selection-request} event to the owner window. Otherwise, if -no owner exists, the server generates on the requestor a -@var{:selection-notify} event containing a @var{nil} -@emph{property} atom. - -The given @emph{property} specifies the requestor property that will -receive the converted value. If the @emph{property} is omitted, the -@emph{selection} owner will define a property to use. The -@emph{time} furnishes a timestamp representing the time of the -conversion request; by default, the current server time is used. - -@var{NOTE:} Standard conventions for inter-client communication -require that both the requestor property and the time must be -specified. If possible, the time should be the time of a user event -which initiated the conversion. Alternatively, a timestamp can be -obtained by calling @var{change-property} to append zero-length -data to some property; the timestamp in the resulting -@var{:property-notify} event can then be used. - - -@end defun - - -@defun selection-owner display selection &optional time - -@table @var -@item display -A @var{display}. -@item selection -The @var{xatom} for the selection name. -@item time -A @var{timestamp}. -@end table - - -Returns and (with @code{setf}) changes the owner and the -last-changed @emph{time} for the @emph{selection}. If the owner is -@var{nil}, no owner for the @emph{selection} exists. When the owner -window for a @emph{selection} is destroyed, the @emph{selection} -owner is set to @var{nil} without affecting the last-changed -@emph{time}. - -The @emph{time} argument is used only when changing the -@emph{selection} owner. If the @emph{time} is @var{nil}, the -current server time is used. If the @emph{time} is earlier than the -current last-changed time of the @emph{selection} or if the -@emph{time} is later than the current server time, the owner is not -changed. Therefore, a client should always confirm successful change -of ownership by immediately calling @var{selection-owner}. If the -change in ownership is successful, the last-changed time of the -@emph{selection} is set to the specified @emph{time}. - -If the change in ownership is successful and the new owner is -different from the previous owner, and if the previous owner is not -@var{nil}, a @var{:selection-clear} event is generated for the -previous owner window. - -@var{NOTE:} Standard conventions for inter-client communication -require that a non-nil time must be specified. If possible, the time -should be the time of a user event which initiated the change of -ownership. Alternatively, a timestamp can be obtained by calling -change-property to append zero-length data to some property; the -timestamp in the resulting @var{:property-notify} event can then be -used. -@table @var -@item owner -Type @var{window} or @var{null}. -@end table - -@end defun - - -@node Events and Input, Resources, Atoms, Top -@chapter Events and Input - -A client application uses CLX functions to send @emph{requests} to an X -server over a display connection returned by the @var{open-display} -function. In return, the X server sends back @emph{replies} and -@emph{events}. Replies are synchronized with specific requests and -return requested server information. Events typically occur -asynchronously. Device events are generated by user input from both the -keyboard and pointer devices. Other events are side-effects of the -requests sent by CLX functions. The types of events returned by an X -server are summarized below. - -Device Events - -@table @asis -@item Keyboard -@var{:key-press} @var{:key-release} -@item Pointer -@var{:button-press} -@var{:button-release} -@var{:enter-notify} -@var{:leave-notify} -@var{:motion-notify} -@end table - -Side-Effect Events - -@table @asis -@item Client communication -@var{:client-message} -@var{:property-notify} -@var{:selection-clear} -@var{:selection-notify} -@var{:selection-request} -@item Color map state -@var{:colormap-notify} - -@item Exposure -@var{:exposure} -@var{:graphics-exposure} -@var{:no-exposure} - -@item Input focus -@var{:focus-in} -@var{:focus-out} - -@item Keyboard and pointer state -@var{:keymap-notify} -@var{:mapping-notify} - -@item Structure control -@var{:circulate-request} -@var{:configure-request} -@var{:map-request} - -@item Window state -@var{:resize-request} -@var{:circulate-notify} -@var{:configure-notify} -@var{:create-notify} -@var{:destroy-notify} -@var{:gravity-notify} -@var{:map-notify} -@var{:reparent-notify} -@var{:unmap-notify} -@var{:visibility-notify} -@end table - -Client programs can override the server's normal distribution of events -by@emph{ grabbing} the pointer or the keyboard. Grabbing causes events -from the pointer or keyboard device to be reported to a single specified -window, rather than to their ordinary destinations. It can also cause -the server to @emph{freeze} the grabbed device, sending queued events -only when explicitly requested by the grabbing client. Two kinds of -grabs are possible: -@itemize @bullet - -@item Active -- Events are immediately grabbed. - -@item Passive -- Events are grabbed later, as soon as a specified device event occurs. -@end itemize - -Grabbing an input device is performed rarely and usually only by special -clients, such as window managers. - -This section describes the CLX functions used to: -@itemize @bullet - -@item Select events (@pxref{Selecting Events}) - -@item Process an event on the event queue (@pxref{Processing Events}) - -@item Manage the event queue (@pxref{Managing the Event Queue}) - -@item Send events to other applications (@pxref{Sending Events}) - -@item Read and change the pointer position (@pxref{Pointer Position}) - -@item Manage the keyboard input focus (@pxref{Managing Input Focus}) - -@item Grab pointer and keyboard events (@pxref{Grabbing the Pointer}) - -@item Release queued events (@pxref{Releasing Queued Events}) -@end itemize - -This section also contains a detailed description of the content of each type of event. - -@menu -* Selecting Events:: -* Processing Events:: -* Managing the Event Queue:: -* Sending Events:: -* Pointer Position:: -* Managing Input Focus:: -* Grabbing the Pointer:: -* Grabbing a Button:: -* Grabbing the Keyboard:: -* Grabbing a Key:: -* Event Types:: -* Releasing Queued Events:: -@end menu - -@node Selecting Events, Processing Events, Events and Input, Events and Input -@section Selecting Events - - -A client @emph{selects} which types of events it receives from a -specific window. The window event-mask attribute, set by the client, -determines which event types are selected (see @var{window-event-mask} -in @ref{Window Attributes}). Most types of events are received -by a client only if they are selected for some window. - -In the X protocol, an event-mask is represented as a bit string. CLX -also allows an event mask to be defined by a list of -@var{event-mask-class} keywords. The functions @var{make-event-keys} -and @var{make-event-mask} can be used to convert between these two -forms of an event-mask. In general, including an @var{event-mask-class} -keyword in an event-mask causes one or more related event types to be -selected. The following table describes the event types selected by each -@var{event-mask-class} keyword. - -@multitable @columnfractions 0.5 0.5 -@item Event Mask Keyword @tab Event Types Selected -@item @var{:button-1-motion} -@tab @var{:motion-notify} when @var{:button-1} is down -@item @var{:button-2-motion} -@tab @var{:motion-notify} when @var{:button-2} is down -@item @var{:button-3-motion} -@tab @var{:motion-notify} when @var{:button-3} is down -@item @var{:button-4-motion} -@tab @var{:motion-notify} when @var{:button-4} is down -@item @var{:button-5-motion} -@tab @var{:motion-notify} when @var{:button-5} is down -@item @var{:button-motion} -@tab @var{:motion-notify} when any pointer button is down -@item @var{:button-press} -@tab @var{:button-press} -@item @var{:button-release} -@tab @var{:button-release} -@item @var{:colormap-change} -@tab @var{:colormap-notify} -@item @var{:enter-window} -@tab @var{:enter-notify} -@item @var{:exposure} -@tab @var{:exposure} -@item @var{:focus-change} -@tab @var{:focus-in} @var{:focus-out} -@item @var{:key-press} -@tab @var{:key-press} -@item @var{:key-release} -@tab @var{:key-release} -@item @var{:keymap-state} -@tab @var{:keymap-notify} -@item @var{:leave-window} -@tab @var{:leave-notify} -@item @var{:owner-grab-button} -@tab Pointer events while button is grabbed -@item @var{:pointer-motion} -@tab @var{:motion-notify} -@item @var{:pointer-motion-hint} -@tab Single @var{:motion-notify} only -@item @var{:property-change} -@tab @var{:property-notify} -@item @var{:resize-redirect} -@tab @var{:resize-request} -@item @var{:structure-notify} -@tab @var{:circulate-notify} @var{:configure-notify} @var{:destroy-notify} @var{:gravity-notify} @var{:map-notify} @var{:reparent-notify} @var{:unmap-notify} -@item @var{:substructure-redirect} -@tab @var{:circulate-request} @var{:configure-request} @var{:map-request} -@item @var{:visibility-change} -@tab @var{:visibility-notify} -@end multitable - - -Some types of events do not have to be selected to be received and -therefore are not represented in an event-mask. For example, the -@var{copy-plane} and @var{copy-area} functions cause -@var{:graphics-exposure} and @var{:no-exposure} events to be reported, -unless exposures are turned @var{:off} in the graphics context (see -@var{copy-area} and @var{copy-plane} in @ref{Area and Plane Operations}, -and @var{gcontext-exposures} in paragraph 5.4.6, Exposures). Also, @var{:selection-clear}, @var{:selection-request}, -@var{:selection-notify} and @var{:client-message} events can be -received at any time, but they are generally sent only to clients using -selections (@pxref{Client Communications Events}). @var{:mapping-notify} is always sent to clients when the -keyboard mapping is changed. - -Any client can select events for any window. A window maintains a -separate event-mask for each interested client. In general, multiple -clients can select for the same events on a window. After the X server -generates an event, it sends it to all clients which selected -it. However, the following restrictions apply to sharing window events -among multiple clients. For a given window: -@itemize @bullet - -@item Only one client at a time can include @var{:substructure-redirect} in its event-mask - -@item Only one client at a time can can include @var{:button-press} in its event-mask - -@item Only one client at a time can include @var{:resize-redirect} in its event-mask -@end itemize - -@node Processing Events, Managing the Event Queue, Selecting Events, Events and Input -@section Processing Events - - -Events received by a CLX client are stored in an @emph{event queue} -until they are read and processed. Events are processed by @emph{handler -functions}. - -@defun handler-function &rest event-slots &key :display :event-key :send-event-p &allow-other-keys - -@table @var -@item :display -A @var{display} for the connection that returned the event. -@item :event-key -An @var{event-key} keyword specifying the event type. -@item :send-event-p -If true, the event was sent from another application using the -@var{send-event} function. -@end table - - -The arguments to a handler function are keyword-value pairs that -describe the contents of an event. The actual @emph{event-slots} -passed depend on the event type, except that @var{:display}, -@var{:event-key}, and @var{:send-event-p} are given for all event -types. The keyword symbols used for each event type are event slot -names defined by the @var{declare-event} macro and are described in -@ref{Declaring Event Types}. - -If a handler returns non-@var{nil}, the event is considered -@emph{processed} and can be removed from the event queue. Otherwise, -if a handler function returns @var{nil}, the event can remain in -the event queue for later processing. -@table @var -@item handled-p -Type @var{boolean}. -@end table - -@end defun - - -@defun process-event display &key :handler :timeout :peek-p :discard-p (:force-output-p t) - -@table @var -@item display -A @var{display}. -@item :handler -A handler function or a sequence of handler functions. -@item :timeout -Specifies the timeout delay in seconds. -@item :peek-p -If @var{nil}, events are removed from the event queue after processing. -@item :discard-p -If true, unprocessed events are discarded. -@item :force-output-p -If true, buffered output requests are sent. -@end table - - -Invokes @var{:handler} on each queued event until @var{:handler} -returns non-@var{nil}. Then, the non-@var{nil :handler} value is -returned by @var{process-event}. If @var{:handler} returns -@var{nil} for each event in the event queue, @var{process-event} -waits for another event to arrive. If timeout is non-@var{nil} and -no event arrives within the specified timeout interval (given in -seconds), @var{process-event} returns @var{nil}; if timeout is -@var{nil}, @var{process-event} will not return until -@var{:handler} returns non-@var{nil}. @var{process-event} may -wait only once on network data, and therefore timeout prematurely. - -If @var{:force-output-p} is true, @var{process-event} first -invokes @var{display-force-output} to send any buffered -requests. If @var{:peek-p} is true, a processed event is not -removed from the queue. If @var{:discard-p} is true, unprocessed -events are removed from the queue; otherwise, unprocessed events are -left in place. - -If @var{:handler} is a sequence, it is expected to contain handler -functions for each event type. The sequence index of the handler -function for a particular event type is given by ( @var{position -event-key *event-key-vector*}). -@table @var -@item handled-p -Type @var{boolean}. -@end table - -@end defun - - -@defmac event-case display &key :timeout :peek-p :discard-p (:force-output-p t) &body clauses -@anchor{event-case} - -@table @var -@item display -A @var{display}. -@item :handler -A handler function or a sequence of handler functions. -@item :timeout -Specifies the timeout delay, in seconds. -@item :peek-p -If @var{nil}, events are removed from the event queue after processing. -@item :discard-p -If true, unprocessed events are discarded. -@item :force-output-p -If true, buffered output requests are sent. -@item clauses -Code to process specified event types. -@end table - -Executes the matching clause for each queued event until a clause -returns non-@var{nil}. The non-@var{nil} clause value is then -returned. Each of the clauses is a list of the form -(@emph{event-match} [@emph{event-slots}] &rest @emph{forms}), -where: -@itemize @bullet - -@item -@emph{event-match} -- Either an @var{event-key}, a list of -@var{event-keys}, otherwise, or @var{t}. It is an error for the -same key to appear in more than one clause. - -@item -@emph{event-slots} -- If given, a list of (non-keyword) event slot -symbols defined for the specified event type(s). @xref{Declaring Event Types}. - -@item -@emph{forms} -- A list of forms that process the specified event -type(s). The value of the last form is the value returned by the -clause. -@end itemize - -A clause matches an event if the @var{event-key} is equal to or a -member of the @emph{event-match}, or if the @emph{event-match} is -@var{t} or @var{otherwise}. If no @var{t} or @var{otherwise} -clause appears, it is equivalent to having a final clause that -returns @var{nil}. If @emph{event-slots} is given, these symbols -are bound to the value of the corresponding event slot in the clause -forms. Each element of @emph{event-slots} can also be a list of the -form (@emph{event-slot-keyword variable}), in which case the -@emph{variable} symbol is bound to the value of the event slot -specified by the @emph{event-slot-keyword}. - -If every clause returns @var{nil} for each event in the event -queue, @var{event-case} waits for another event to arrive. If -@var{:timeout} is non-@var{nil} and no event arrives within the -specified timeout interval (given in seconds), @var{event-case} -returns @var{nil}; if @var{:timeout} is @var{nil}, -@var{event-case} will not return until a clause returns -non-@var{nil}. @var{event-case} may wait only once on network data -and therefore timeout prematurely. - -If @var{:force-output-p} is true, @var{event-case} first invokes -@var{display-force-output} to send any buffered requests. If -@var{:peek-p} is true, a processed event is not removed from the -queue. If @var{:discard-p} is true, unprocessed events are removed -from the queue; otherwise, unprocessed events are left in place. - -@table @var -@item handled-p -Type @var{boolean}. -@end table - -@end defmac - - - -@defmac event-cond display &key :timeout :peek-p :discard-p (:force-output-p t) &body clauses - -@table @var -@item handled-p -Type @var{boolean}. -@end table - - -Similar to @var{event-case} except that each of the clauses is a -list of the form (@emph{event-match} [@emph{event-slots}] -@emph{test-form} &rest @emph{forms}). Executes the -@emph{test-form} of the clause that matches each queued event until -a @emph{test-form} returns non-@var{nil}. The body @emph{forms} of -the clause are then executed. The values returned by the last clause -body form are then returned by @var{event-cond}. - -When a @emph{test-form} returns true and @var{:peek-p} is -@var{nil}, or when a @emph{test-form} returns @var{nil} and -@var{:discard-p} is true, the matching event is removed from the -event queue before the body @emph{forms} are executed. -@table @var -@item display -A @var{display}. -@item :handler -A handler function or a sequence of handler functions. -@item :timeout -Specifies the timeout delay in seconds. -@item :peek-p -If @var{nil}, events are removed from the event queue after processing. -@item :discard-p -If true, unprocessed events are discarded. -@item :force-output-p -If true, buffered output requests are sent. -@item clauses -Code to process specified event types. -@end table - -@end defmac - - - -@node Managing the Event Queue, Sending Events, Processing Events, Events and Input -@section Managing the Event Queue - - -The following paragraphs describe CLX functions and macros used to: -@itemize @bullet - -@item Put a new event on the event queue - -@item Discard the current event - -@item Return the current length of the event queue - -@item Gain exclusive access to the event queue for a client process -@end itemize - -@defun queue-event display event-key &rest event-slots &key :append-p &allow-other-keys - -@table @var -@item display -A @var{display}. -@item event-key -Specifies the type of event placed in the queue. -@item event-slots -Keyword-value pairs that describe the contents of an event. -@item :append-p -If true, the event is placed at the tail of the queue; otherwise, the event is -placed at the head of the queue. -@end table - -Places an event of the type given by @emph{event-key} into the event -queue. When @var{:append-p} is true, the event is placed at the -tail of the queue; otherwise, the event is placed at the head of the -queue. The actual @emph{event-slots} passed depend on the event -type. The keyword symbols used for each event type are event slot -names defined by the @var{declare-event} macro and are described in -@ref{Declaring Event Types}. - - - -@end defun - - -@defun discard-current-event display - -@table @var -@item display -A @var{display}. -@end table - - -Discards the current event for the @emph{display}. Returns -@var{nil} when the event queue is empty; otherwise, returns -@var{t}. This function provides extra flexibility for discarding -events, but it should be used carefully; use @var{event-cond} -instead, if possible. Typically, @var{discard-current-event} is -called inside a handler function or a clause of an @var{event-case} -form and is followed by another call to @var{process-event}, -@var{event-case}, or @var{event-cond}. -@table @var -@item discarded-p -Type @var{boolean}. -@end table - -@end defun - - -@defun event-listen display &optional (timeout 0) - -@table @var -@item display -A @var{display}. -@item timeout -The number of seconds to wait for events. -@end table - - -Returns the number of events queued locally. If the event queue is -empty, @var{event-listen} waits for an event to arrive. If timeout -is non-@var{nil} and no event arrives within the specified timeout -interval (given in seconds), @var{event-listen} returns @var{nil}; -if timeout is @var{nil}, @var{event-listen} will not return until -an event arrives. -@table @var -@item event-count -Type @code{(or null integer)}. -@end table - -@end defun - -@defmac with-event-queue display &body body -@anchor{with-event-queue} - -@table @var -@item display -A @var{display}. -@item body -Forms to execute. -@end table - -Executes the @emph{body} in a critical region in which the executing -client process has exclusive access to the event queue. - -@end defmac - - - -@node Sending Events, Pointer Position, Managing the Event Queue, Events and Input -@section Sending Events - - -A client can send an event to a window. Clients selecting this window -event will receive it just like any other event sent by the X server. - -@defun send-event window event-key event-mask &rest event-slots &key :propagate-p :display &allow-other-keys - -@table @var -@item window -The destination @var{window} for the event. -@item event-key -An @var{event-key} defining the type of event to send. -@item event-mask -Specifies the event types that receiving clients must select. -@item event-slots -Keyword-value pairs that describe the contents of an event. -@item :propagate-p -If true, the event can be propagated to ancestors of the destination window. -@item :display -A @var{display}. -@end table - -Sends an event specified by the @emph{event-key} and -@emph{event-slots} to the given destination @emph{window}. Any -active grabs are ignored. The @emph{event-slots} passed depend on -the event type. The keyword symbols used for each event type are -event slot names defined by the @var{declare-event} macro and are -described in @ref{Declaring Event Types}. - -If the @emph{window} is @var{:pointer-window}, the destination -@emph{window} is replaced with the window containing the -pointer. If the @emph{window} is @var{:input-focus}, the -destination @emph{window} is replaced with the descendant of the -focus window that contains the pointer or (if no such descendant -exists) the focus window. The @var{:display} keyword is only -required if the @emph{window} is @var{:pointer-window} or -@var{:input-focus}. - -The @emph{event-key} must be one of the core events, or one of the -events defined by an extension, so the server can send the event -with the correct byte-order. The contents of the event are -otherwise unaltered and unchecked by the server, except that the -@var{send-event-p} event slot is set to true. - -If the @emph{event-mask} is @var{nil}, the event is sent to the -client that created the destination @emph{window} with an -@emph{event-mask} of 0; if that client no longer exists, no event -is sent. Otherwise, the event is sent to every client selecting -any of the event types specified by @emph{event-mask} on the -destination @emph{window}. - -If @var{:propagate-p} is true and no clients have selected any of -the event types in @emph{event-mask} on the destination -@emph{window}, the destination is replaced with the closest -ancestor of @emph{window} for which some client has selected a -type in @emph{event-mask} and no intervening window has that type -in its do-not-propagate mask. If no such window exists, or if the -@emph{window} is an ancestor of the focus window and -@var{:input-focus} was originally specified as the destination, -the event is not sent to any clients. Otherwise, the event is -reported to every client selecting on the final destination any of -the types specified in @emph{event-mask}. - - -@end defun - - -@node Pointer Position, Managing Input Focus, Sending Events, Events and Input -@section Pointer Position - - -The CLX functions affecting pointer position are discussed in the -following paragraphs. - -@defun query-pointer window - -@table @var -@item window -A @var{window} specifying the coordinate system for the returned position. -@end table - - -Returns the current pointer coordinates relative to the given -@emph{window}. If @var{query-pointer} returns @var{nil} for -@emph{same-screen-p}, the pointer is not on the same screen as the -@emph{window}. In this case, @var{query-pointer} returns a value -of @var{nil} for @emph{child} and a value of zero for @emph{x} -and @emph{y}. If @var{query-pointer} returns true for -@emph{same-screen-p}, the returned @emph{x} and @emph{y} are -relative to the origin of window. The @emph{child} is the child of -the window containing the pointer, if any. The @emph{state-mask} -returned gives the current state of the modifier keys and pointer -buttons. The returned @emph{root} is the root window currently -containing the pointer. The returned @emph{root-x} and -@emph{root-y} specify the pointer coordinates relative to -@emph{root}. -@table @var -@item x -Type @var{int16}. -@item y -Type @var{int16}. -@item same-screen-p -Type @var{boolean}. -@item child -Type @var{window} or @var{null}. -@item state-mask -Type @var{card16}. -@item root-x -Type @var{int16}. -@item root-y -Type @var{int16}. -@item root -Type @var{window}. -@end table - -@end defun - - -@defun global-pointer-position display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the @emph{root} window currently containing the @emph{display} pointer and the current -position of the pointer relative to the @emph{root}. -@table @var -@item root-x -Type @var{int16}. -@item root-y -Type @var{int16}. -@item root -Type @var{window}. -@end table - -@end defun - - -@defun pointer-position window - -@table @var -@item window -A @var{window} specifying the coordinate system for the returned position. -@end table - - -Returns the current pointer coordinates relative to the given -@emph{window}. If @var{pointer-position} returns @var{nil} for -@emph{same-screen-p}, the pointer is not on the same screen as the -@emph{window}. In this case, @var{pointer-position} returns a -value of @var{nil} for @emph{child} and a value of zero for -@emph{x} and @emph{y}. If @var{pointer-position} returns true for -@emph{same-screen-p}, the returned @emph{x} and @emph{y} are -relative to the origin of @emph{window}. -@table @var -@item x -Type @var{int16}. -@item y -Type @var{int16}. -@item same-screen-p -Type @var{boolean}. -@item child -Type @var{window} or @var{null}. -@end table - -@end defun - - -@defun motion-events window &key :start :stop (:result-type 'list) - -@table @var -@item window -The @var{window} containing the returned motion events. -@item :start -@itemx :stop -@var{timestamp} values for the time interval for returned motion events. -@item :result-type -The form of the returned motion events. -@end table - - -Many X server implementations maintain a more precise history of -pointer motion between event notifications. The pointer position -at each pointer hardware interrupt can be stored into a buffer for -later retrieval.This is called the @emph{motion history buffer}. A -paint program, for example, may want to have a precise history of -where the pointer traveled, even though for most other -applications this amount of detail is grossly excessive. - -The @var{motion-events} function returns all events in the motion -history buffer that fall between the specified @var{:start} and -@var{:stop} timestamps (inclusive) and have coordinates that lie -within the specified @emph{window} (including borders) at its -present placement. If the @var{:start} time is later than the -@var{:stop} time or if the @var{:start} time is in the future, -no events are returned. -@table @var -@item motion-events -Type @code{(repeat-seq (int16 x) (int16 y) (timestamp time))}. -@end table - -@end defun - - -@defun warp-pointer destination destination-x destination-y - -@table @var -@item destination -The @var{window} into which the pointer is moved. -@item destination-x -@itemx destination-y -The new position of the pointer relative to the destination. -@end table - -Moves the pointer to the given coordinates relative to the -@emph{destination} window. @var{warp-pointer} should be rarely be -used since the user should normally be in control of the pointer -position. @var{warp-pointer} generates events just as if the user -had instantaneously moved the pointer from one position to another. - -@var{warp-pointer} cannot move the pointer outside the confine-to -window of an active pointer grab; an attempt to do so only moves the -pointer as far as the closest edge of the confine-to window. - - -@end defun - - -@defun warp-pointer-relative display x-offset y-offset - -@table @var -@item display -A @var{display}. -@item x-offset -@itemx y-offset -The offsets used to adjust the pointer position. -@end table - -Moves the pointer by the given offsets. This function should rarely -be used since the user should normally be in control of the pointer -position. @var{warp-pointer-relative} generates events just as if -the user had instantaneously moved the pointer from one position to -another. - -@var{warp-pointer-relative} cannot move the pointer outside the -confine-to window of an active pointer grab; an attempt to do so -only moves the pointer as far as the closest edge of the confine-to -window. - - -@end defun - - -@defun warp-pointer-if-inside destination destination-x destination-y source source-x source-y &optional (source-width 0) (source-height 0) - -@table @var -@item destination -The @var{window} into which the pointer is moved. -@item destination-x -@itemx destination-y -The new position of the pointer relative to the @emph{destination}. -@item source -The @var{window} that must currently contain the pointer. -@item source-x -@itemx source-y -@itemx source-width -@itemx source-height -The source rectangle that must currently contain the pointer. -@end table - -Moves the pointer to the given position relative to the -@emph{destination} window. However, the move can only take place if -the pointer is currently contained in a visible portion of the -specified rectangle of the @emph{source} window. If -@emph{source-height} is zero, it is replaced with the current height -of @emph{source} window minus @emph{source-y}. If -@emph{source-width} is zero, it is replaced with the current width -of @emph{source} window minus @emph{source-x}. - -@var{warp-pointer-if-inside} generates events just as if the user -had instantaneously moved the pointer from one position to -another. @var{warp-pointer-if-inside} cannot move the pointer -outside the confine-to window of an active pointer grab; an attempt -to do so only moves the pointer as far as the closest edge of the -confine-to window. - - -@end defun - -@defun warp-pointer-relative-if-inside x-offset y-offset source source-x source-y &optional (source-width 0) (source-height 0) - -@table @var -@item x-offset -@itemx y-offset -The offsets used to adjust the pointer position. -@item source -The @var{window} that must currently contain the pointer. -@item source-x -@itemx source-y -@itemx source-width -@itemx source-height -The source rectangle that must currently contain the pointer. -@end table - -Moves the pointer by the given offsets. However, the move can only -take place if the pointer is currently contained in a visible -portion of the specified rectangle of the @emph{source} window. If -@emph{source-height} is zero, it is replaced with the current height -of @emph{source-window} minus @emph{source-y}. If -@emph{source-width} is zero, it is replaced with the current width -of @emph{source-window} minus @emph{source-x}. - -@var{warp-pointer-relative-if-inside} generates events just as if -the user had instantaneously moved the pointer from one position to -another. @var{warp-pointer-relative-if-inside} cannot move the -pointer outside the confine-to window of an active pointer grab; an -attempt to do so only moves the pointer as far as the closest edge -of the confine-to window. - - - -@end defun - - -@node Managing Input Focus, Grabbing the Pointer, Pointer Position, Events and Input -@section Managing Input Focus - - -CLX provides the @var{set-focus-input} and @var{focus-input} functions -to set and get the keyboard input focus window. - -@defun set-input-focus display focus revert-to &optional time - -@table @var -@item display -A @var{display}. -@item focus -The new input focus @var{window}. -@item revert-to -The focus @var{window} when focus is no longer viewable. -@item time -A @var{timestamp}. -@end table - -Changes the keyboard input focus and the last-focus-change -time. The function has no effect if the specified @emph{time} is -earlier than the current last-focus-change time or is later than -the current server time; otherwise, the last-focus-change time is -set to the specified @emph{time}. The @var{set-input-focus} -function causes the X server to generate @var{:focus-in} and -@var{:focus-out} events. - -If @var{:none} is specified as the @emph{focus}, all keyboard -events are discarded until a new focus window is set. In this -case, the @emph{revert-to} argument is ignored. - -If a window is specified as the @emph{focus} argument, it becomes -the keyboard's focus window. If a generated keyboard event would -normally be reported to this window or one of its inferiors, the -event is reported normally; otherwise, the event is reported with -respect to the focus window. - -If @var{:pointer-root} is specified as the @emph{focus} argument, -the input focus window is set to the root window of the screen -containing the pointer when each keyboard event occurs. In this -case, the @emph{revert-to} argument is ignored. - -The specified @emph{focus} window must be viewable at the time of -the request. If the @emph{focus} window later becomes not -viewable, the new focus window depends on the @emph{revert-to} -argument. If @emph{revert-to} is specified as @var{:parent}, the -@emph{focus} reverts to the parent (or the closest viewable -ancestor) and the new @emph{revert-to} value is take to be -@var{:none}. If @emph{revert-to} is @var{:pointer-root} or -@var{:none}, the @emph{focus} reverts to that value. When the -@emph{focus} reverts, @var{:focus-in} and @var{:focus-out} -events are generated, but the last-focus-change time is not -affected. - - -@end defun - - -@defun input-focus display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the @emph{focus} window, @var{:pointer-root}, or -@var{:none}, depending on the current state of the focus -window. @emph{revert-to} returns the current focus revert-to -state. -@table @var -@item focus -Type (@var{or window} (@var{member :none :pointer-root})). -@item revert-to -Type (@var{or window} (@var{member :none :pointer-root :parent})). -@end table - -@end defun - - -@node Grabbing the Pointer, Grabbing a Button, Managing Input Focus, Events and Input -@section Grabbing the Pointer - - -CLX provides the @var{grab-pointer} and @var{ungrab-pointer} functions -for grabbing and releasing pointer control. - -@defun grab-pointer window event-mask &key :owner-p :sync-pointer-p :sync-keyboard-p :confine-to :cursor :time - -@table @var -@item window -The @var{window} grabbing the pointer. -@item event-mask -A @var{pointer-event-mask}. -@item :owner-p -If true, all client windows receive pointer events normally. -@item :sync-pointer-p -Indicates whether the pointer is in synchronous or asynchronous mode. -@item :sync-keyboard-p -Indicates whether the keyboard is in synchronous or asynchronous mode. -@item :confine-to -A @var{window} to which the pointer is confined. -@item :cursor -A @var{cursor}. -@item :time -A @var{timestamp}. A @var{nil} value means the current server time is used. -@end table - - -Actively grabs control of the pointer. Further pointer events are -only reported to the grabbing client. The request overrides any -active pointer grab by this client. - -If @var{:owner-p} is @var{nil}, all generated pointer events are -reported with respect to @emph{window}, and are only reported if -selected by @emph{event-mask}. If @var{:owner-p} is true, and if a -generated pointer event would normally be reported to this client, -it is reported normally; otherwise the event is reported with -respect to the @emph{window}, and is only reported if selected by -@emph{event-mask}. For either value of @var{:owner-p}, unreported -events are simply discarded. - -If @var{:sync-pointer-p} is @var{nil}, pointer event processing -continues normally (asynchronously); if the pointer is currently -frozen by this client, then processing of pointer events is -resumed. If @var{:sync-pointer-p} is true (indicating a synchronous -action), the pointer (as seen via the protocol) appears to freeze, -and no further pointer events are generated by the server until the -grabbing client issues a releasing @var{allow-events} request. -Actual pointer changes are not lost while the pointer is frozen; -they are simply queued for later processing. - -If @var{:sync-keyboard-p} is @var{nil}, keyboard event processing -is unaffected by activation of the grab. If @var{:sync-keyboard-p} -is true, the keyboard (as seen via the protocol) appears to freeze, -and no further keyboard events are generated by the server until the -grabbing client issues a releasing @var{allow-events} -request. Actual keyboard changes are not lost while the keyboard is -frozen; they are simply queued for later processing. - -If @var{:cursor} is specified, it is displayed regardless of what -window the pointer is in. Otherwise, the normal cursor for the -@emph{window} is displayed. - -If a @var{:confine-to} window is specified, the pointer is -restricted to stay within that window. The @var{:confine-to} -window does not need to have any relationship to the -@emph{window}. If the pointer is not initially in the -@var{:confine-to} window, it is warped automatically to the closest -edge (with @var{:enter}/@var{:leave-events} generated normally) -just before the grab activates. If the @var{:confine-to} window is -subsequently reconfigured, the pointer is warped automatically as -necessary to keep it contained in the window. - -@var{grab-pointer} generates @var{:enter-notify} and -@var{:leave-notify} events. @var{grab-pointer} can fail with a -status of: -@itemize @bullet - -@item -@var{:already-grabbed} if the pointer is actively grabbed by some -other client - -@item -@var{:frozen} if the pointer is frozen by an active grab of -another client - -@item -@var{:not-viewable} if the @emph{window} or the -@var{:confine-to} window is not viewable, or if the -@var{:confine-to} window lies completely outside the boundaries -of the root window. - -@item -@var{:invalid-time} if the specified time is earlier than the -last-pointer-grab time or later than the current server -time. Otherwise, the last-pointer-grab time is set to the -specified time, with current-time replaced by the current server -time, and a value of @var{:success} is returned by -@var{grab-pointer}. -@end itemize -@table @var -@item grab-status -One of @var{:already-grabbed}, @var{:frozen}, @var{:invalid-time}, -@var{:not-viewable}, or @var{:success}. -@end table - -@end defun - - -@defun ungrab-pointer display &key :time - -@table @var -@item display -A @var{display}. -@item :time -A @var{timestamp}. -@end table - -Releases the pointer if this client has it actively grabbed (from -either @var{grab-pointer}, @var{grab-button}, or from a normal -button press), and releases any queued events. The request has no -effect if the specified @var{:time} is earlier than the -last-pointer-grab time or is later than the current server time. An -@var{ungrabpointer} is performed automatically if the event window -or @var{:confine-to} window for an active pointer grab becomes not -viewable. - -This request generates @var{:enter-notify} and @var{:leave-notify} -events. - - -@end defun - - -@defun change-active-pointer-grab display event-mask &optional cursor time - -@table @var -@item display -A @var{display}. -@item event-mask -A @var{pointer-event-mask}. -@item cursor -A @var{cursor} or @var{nil}. -@item time -A @var{timestamp}. -@end table - -Changes the specified dynamic parameters if the pointer is actively -grabbed by the client and the specified @emph{time} is no earlier -than the last-pointer-grab time and no later than the current server -time. The interpretation of @emph{event-mask} and @emph{cursor} are -as in @var{grab-pointer}. @var{change-active-pointer-grab} has no -effect on the passive parameters of a @var{grab-button}. - - -@end defun - - -@node Grabbing a Button, Grabbing the Keyboard, Grabbing the Pointer, Events and Input -@section Grabbing a Button - - -CLX provides the @var{grab-button} and @var{ungrab-button} functions -for passively grabbing and releasing pointer control. - -@defun grab-button window button event-mask &key (:modifiers 0) :owner-p :sync-pointer-p :sync-keyboard-p :confine-to :cursor - -@table @var -@item window -A @var{window}. -@item button -The button (type @var{card8}) pressed or @var{:any}. -@item event-mask -A @var{pointer-event-mask}. -@item :modifiers -A @var{modifier-mask}. -@item :owner-p -If true, all client windows receive pointer events normally. -@item :sync-pointer-p -Indicates whether the pointer is handled in a synchronous or asynchronous fashion. -@item :sync-keyboard-p -Indicates whether the keyboard is in synchronous or asynchronous mode. -@item :confine-to -A @var{window} to which the pointer is confined. -@item :cursor -A @var{cursor}. -@end table - -This request establishes a passive grab. If the specified -@emph{button} is pressed when the specified modifier keys are down -(and no other buttons or modifier keys are down), and: -@itemize @bullet - -@item @emph{window} contains the pointer - -@item The @var{:confine-to} window (if any) is viewable - -@item These constraints are not satisfied for any ancestor of @emph{window} -@end itemize - -then: -@itemize @bullet - -@item -The pointer is actively grabbed as described with -@var{grab-pointer} - -@item -The last-pointer-grab time is set to the time that the button was -pressed (as transmitted in the @var{:button-press} event) - -@item -The @var{:button-press} event is reported -@end itemize - -The interpretation of the remaining arguments is the same as with -@var{grab-pointer}. The active grab is terminated automatically -when all buttons are released (independent of the state of modifier -keys). - -A zero @emph{modifier} mask is equivalent to issuing the request for -all possible modifier-key combinations (including the combination of -no modifiers). It is not required that all specified modifiers have -currently assigned keycodes. A @emph{button} of @var{:any} is -equivalent to issuing the request for all possible -buttons. Otherwise, it is not required that the specified -@emph{button} currently be assigned to a physical button. - - -@end defun - - -@defun ungrab-button window button &key (:modifiers 0) - -@table @var -@item window -A @var{window}. -@item button -The button (type @var{card8}) that is released or @var{:any}. -@item :modifiers -A @var{modifier-mask}. -@end table - -Releases the passive button/key combination on the specified -@emph{window} if it was grabbed by this client. A zero -@emph{modifier} mask is equivalent to issuing the request for all -possible modifier combinations including the combination of no -modifiers. A @emph{button} of @var{:any} is equivalent to issuing -the request for all possible buttons. This has no effect on an -active grab. - - -@end defun - - -@node Grabbing the Keyboard, Grabbing a Key, Grabbing a Button, Events and Input -@section Grabbing the Keyboard - - -CLX provides the @var{grab-keyboard} and @var{ungrab-keyboard} -functions for actively grabbing and releasing control of the keyboard. - -@defun grab-keyboard window &key :owner-p :sync-pointer-p :sync-keyboard-p :time - -@table @var -@item window -A @var{window}. -@item :owner-p -If true, all client windows receive keyboard input normally. -@item :sync-pointer-p -Indicates whether the pointer is in synchronous or asynchronous mode. -@item :sync-keyboard-p -Indicates whether the keyboard is in synchronous or asynchronous mode. -@item :time -A @var{timestamp}. -@end table - - -Actively grabs control of the keyboard. Further key events are -reported only to the grabbing client. The request overrides any -active keyboard grab by this client. @var{grab-keyboard} generates -@var{:focus-in} and @var{:focus-out} events. - -If @var{:owner-p} is @var{nil}, all generated key events are -reported with respect to @emph{window}. If @var{:owner-p} is true, -then a generated key event that would normally be reported to this -client is reported normally; otherwise the event is reported with -respect to the @emph{window}. Both @var{:key-press} and -@var{:key-release} events are always reported, independent of any -event selection made by the client. - -If @var{:sync-keyboard-p} is @var{nil}, keyboard event processing -continues normally (asynchronously); if the keyboard is currently -frozen by this client, then processing of keyboard events is -resumed. If @var{:sync-keyboard-p} is true, the keyboard (as seen -via the protocol) appears to freeze, and no further keyboard events -are generated by the server until the grabbing client issues a -releasing @var{allow-events} request. Actual keyboard changes are -not lost while the keyboard is frozen; they are simply queued for -later processing. - -If @var{:sync-pointer-p} is @var{nil}, pointer event processing is -unaffected by activation of the grab. If @var{:sync-pointer-p} is -true, the pointer (as seen via the protocol) appears to freeze, and -no further pointer events are generated by the server until the -grabbing client issues a releasing @var{allow-events} -request. Actual pointer changes are not lost while the pointer is -frozen; they are simply queued for later processing. - -The grab can fail with a status of: -@itemize @bullet - -@item -@var{:already-grabbed} if the keyboard is actively grabbed by -some other client - -@item -@var{:frozen} if the keyboard is frozen by an active grab from -another client - -@item -@var{:not-viewable} if @emph{window} is not viewable - -@item -@var{:invalid-time} if the specified time is earlier than the -last-keyboard-grab time or later than the current server -time. Otherwise, @var{grab-keyboard} returns a status of -@var{:success} and last-keyboard-grab time is set to the -specified time, with current-time replaced by current server time. -@end itemize -@table @var -@item grab-status -One of @var{:already-grabbed}, @var{:frozen}, @var{:invalid-time}, -@var{:not-viewable}, or @var{:success}. -@end table - -@end defun - - -@defun ungrab-keyboard display &key :time - -@table @var -@item display -A @var{display}. -@item :time -A @var{timestamp}. -@end table - -Releases the keyboard if this client has it actively grabbed (from -either @var{grab-keyboard} or @var{grab-key}), and releases any -queued events. The request has no effect if the specified time is -earlier than the last-keyboard-grab time or is later than the -current server time. An @var{ungrab-keyboard} is performed -automatically if the event window for an active keyboard grab -becomes not viewable. - - -@end defun - - -@node Grabbing a Key, Event Types, Grabbing the Keyboard, Events and Input -@section Grabbing a Key - - -The following paragraphs describe the functions used for passively -grabbing and releasing the keyboard. - -@defun grab-key window key &key (:modifiers 0) :owner-p :sync-pointer-p :sync-keyboard-p :time - -@table @var -@item window -A @var{window}. -@item key -The key (type @var{card8}) to be grabbed or @var{:any}. -@item :modifiers -A @var{modifier-mask}. -@item :owner-p -If true, all client windows receive keyboard input normally. -@item :sync-pointer-p -Indicates whether the pointer is in synchronous or asynchronous mode. -@item :sync-keyboard-p -Indicates whether the keyboard is in synchronous or asynchronous mode. -@item :time -A @var{timestamp}. -@end table - -This request establishes a passive grab on the keyboard. If the -specified @emph{key} (which can also be a modifier key) is pressed -(whether or not any specified modifier keys are down), and either of -the following is true: -@itemize @bullet - -@item -@emph{window} is an ancestor of (or is) the focus window - -@item -@emph{window} is a descendant of the focus window and contains the -pointer - -@item -These constraints are not satisfied for any ancestor of -@emph{window}, then the following occurs: -@itemize @bullet - -@item -The keyboard is actively grabbed as described in -@var{grab-keyboard} - -@item -The last-keyboard-grab time is set to the time that the -@emph{key} was pressed (as transmitted in the -@var{:key-press} event) - -@item -The @var{:key-press} event is reported -@end itemize -@end itemize -The interpretation of the remaining arguments is as for -@var{grab-keyboard}. The active grab is terminated automatically when -the specified @emph{key} has been released, independent of the state -of the modifier keys. - -A zero modifier mask is equivalent to issuing the request for all -possible modifier combinations (including the combination of no -modifiers). It is not required that all specified modifiers have -currently assigned keycodes. A @emph{key} of @var{:any} is -equivalent to issuing the request for all possible -keycodes. Otherwise, the @emph{key} must be in the range specified -by @var{display-min-keycode} and @var{display-max-keycode} in the -connection setup. - - -@end defun - - -@defun ungrab-key window key &key (:modifiers 0) - -@table @var -@item window -A @var{window}. -@item key -The key (type @var{card8}) to be released or @var{:any}. -@item :modifiers -A @var{modifier-mask}. -@end table - -Releases the @emph{key} combination on the specified @emph{window} -if it was grabbed by this client. A zero modifier mask of -@var{:any} is equivalent to issuing the request for all possible -modifier combinations (including the combination of no modifiers). A -@emph{key} of @var{:any} is equivalent to issuing the request for -all possible keycodes. @var{ungrab-key} has no effect on an active -grab. - - -@end defun - - -@node Event Types, Releasing Queued Events, Grabbing a Key, Events and Input -@section Event Types - - -The following paragraphs contain detailed descriptions of the contents -of each event type. In CLX, events are not actually represented by -structures, but rather by lists of keyword values passed to handler -functions or by values bound to symbols within the clauses of -@var{event-case} and @var{event-cond} forms. Nevertheless, it is -convenient to describe event contents in terms of slots and to -identify the components of events with slot name symbols. In fact, CLX -uses the @var{declare-event} macro to define event slot symbols and to -map these symbols to specific event data items returned by the X -server (@pxref{Declaring Event Types}). - -The following paragraphs describe each event type, listing its -@var{event-key} keyword symbol and its slot name symbols. An event -keyword symbol identifies a specific event type. An event keyword -symbol can be given as an argument to @var{send-event} or to an event -handler function; it can also appear in the @emph{event-match} form of -an @var{event-case} clause. An event slot name symbol identifies a -specific event data item. Event slot names appear as keywords with -associated values among the arguments passed to @var{send-event} or to -an event handler function; as non-keyword symbols, they can also be in -the @emph{event-slots} form of an @var{event-case} clause. - -In certain cases, more than one name symbol is defined for the same -event slot. For example, in @var{:key-press} events, the symbols -@emph{window} and @emph{event-window} both refer to the same event data -item. - -@menu -* Keyboard and Pointer Events:: -* Input Focus Events:: -* Keyboard and Pointer State Events:: -* Exposure Events:: -* Window State Events:: -* Structure Control Events:: -* Client Communications Events:: -* Declaring Event Types:: -@end menu - -@node Keyboard and Pointer Events, Input Focus Events, Event Types, Event Types -@subsection Keyboard and Pointer Events - - -The keyboard and pointer events are: @var{:key-press} @var{:key-release}, -@var{:button-press}, @var{:button-release}, @var{:motion-notify}, -@var{:enter-notify}, and @var{:leave-notify}. - -@deftp {Event Type} :key-press -@deftpx {Event Type} :key-release -@deftpx {Event Type} :button-press -@deftpx {Event Type} :button-release - -Selected by @var{:key-press}, @var{:key-release}, @var{:button-press}, -or @var{:button-release}. - -@var{:key-press}, and @var{:key-release} events are generated when -a key or pointer button changes state. Note that @var{:key-press} -and @var{:key-release} are generated for all keys, even those -mapped to modifiers. All of these event types have the same -slots. The window containing the pointer at the time of the event is -referred to as the @emph{source} window. The @emph{event} -@emph{window} is the window to which the event is actually -reported. The event window is found by starting with the source -window and looking up the hierarchy for the first window on which -any client has selected interest in the event (provided no -intervening window prohibits event generation by including the event -type in its do-not-propagate-mask). The actual window used for -reporting can be modified by active grabs and, in the case of -keyboard events, can be modified by the focus window. - -A @var{:button-press} event has the effect of a temporary -@var{grab-button}. When a pointer button is pressed and no active -pointer grab is in progress, the ancestors of the source window are -searched from the @emph{root} down, looking for a passive grab to -activate. If no matching passive grab on the button exists, then an -active grab is started automatically for the client receiving the -@var{:button-press} event, and the last-pointer-grab time is set to -the current server time. The effect is essentially equivalent to -calling @var{grab-button} with the following arguments: - -@table @var -@item @emph{window} -The event window. -@item @emph{button} -The button that was pressed. -@item @emph{event-mask} -The client's selected pointer events on the event window. -@item @var{:modifiers} -0 -@item @var{:owner-p} -@var{t} if the client has @var{:owner-grab-button} selected on the event window; otherwise @var{nil}. -@item @var{:sync-pointer-p} -@var{nil} -@item @var{:sync-keyboard-p} -@var{nil} -@item @var{:confine-to} -@var{nil} -@item @var{:cursor} -@var{nil} -@end table - - -The @var{:button-press} grab is terminated automatically when all -buttons are released. The functions @var{ungrab-pointer} and -@var{change-active-pointer-grab} can both be used to modify the -@var{:button-press} grab. - -@table @var -@item window -@item event-window -Type @var{window}. - -The window receiving the event. - -@item code -Type @var{card8}. - -The @emph{code} argument varies with the event type. For @var{:key-press} and -@var{:key-release}, @emph{code} is the keycode (@pxref{Keyboard Encodings}). For -@var{:button-press} and @var{:button-release}, @emph{code} is the pointer button number. - -@item x -Type @var{int16}. - -If @emph{event-window} is on the same screen as root, then @emph{x} and @emph{y} are the pointer -coordinates relative to the @emph{event-window}; otherwise @emph{x} and @emph{y} are zero. - -@item y -Type @var{int16}. - -If @emph{event-window} is on the same screen as root, then @emph{x} and @emph{y} are the pointer -coordinates relative to the @emph{event-window}; otherwise @emph{x} and @emph{y} are zero. - -@item state -Type @var{card16}. - -A mask that gives the state of the buttons and modifier keys just before the -event. - -@item time -Type @var{card32}. - -A timestamp for the moment when the event occurred. - -@item root -Type @var{window}. - -The root window of the source window. - -@item root-x -Type @var{int16}. - -The x coordinate of the pointer position relative to root at the time of the event. - -@item root-y -Type @var{int16}. - -The y coordinate of the pointer position relative to root at the time of the event@emph{.} - -@item child -Type (@var{or null window}). - -If the source window is an inferior of the @emph{event-window}, @emph{child} is set to the child -of @emph{event-window} that is an ancestor of (or is) the source window; otherwise, it is -set to @var{nil}@emph{.} - -@item same-screen-p -Type @var{boolean}. - -True if @emph{event-window} and root are on the same screen. -@end table - -@end deftp - - -@deftp {Event Type} :motion-notify - -Selected by: @var{:button-1-motion}, @var{:button-2-motion}, -@var{:button-3-motion}, @var{:button-4-motion}, -@var{:button-5-motion}, @var{:button-motion}, or -@var{:pointer-motion}. - - -The @var{:motion-notify} event is generated when the pointer -moves. A @var{:motion-notify} event has the same slots as -@var{:button-press} @var{:button-release}, @var{:key-press}, and -@var{:key-release} events, with the exception that the @emph{code} -slot is replaced by the @emph{hint-p} slot. As with these other -events, the event window for @var{:motion-notify} is found by -starting with the source window and looking up the hierarchy for the -first window on which any client has selected interest in the event -(provided no intervening window prohibits event generation by -including @var{:motion-notify} in its do-not-propagate-mask).The -actual window used for reporting can be modified by active grabs. - -@var{:motion-notify} events are generated only when the motion -begins and ends in the window. The granularity of motion events is -not guaranteed, but a client selecting for motion events is -guaranteed to get at least one event when the pointer moves and -comes to rest. Selecting @var{:pointer-motion} generates -@var{:motion-notify} events regardless of the state of the pointer -buttons. By selecting some subset of @var{:button[1-5]-motion} -instead, @var{:motion-notify} events are only received when one or -more of the specified buttons are pressed. By selecting -@var{:button-motion}, @var{:motion-notify} events are only -received when at least one button is pressed. If -@var{:pointer-motion-hint} is also selected, the server is free to -send only one @var{:motion-notify}, until either the key or button -state changes, the pointer leaves the event window, or the client -calls @var{query-pointer} or @var{motion-events}. - -@table @var -@item hint-p -Type @var{boolean}. - -True if the event is a hint generated by selecting @var{:pointer-motion-hint}. -@end table - -@end deftp - - - -@deftp {Event Type} :enter-notify -@deftpx {Event Type} :leave-notify -@anchor{:enter-notify} - -Selected by: @var{:enter-window} or @var{:leave-window}. - -If pointer motion or a window hierarchy change causes the pointer to -be in a different window than before, @var{:enter-notify} and -@var{:leave-notify} events are generated instead of a -@var{:motion-notify} event. All @var{:enter-notify} and -@var{:leave-notify} events caused by a hierarchy change are -generated after any hierarchy event (@var{:unmap-notify}, -@var{:map-notify}, @var{:configure-notify}, -@var{:gravity-notify}, or @var{:circulate-notify}) caused by that -change, but the ordering of @var{:enter-notify} and -@var{:leave-notify} events with respect to @var{:focus-out}, -@var{:visibility-notify}, and @var{:exposure} events is not -constrained by the X protocol. An @var{:enter-notify} or -@var{:leave-notify} event can also be generated when a client -application calls @var{change-active-pointer-grab}, -@var{grab-pointer}, or @var{ungrab-pointer}. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving the event. - -@item x -Type @var{int16}. - -The final pointer position. If @emph{event-window} is on the same screen as root, then @emph{x} -and @emph{y} are the pointer coordinates relative to the @emph{event-window}; otherwise @emph{x} and -@emph{y} are zero. - -@item y -Type @var{int16}. - -The final pointer position. If @emph{event-window} is on the same screen as root, then @emph{x} -and @emph{y} are the pointer coordinates relative to the @emph{event-window}; otherwise @emph{x} and -@emph{y} are zero. - -@item mode -Type (@var{member :normal :grab :ungrab}). - -Events caused when the pointer is actively grabbed have mode @var{:grab}. Events -caused when an active pointer grab deactivates have mode @var{:ungrab}. In all -other cases, mode is @var{:normal}. - -@item kind -Type (@var{member :ancestor :virtual :inferior :nonlinear} @var{:nonlinear-virtual}). - -When the pointer moves from window A to window B, and A is an inferior of -B: -@itemize @bullet - -@item -@var{:leave-notify} with @emph{kind} @var{:ancestor} is generated on A - -@item -@var{:leave-notify} with @emph{kind} @var{:virtual} is generated on each window between A -and B exclusive (in that order) - -@item -@var{:enter-notify} with @emph{kind} @var{:inferior} is generated on B -@end itemize - -When the pointer moves from window A to window B, and -B is an inferior of A: -@itemize @bullet - -@item -@var{:leave-notify} with @emph{kind} @var{:inferior} is generated on A - -@item -@var{:enter-notify} with @emph{kind} -@var{:virtual} is generated on each window between -A and B exclusive (in that order) - -@item -@var{:enter-notify} with @emph{kind} @var{:ancestor} is generated on B -@end itemize - -When the pointer moves from window A to window B, with -window C being their least common ancestor: -@itemize @bullet - -@item -@var{:leave-notify} with @emph{kind} @var{:nonlinear} is generated on A - -@item -@var{:leave-notify} with @emph{kind} -@var{:nonlinear-virtual} is generated on each -window between A and C exclusive (in that order) - -@item -@var{:enter-notify} with @emph{kind} -@var{:nonlinear-virtual} is generated on each -window between C and B exclusive (in that order) - -@item -@var{:enter-notify} with @emph{kind} -@var{:nonlinear} is generated on B -@end itemize - -When the pointer moves from window A to window B, on different screens: -@itemize @bullet - -@item -@var{:leave-notify} with @emph{kind} @var{:nonlinear} is generated on A - -@item -If A is not a root window, @var{:leave-notify} with @emph{kind} @var{:nonlinear-virtual} is -generated on each window above A up to and including its root (in order) - -@item -If B is not a root window, @var{:enter-notify} with -@emph{kind} @var{:nonlinear-virtual} is generated -on each window from B's root down to but not -including B (in order) - -@item -@var{:enter-notify} with @emph{kind} @var{:nonlinear} is generated on B -@end itemize - -When a pointer grab activates (but after any initial warp into a -confine-to window, and before generating any actual -@var{:button-press} event that activates the grab), with -@emph{G} the @var{grab-window} for the grab and @emph{P} the -window the pointer is in, then @var{:enter-notify} and -@var{:leave-notify} events with mode @var{:grab} are generated -(as for @var{:normal} above) as if the pointer were to suddenly -warp from its current position in @emph{P} to some position in -@emph{G}. However, the pointer does not warp, and the pointer -position is used as both the @emph{initial} and @emph{final} -positions for the events. - -When a pointer grab deactivates (but after generating any actual -@var{:button-release} event that deactivates the grab), with -@emph{G} the @var{grab-window} for the grab and @emph{P} the -window the pointer is in, then @var{:enter-notify} and -@var{:leave-notify} events with mode @var{:ungrab} are -generated (as for @var{:normal} above) as if the pointer were -to suddenly warp from from some position in @emph{G} to its -current position in @emph{P}. However, the pointer does not -warp, and the current pointer position is used as both the -@emph{initial} and @emph{final} positions for the events. - -@item focus-p -Type @var{boolean}. - -If @emph{event-window} is the focus window or an inferior of the focus window, then -@emph{focus-p} is @var{t}; otherwise, @emph{focus-p} is @var{nil}. - -@item state -Type @var{card16}. - -A mask that gives the state of the buttons and modifier keys just before the -event. - -@item time -Type @var{card32}. - -A timestamp for the moment when the event occurred. - -@item root -Type @var{window}. - -The root window containing the final pointer position. - -@item root-x -Type @var{int16}. - -The x coordinate of the pointer position relative to root at the time of the event. - -@item root-y -Type @var{int16}. - -The y coordinate of the pointer position relative to root at the time of the event. - -@item child -Type (@var{or null window}). - -In a @var{:leave-notify} event, if a child of the @emph{event-window} contains the initial -position of the pointer, the @emph{child} slot is set to that child; otherwise, the @emph{child} slot is -@var{nil}. For an @var{:enter-notify} event, if a child of the @emph{event-window} contains the final -pointer position, the @emph{child} slot is set to that child; otherwise, the @emph{child} slot is @var{nil}. - -@item same-screen-p -Type @var{boolean}. - -True if @emph{event-window} and root are on the same screen. -@end table - -@end deftp - - -@node Input Focus Events, Keyboard and Pointer State Events, Keyboard and Pointer Events, Event Types -@subsection Input Focus Events - - -The input focus events are @var{:focus-in} and @var{:focus-out}. - -@deftp {Event Type} :focus-in -@deftpx {Event Type} :focus-out - -Selected by: @var{:focus-change}. - -@var{:focus-in} and @var{:focus-out} events are generated when the -input focus changes. All @var{:focus-out} events caused by a window -@var{:unmap} are generated after any @var{:unmap-notify} event, -but the ordering of @var{:focus-out} with respect to generated -@var{:enter-notify}, @var{:leave-notify}, -@var{:visibility-notify}, and @var{:expose} events is not -constrained. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -For @var{:focus-in}, the new input focus window. For @var{:focus-out}, the previous input -focus window. - -@item mode -Type @code{(member :normal :while-grabbed :grab :ungrab)}. - -Events generated by @var{set-input-focus} when the keyboard is not grabbed have -mode @var{:normal}. Events generated by @var{set-input-focus} when the keyboard is -grabbed have mode @var{:while-grabbed}. Events generated when a keyboard grab -activates have mode @var{:grab}, and events generated when a keyboard grab -deactivates have mode @var{:ungrab}. - -@item kind -Type (@var{member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual :pointer :pointer-root :none}). - -When the focus moves from window A to window B, and A is an inferior of B, -with the pointer in window P: -@itemize @bullet - -@item -@var{:focus-out} with @emph{kind} @var{:ancestor} is -generated on A - -@item -@var{:focus-out} with @emph{kind} @var{:virtual} is -generated on each window between A and B exclusive (in that -order) - -@item -@var{:focus-in} with @emph{kind} @var{:inferior} is -generated on B - -@item -If P is an inferior of B, but P is not A or an inferior of -A or an ancestor of A, @var{:focus-in} with @emph{kind} -@var{:pointer} is generated on each window below B down -to and including P (in order) -@end itemize - -When the focus moves from window A to window B, and B is an inferior of A, -with the pointer in window P: -@itemize @bullet - -@item -If P is an inferior of A, but P is not A or an inferior of -B or an ancestor of B, @var{:focus-out} with @emph{kind} -@var{:pointer} is generated on each window from P up to -but not including A (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:inferior} is -generated on A - -@item -@var{:focus-in} with @emph{kind} @var{:virtual} is -generated on each window between A and B exclusive (in -that order) - -@item -@var{:focus-in} with @emph{kind} @var{:ancestor} is -generated on B -@end itemize - -When the focus moves from window A to window B, with window C being -their least common ancestor, and with the pointer in window P: -@itemize @bullet - -@item -If P is an inferior of A, @var{:focus-out} with -@emph{kind} @var{:pointer} is generated on each window -from P up to but not including A (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:nonlinear} is -generated on A - -@item -@var{:focus-out} with @emph{kind} -@var{:nonlinear-virtual} is generated on each window -between A and C exclusive (in that order) - -@item -@var{:focus-in} with @emph{kind} -@var{:nonlinear-virtual} is generated on each window -between C and B exclusive (in that order) - -@item -:focus-in with @emph{kind} @var{:nonlinear} is generated -on B - -@item -If P is an inferior of B, @var{:focus-in} with -@emph{kind} @var{:pointer} is generated on each window -below B down to and including P (in order) -@end itemize - -When the focus moves from window A to window B, on different -screens, with the pointer in window P: -@itemize @bullet - -@item -If P is an inferior of A, @var{:focus-out} with -@emph{kind} @var{:pointer} is generated on each window -from P up to but not including A (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:nonlinear} is -generated on A - -@item -If A is not a root window, @var{:focus-out} with -@emph{kind} @var{:nonlinear-virtual} is generated on each -window above A up to and including its root (in order) - -@item -If B is not a root window, @var{:focus-in} with -@emph{kind} @var{:nonlinear-virtual} is generated on each -window from B's root down to but not including B (in -order) - -@item -@var{:focus-in} with @emph{kind} @var{:nonlinear} is -generated on B - -@item -If P is an inferior of B, @var{:focus-in} with -@emph{kind} @var{:pointer} is generated on each window -below B down to and including P (in order) -@end itemize - -When the focus moves from window A to @var{:pointer-root} -(or @var{:none}), with the pointer in window P: -@itemize @bullet - -@item -If P is an inferior of A, @var{:focus-out} with -@emph{kind} @var{:pointer} is generated on each window -from P up to but not including A (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:nonlinear} is -generated on A - -@item -If A is not a root window, @var{:focus-out} with -@emph{kind} @var{:nonlinear-virtual} is generated on each -window above A up to and including its root (in order) - -@item -@var{:focus-in} with @emph{kind} @var{:pointer-root} (or -@var{:none}) is generated on all root windows - -@item -If the new focus is @var{:pointer-root}, @var{:focus-in} -with @emph{kind} @var{:pointer} is generated on each -window from P's root down to and including P (in order) -@end itemize - -When the focus moves from @var{:pointer-root} (or -@var{:none}) to window A, with the pointer in window P: -@itemize @bullet - -@item -If the old focus is @var{:pointer-root}, -@var{:focus-out} with @emph{kind} @var{:pointer} is -generated on each window from P up to and including P's -root (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:pointer-root} -(or @var{:none}) is generated on all root windows - -@item -If A is not a root window, @var{:focus-in} with -@emph{kind} @var{:nonlinear-virtual} is generated on each -window from A's root down to but not including A (in -order) - -@item -@var{:focus-in} with @emph{kind} @var{:nonlinear} is -generated on A - -@item -If P is an inferior of A, @var{:focus-in} with -@emph{kind} @var{:pointer} is generated on each window -below A down to and including P (in order) -@end itemize - -When the focus moves from @var{:pointer-root} to -@var{:none} (or vice versa), with the pointer in window P: -@itemize @bullet - -@item -If the old focus is @var{:pointer-root}, -@var{:focus-out} with @emph{kind} @var{:pointer} is -generated on each window from P up to and including P's -root (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:pointer-root} -(or @var{:none}) is generated on all root windows - -@item -@var{:focus-in} with @emph{kind} @var{:none} (or -@var{:pointer-root}) is generated on all root windows - -@item -If the new focus is @var{:pointer-root}, @var{:focus-in} -with @emph{kind} @var{:pointer} is generated on each -window from P's root down to and including P (in order) -@end itemize -@end table - - -When a keyboard grab activates (but before generating any actual -@var{:key-press} event that activates the grab), with @emph{G} -the @var{grab-window} for the grab and @emph{F} the current -focus, then @var{:focus-in} and @var{:focus-out} events with -mode @var{:grab} are generated (as for @var{:normal} above) as -if the focus were to change from @emph{F} to @emph{G}. - -When a keyboard grab deactivates (but after generating any -actual @var{:key-release} event that deactivates the grab), -with @emph{G} the @var{grab-window} for the grab and @emph{F} -the current focus, then @var{:focus-in} and @var{:focus-out} -events with mode @var{:ungrab} are generated (as for -@var{:normal} above) as if the focus were to change from -@emph{G} to @emph{F}. -@end deftp - -@node Keyboard and Pointer State Events, Exposure Events, Input Focus Events, Event Types -@subsection Keyboard and Pointer State Events - - -The keyboard and pointer state events are @var{:keymap-notify} and @var{:mapping-notify}. - -@deftp {Event Type} :keymap-notify - - -Selected by: @var{:keymap-state}. - -The @var{:keymap-notify} event returns the current state of the -keyboard. @var{:keymap-notify} is generated immediately after every -@var{:enter-notify} and @var{:focus-in}. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving an @var{:enter-notify} or @var{:focus-in} event. - -@item keymap -Type (@var{bit-vector 256}). - -A bit-vector containing the logical state of the keyboard. Each bit set to 1 -indicates that the corresponding key is currently pressed. The vector is represented -as 32 bytes. For @emph{n} from 0 to 7, byte @emph{n} (from 0) contains the bits for keys 8@emph{n} to -8@emph{n}+7, with the least significant bit in the byte representing key 8@emph{n}. -@end table - -@end deftp - - -@deftp {Event Type} :mapping-notify - -The X server reports @var{:mapping-notify} events to all -clients. There is no mechanism to express disinterest in this -event. The X server generates this event type whenever a client -application calls one of the following: -@itemize @bullet - -@item -@var{set-modifier-mapping} to indicate which keycodes to use as -modifiers (the status reply must be @var{:mapping-success}) - -@item -@var{change-keyboard-mapping} to change the keyboard mapping - -@item -@var{set-pointer-mapping} to set the pointer mapping (the status -reply must be @var{:mapping-success}) -@end itemize - -@table @var -@item request -Type (@code{member :modifier :keyboard :pointer}). - -Indicates the kind of change that occurred--@var{:modifier} for a successful -@var{set-modifier-mapping}, @var{:keyboard} for a successful @var{change-keyboard-mapping}, -and @var{:pointer} for a successful @var{set-pointer-mapping}. - -@item start -Type @var{card8}. - -If request is @var{:keyboard}, then @emph{start} and @emph{count} indicate the range of altered -keycodes. - -@item count -Type @var{card8}. - -If request is @var{:keyboard}, then @emph{start} and @emph{count} indicate the range of altered -keycodes. -@end table -@end deftp - - -@node Exposure Events, Window State Events, Keyboard and Pointer State Events, Event Types -@subsection Exposure Events - - -The X server cannot guarantee that a window's content is preserved when -the window is obscured or reconfigured. X requires client applications -to be capable of restoring the contents of a previously-invisible window -region whenever it is exposed. Therefore, the X server sends events -describing the exposed window and its exposed region. For a simple -window, a client can choose to redraw the entire content whenever any -region is exposed. For a complex window, a client can redraw only the -exposed region. - -@deftp {Event Type} :exposure -@anchor{:exposure} - -Selected by: @var{:exposure}. - -An @var{:exposure} event is sent when redisplay is needed for a -window region whose content has been lost. Redisplay is needed -when one of the following occurs: -@itemize @bullet - -@item -A region is exposed for a window and the X server has no backing -store for the region - -@item -A region of a viewable window is obscured and the X server -begins to honor the window's backing-store attribute of -@var{:always} or @var{:when-mapped} - -@item -The X server begins to honor an unviewable window's -backing-store attribute of @var{:always} or -@var{:when-mapped}. -@end itemize - -The regions needing redisplay are decomposed into an arbitrary set -of rectangles, and an @var{:exposure} event is generated for each -rectangle. For a given action causing @var{:exposure} events, the -set of events for a given window are guaranteed to be reported -contiguously. - -@var{:exposure} events are never generated for @var{:input-only} -windows. - -All @var{:exposure} events caused by a hierarchy change are -generated after any hierarchy event (@var{:unmap-notify}, -@var{:map-notify}, -@var{:configure-notify},@var{:gravity-notify}, or -@var{:circulate-notify}) caused by that change. All -@var{:exposure} events on a given window are generated after any -@var{:visibility-notify} event on that window, but it is not -required that all @var{:exposure} events on all windows be -generated after all visibility events on all windows. The ordering -of @var{:exposure} events with respect to @var{:focus-out}, -@var{:enter-notify}, and @var{:leave-notify} events is not -constrained. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window needing redisplay. - -@item x -Type @var{card16}. - -The position of the left edge of the region to redisplay, relative to the -@emph{event-window}. - -@item y -Type @var{card16}. - -The position of the top edge of the region to redisplay, relative to the -@emph{event-window}. - -@item width -Type @var{card16}. - -The width of the region to redisplay. - -@item height -Type @var{card16}. - -The height of the region to redisplay. - -@item count -Type @var{card16}. - -If count is zero, then no more @var{:exposure} events for this window follow. If -count is nonzero, then at least that many more @var{:exposure} events for this -window follow (and possibly more). -@end table - -@end deftp - - -@deftp {Event Type} :graphics-exposure - -A @var{:graphics-exposure} event is generated by a call to -@var{copy-area} or @var{copy-plane} when the exposures attribute -of the graphics context is @var{:on}. A @var{:graphics-exposure} -event reports a destination region whose content cannot be computed -because the content of the corresponding source region has been -lost. For example, the missing source region may be obscured or may -lie outside the current source drawable size. For a given action -causing @var{:graphics-exposure} events, the set of events for a -given destination are guaranteed to be reported contiguously. - -@table @var -@item drawable -@itemx event-window -Type @var{drawable}. - -The destination drawable for the @var{copy-area} or @var{copy-plane} function. - -@item x -Type @var{card16}. - -The position of the left edge of the destination region, relative to the @emph{drawable}. - -@item y -Type @var{card16}. - -The position of the top edge of the destination region, relative to the @emph{drawable}. - -@item width -Type @var{card16}. - -The width of the destination region. - -@item height -Type @var{card16}. - -The height of the destination region. - -@item count -Type @var{card16}. - -If count is zero then no more @var{:graphics-exposure} events for the @emph{drawable} -follow. If count is nonzero then at least that many more @var{:graphics-exposure} -events for the @emph{drawable} follow (and possibly more). - -@item major -Type @var{card8}. - -The major opcode for the graphics request generating the event -(62 for @var{copy-area}, 63 for @var{copy-plane}). - -@item minor -Type @var{card16}. - -The minor opcode for the graphics request generating the event -(0 for both @var{copy-area} and @var{copy-plane}). -@end table - -@end deftp - - -@deftp {Event Type} :no-exposure - -A @var{:no-exposure} event is generated by a call to -@var{copy-area} or @var{copy-plane} when the exposures attribute -of the graphics context is @var{:on}. If no -@var{:graphics-exposure} events are generated, then a single -@var{:no-exposure} event is sent. - -@table @var -@item drawable -@itemx event-window -Type @var{drawable}. - -The destination drawable for the @var{copy-area} or @var{copy-plane} function. - -@item major -Type @var{card8}. - -The major opcode for the graphics request generating the event -(62 for @var{copy-area}, 63 for @var{copy-plane}). - -@item minor -Type @var{card16}. - -The minor opcode for the graphics request generating the event -(0 for both @var{copy-area} and @var{copy-plane}). -@end table - -@end deftp - - -@node Window State Events, Structure Control Events, Exposure Events, Event Types -@subsection Window State Events - - -The following paragraphs describe the events that can be received when a -window becomes: -@itemize @bullet - -@item Created - -@item Destroyed - -@item Invisible - -@item Mapped - -@item Moved - -@item Reparented - -@item Resized - -@item Restacked - -@item Unmapped - -@item Visible -@end itemize - -@deftp {Event Type} :circulate-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -A @var{:circulate-notify} event is generated whenever a window is -actually restacked as a result of a client application calling -@var{circulate-window-up} or @var{circulate-window-down}. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was restacked. - -@item place -Type (@var{member :top :bottom}). - -If place is @var{:top}, the @emph{window} is now on top of all siblings. Otherwise, it is below -all siblings. -@end table - -@end deftp - - -@deftp {Event Type} :configure-notify - -Selected by: @var{:structure-notify} on a window or -@var{:substructure-notify} on its parent. - - -The @var{:configure-notify} event is generated when the position or -size of a window actually changes as a result of a client -application setting its @emph{x}, @emph{y}, @emph{width}, -@emph{height}, or @emph{border-width} attributes. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was moved or resized. - -@item x -Type @var{int16}. - -@emph{x} and @emph{y} specify the new upper-left corner position of the @emph{window} relative to its -parent. - -@item y -Type @var{int16}. - -@emph{x} and @emph{y} specify the new upper-left corner position of the @emph{window} relative to its -parent. - -@item width -Type @var{card16}. - -@emph{width} and @emph{height} specify the new size of the @emph{window} interior. - -@item height -Type @var{card16}. - -@emph{width} and @emph{height} specify the new size of the @emph{window} interior. - -@item border-width -Type @var{card16}. - -The new @emph{window} border width. - -@item above-sibling -Type (@var{or null window}). - -The sibling immediately below the @emph{window}. If above-sibling is @var{nil}, then the -@emph{window} is below all of its siblings. - -@item override-redirect-p -Type @var{boolean}. - -@emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is -@var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. -@end table - - -The X server can report @var{:create-notify} events to clients -wanting information about creation of windows. The X server -generates this event whenever a client application creates a window -by calling @var{create-window}. - -To receive this event type in a client application, you @code{setf} -the @var{:substructure-notify} as the event-mask in the parent -window's event-mask slot. - -@end deftp - - -@deftp {Event Type} :create-notify - -Selected by: @var{:substructure-notify}. - - -The @var{:create-notify} event is generated when a @emph{window} is -created and is sent to the @emph{parent} window. - -@table @var -@item parent -@itemx event-window -Type @var{window}. - -The parent window receiving the event. - -@item window -Type @var{window}. - -The new window created. - -@item x -Type @var{int16}. - -@emph{x} and @emph{y} specify the initial upper-left corner position of the @emph{window} relative to -the parent. - -@item y -Type @var{int16}. - -@emph{x} and @emph{y} specify the initial upper-left corner position of the @emph{window} relative to -the parent. - -@item width -Type @var{card16}. - -@emph{width} and @emph{height} specify the initial size of the @emph{window} interior. - -@item height -Type @var{card16}. - -@emph{width} and @emph{height} specify the initial size of the @emph{window} interior. - -@item border-width -Type @var{card16}. - -The initial @emph{window} border width. - -@item override-redirect-p -Type @var{boolean}. - -@emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is -@var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. - -@end table - -@end deftp - - -@deftp {Event Type} :destroy-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -The @var{:destroy-notify} event is generated when a @emph{window} -is destroyed. The ordering of the @var{:destroy-notify} events is -such that for any given window, @var{:destroy-notify} is generated -on all inferiors of a window before @var{:destroy-notify} is -generated on the @emph{window}. The ordering among siblings and -across subhierarchies is not otherwise constrained. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was destroyed. -@end table - -@end deftp - - -@deftp {Event Type} :gravity-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -The X server can report @var{:gravity-notify} events to clients -wanting information about when a @emph{window} is moved because of a -change in the size of its parent. The X server generates this event -whenever a client application actually moves a child window as a -result of resizing its parent by calling @var{with-state} with the -appropriate arguments set. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was moved. - -@item x -Type @var{int16}. - -x and y specify the new upper-left corner position of the @emph{window} relative to its -parent. - -@item y -Type @var{int16}. - -x and y specify the new upper-left corner position of the @emph{window} relative to its -parent. -@end table - -@end deftp - - -@deftp {Event Type} :map-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -The X server can report @var{:map-notify} events to clients wanting -information about which windows are mapped. The X server generates -this event type whenever a client application changes the -@emph{window}'s state from unmapped to mapped by calling -@var{map-window} or @var{map-subwindow}. - -To receive this event type, you @var{setf :structure-notify} as the -event-mask on the @emph{window}'s @var{event-mask} slot. You can -also receive this event type by @code{setf}ing the -@var{:substructure-notify} event-mask on the parent window. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was mapped. - -@item override-redirect-p -Type @var{boolean}. - -@emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is -@var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. -@end table - -@end deftp - - -@deftp {Event Type} :reparent-notify -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its old or new parent. - -The @var{:reparent-notify} event is generated when a @emph{window} -is reparented. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was reparented. - -@item parent -Type @var{window}. - -The new parent of the @emph{window}. - -@item x -Type @var{int16}. - -x and y specify the upper-left corner position of the @emph{window} relative to its new -@emph{parent}. - -@item y -Type @var{int16}. - -x and y specify the upper-left corner position of the @emph{window} relative to its new -@emph{parent}. - -@item override-redirect-p -Type @var{boolean}. - -@emph{override-redirect-p} is true if the override-redirect attribute -of the @emph{window} is @var{:on}; otherwise, it is @var{nil}. See -@var{window-override-redirect} in @ref{Window Attributes}. -@end table - -@end deftp - - -@deftp {Event Type} :unmap-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -The @var{:unmap-notify} event is generated when a mapped -@emph{window} is unmapped. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was unmapped. - -@item configure-p -Type @var{boolean}. - -@emph{configure-p} is true if the @emph{window} has a win-gravity -attribute of @var{:unmap}, and the event was generated because -@emph{window}'s parent was resized. -@end table - -@end deftp - - -@deftp {Event Type} :visibility-notify - -Selected by: @var{:visibility-change}. - -The @var{:visibility-notify} event is sent when the visibility of a -@emph{window} changes. @var{:visibility-notify} events are never -generated on @var{:input-only} windows. For the purposes of this -event, the visibility of the @emph{window} is not affected by its -subwindows. - -All @var{:visibility-notify} events caused by a hierarchy change -are generated after any hierarchy event caused by that change (for -example, @var{:unmap-notify}, @var{:map-notify}, -@var{:configure-notify}, @var{:gravity-notify}, or -@var{:circulate-notify}). Any @var{:visibility-notify} event on a -given window is generated before any @var{:exposure} events on that -window, but it is not required that all @var{:visibility-notify} -events on all windows be generated before all @var{:exposure} -events on all windows. The ordering of @var{:visibility-notify} -events with respect to @var{:focus-out}, @var{:enter-notify}, and -@var{:leave-notify} events is not constrained. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window that changed in visibility. - -@item state -Type (@var{member :unobscured :partially-obscured} @var{:fully-obscured}). - -When the @emph{window} was either unviewable or it was viewable and at least -partially obscured, and the @emph{window} changed to viewable and completely -unobscured, then @emph{state} is @var{:unobscured}. - -When the @emph{window} was either unviewable or it was viewable and completely -obscured, and the @emph{window} changed to viewable and partially obscured, then -@emph{state} is @var{:partially-obscured}. - -When the @emph{window} was either unviewable or it was at least partially visible, and -the @emph{window} changed to viewable and completely obscured, then @emph{state} is -@var{:fully-obscured}. -@end table - -@end deftp - - -@node Structure Control Events, Client Communications Events, Window State Events, Event Types -@subsection Structure Control Events - - -The following paragraphs describe events used to @emph{redirect} -client requests that reconfigure, restack, or map a window. Structure -control events are typically used only by window managers and not by -ordinary client applications. Structure control events report -redirected requests, allowing a window manager to modify the requests -before they are actually performed. However, if the override-redirect -attribute of a window is @var{:on}, then no requests are redirected -and no structure control events are generated. - -@deftp {Event Type} :circulate-request - -The @var{:circulate-request} event is generated when a client -application calls @var{circulate-window-up} or -@var{circulate-window-down} with a window that has the -override-redirect attribute @var{:off}. The @emph{window} argument -specifies the window to be restacked, and @emph{place} specifies -what the new position in the stacking order should be (either -@var{:top} or @var{:bottom}). - -Selected by: @var{:substructure-redirect} on @emph{parent}. - -@table @var -@item parent -@itemx event-window -Type @var{window}. - -The window receiving the event. The receiving client must have selected -@var{:substructure-redirect} on this window. - -@item window -Type @var{window}. - -The window to be restacked. - -@item place -Type @code{(member :top :bottom)}. - -The new stacking priority requested for @emph{window}. -@end table - -@end deftp - - -@deftp {Event Type} :colormap-notify -Selected by: @var{:colormap-change}. - -The @var{:colormap-notify} event is generated with @emph{new-p} -@var{t} when the @emph{colormap} associated with a @emph{window} is -changed, installed, or uninstalled. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving the event. - -@item colormap -Type @code{(or null colormap)}. - -The colormap attribute of the window. - -@item new-p -Type @var{boolean}. - -If @emph{new-p} is true, then the @emph{window}'s colormap attribute has changed to the given -@emph{colormap}. Otherwise, the @emph{window}'s colormap attribute has not, but the -@emph{colormap} has been installed or uninstalled. - -@item installed-p -Type @var{boolean}. - -If @emph{installed-p} is true, then the @emph{colormap} is currently installed. -@end table - -@end deftp - - -@deftp {Event Type} :configure-request - -Selected by:@var{:substructure-redirect} on parent. - -The @var{:configure-request} event is generated when a client -program sets the @emph{x}, @emph{y}, @emph{width}, @emph{heigh}t, -@emph{border-width} or stacking priority attributes of a window that -has the override-redirect attribute @var{:off}. - -@table @var -@item parent -@itemx event-window -Type @var{window}. - -The window receiving the event. The receiving client must have selected -@var{:substructure-redirect} on this window. - -@item window -Type @var{window}. - -The window to be reconfigured. - -@item x -Type @var{int16}. - -@emph{x} and @emph{y} specify the requested upper-left corner position of the @emph{window} relative -to the parent. If either @emph{x} or @emph{y} is not specified in the value-mask, then it is set to -the current window position. - -@item y -Type @var{int16}. - -@emph{x} and @emph{y} specify the requested upper-left corner position of the @emph{window} relative -to the @emph{parent}. If either @emph{x} or @emph{y} is not specified in the @emph{value-mask}, then it is set to -the current window position. - -@item width -@itemx height -Type @var{card16}. - -@emph{width} and @emph{height} specify the requested size of the @emph{window} interior. If either -@emph{width} or @emph{height} is not specified in the @emph{value-mask}, then it is set to the current -window size. - -@item border-width -Type @var{card16} - -The requested @emph{window} border width. If @emph{border-width} is not specified in the -@emph{value-mask}, then it is set to the current window @emph{border-width}. - -@item stack-mode -Type @code{(member :above :below :top-if :bottom-if :opposite)}. - -@emph{stack-mode} and @emph{above-sibling} specify the requested stacking priority of the -@emph{window}. If @emph{stack-mode} is not specified in the @emph{value-mask}, then it is set to -@var{:above}. - -@item above-sibling -Type (@var{or null window}). - -@emph{stack-mode} and @emph{above-sibling} specify the requested stacking priority of the -@emph{window}. If @emph{above-sibling} is not specified in the @emph{value-mask}, then it is set to @var{nil}. - -@item value-mask -Type @var{mask16}. - -Specifies the changed @emph{window} attributes contained in the redirected client -request. Each 1 bit specifies that the corresponding attribute was changed. -@end table - -@end deftp - - -@deftp {Event Type} :map-request - -Selected by: @var{:substructure-redirect} on parent. - -The @var{:map-request} event is generated when a client application -maps a @emph{window} that has the override-redirect attribute -@var{:off}. - -@table @var -@item parent -@itemx event-window -Type @var{window}. - -The window receiving the event. The receiving client must have selected -@var{:substructure-redirect} on this window. - -@item window -Type @var{window}. - -The window to be mapped. -@end table - -@end deftp - - -@deftp {Event Type} :resize-request - -Selected by: @var{:resize-redirect}. - -The @var{:resize-request} event is generated when a client program -sets the @emph{width} or @emph{height} attributes of a @emph{window} -that has the override-redirect attribute @var{:off}. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window to be resized. - -@item width -@itemx height -Type @var{card16}. - -@emph{width} and @emph{height} specify the requested size of the wi@emph{ndow} interior. If either -@emph{width} or @emph{height} was unchanged in the client request, then it is set to the current -window size. -@end table - -@end deftp - - -@node Client Communications Events, Declaring Event Types, Structure Control Events, Event Types -@subsection Client Communications Events - - -The client communications events discussed in the following paragraphs -are: @var{:client-message}, @var{:property-notify}, -@var{:selection-clear}, @var{:selection-request}, and -@var{:selection-notify}. - -@deftp {Event Type} :client-message - -The @var{:client-message} event is generated exclusively by client -calls to @var{send-event}. The X server places no interpretation on -the @emph{type} or content of @emph{data} sent in a -@var{:client-message}. A client can neither select -@var{:client-message} events nor avoid receiving them. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving the event. - -@item type -Type @var{keyword}. - -An xatom keyword that specifies the type of client message. Interpretation of -the type is determined solely by agreement between the sending and receiving -clients. - -@item format -Type (@var{member 8 16 32}). - -An integer that specifies whether @emph{data} should be viewed as a sequence of 8-bit, -16-bit, or 32-bit quantities. - -@item data -Type @code{(sequence integer)}. - -The data content of the client message. @emph{data} always consists of 160 bytes -- -depending on format, either 20 8-bit values, 10 16-bit values or 5 32-bit values. -The amount of this data actually used by a particular client message depends on -the type. -@end table - -@end deftp - - -@deftp {Event Type} :property-notify -Selected by: @var{:property-change}. - -The @var{:property-notify} event is generated when a window -property is changed or deleted. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving the event. - -@item atom -Type @var{keyword}. - -The property that was changed or deleted. - -@item state -Type @code{(member :new-value :deleted)}. - -@emph{state} is @var{:new-value} if the property was changed using @var{change-property} or -@var{rotate-properties}, even if zero-length data was added or if all or part of the -property was replaced with identical data. @emph{state} is @var{:deleted} if the property was -deleted using @var{delete-property} or @var{get-property}. - -@item time -Type @var{timestamp}. - -The server time when the property was changed or deleted. -@end table - -@end deftp - - -@deftp {Event Type} :selection-clear - -The @var{:selection-clear} event is reported to the previous owner -of a @emph{selection} when the owner of the @emph{selection} is -changed. The selection owner is changed by a client using -@code{setf}. A client can neither select @var{:selection-clear} -events nor avoid receiving them. -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window losing ownership of the @emph{selection}. - -@item selection -Type @var{keyword}. - -The name of the selection. - -@item time -Type @var{timestamp}. - -The last-change time recorded for the @emph{selection}. -@end table - -@end deftp - -@deftp {Event Type} :selection-notify - -The @var{:selection-notify} event is sent to a client calling -@var{convert-selection}. @var{:selection-notify} reports the -result of the client request to return the current value of a -@emph{selection} into a particular form. @var{:selection-notify} is -sent using @var{send-event} by the owner of the selection or (if no -owner exists) by the X server. A client can neither select -@var{:selection-notify} events nor avoid receiving them. - -@var{NOTE:} Standard conventions for inter-client communication require the following -additional steps in processing a @var{:selection-notify} event: - -@enumerate - -@item -The client receiving this event should call @var{get-property} to -return the converted selection value. - -@item -After receiving the selection value, the property should then be -deleted (either by using the @var{:delete-p} argument to -@var{get-property} or by calling @var{delete-property}). -@end enumerate - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The requestor window given in the call to @var{convert-selection}. - -@item selection -Type @var{keyword}. - -The selection to be converted. - -@item target -Type @var{keyword}. - -An @var{xatom} specifying the type of the converted selection value. This is the same -target type given in the call to @var{convert-selection}. - -@item property -Type @code{(or null keyword)}. - -The window property containing the converted selection. If the property is @var{nil}, -then either the @emph{selection} has no owner or the owner could not perform the -conversion to the @emph{target} type. - -@item time -Type @var{timestamp}. - -The timestamp from the client call to @var{convert-selection}. -@end table - -@end deftp - - -@deftp {Event Type} :selection-request - -The @var{:selection-request} event is reported to the owner of a -selection when a client calls @var{convert-selection}. This event -requests the selection owner to convert the current value of a -@emph{selection} into a specified form and to return it to the -requestor. A client can neither select @var{:selection-request} -events nor avoid receiving them. - -The selection owner should respond to a @var{:selection-request} event by performing the -following steps: - -@enumerate - -@item -Convert the current @emph{selection} value to the @emph{target} -type. - -@item -Store the converted selection value in the @emph{property}. If -@emph{property} is @var{nil}, then the owner should choose the -@emph{property}. - -@item -Call @var{send-event} to send a @var{:selection-notify} event to -the @emph{requestor} containing the @emph{property} with the -converted value. If the @emph{selection} could not be converted to -the @emph{target} type, then a @var{nil} @emph{property} should -be sent. The @var{:selection}, @var{:target}, and @var{:time} -arguments to @var{send-event} should be the same as those -received in the @var{:selection-request} event. The event-mask -argument to @var{send-event} should be @var{nil}; that is, the -@var{:selection-notify} event should be sent to client that -created the @emph{requestor}. -@end enumerate - - -@var{NOTE:} Standard conventions for inter-client communication -require the following additional steps in processing a -@var{:selection-request} event: - -@enumerate - -@item -The property used to store the selection value must belong to the -requestor. - -@item -If the property is @var{nil}, the target type @var{atom} should -be used as the property name. - -@item -If the window did not actually own the selection at the given -time, the request should be refused, just as if it could not be -converted to the target type. -@end enumerate - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The selection owner receiving the event. - -@item requestor -Type @var{window}. - -The window requesting the converted @emph{selection}. - -@item selection -Type @var{keyword}. - -The selection to be converted. - -@item target -Type @var{keyword}. - -An @var{xatom} specifying the type of the converted @emph{selection} value. - -@item property -Type @code{(or null keyword)}. - -A requestor window property. - -@item time -Type @var{timestamp}. - -The timestamp sent in the client @var{convert-selection} request. -@end table - -@end deftp - - -@node Declaring Event Types, , Client Communications Events, Event Types -@subsection Declaring Event Types - - -CLX uses the @var{declare-event} macro to define the event slot symbols -that access the contents of X events. Most client applications do not -need to use @var{declare-event} because the declarations for all core X -events are already defined by CLX. Programmers using extensions to the -X protocol can use @var{declare-event} to allow CLX to handle new event -types returned by an extended X server. - -@defmac declare-event event-codes &rest slot-declarations - -Defines a mapping between event slot symbols and the data items in -event messages received from an X server. - -The @emph{event-codes} argument gives the event type keyword for the -event described. If several event types share the same slots, then -@emph{event-codes} can be a list of event type -keywords. @emph{slot-declarations} is a list containing an element -for each event data item. The order of @emph{slot-declarations} -corresponds to the order of event data items defined by the X -protocol. - -Each element of @emph{slot-declarations} is a list of the form -(@emph{type slot-name}*), where @emph{type} is a Common Lisp type -specifier and @emph{slot-name} is a slot name symbol. The effect of -such a list is to declare that the next data items in the event have -the given data @emph{type} and are associated with the given -@emph{slot-name} symbols. @emph{slot-name} can also be a list of -slot name symbols; in this case, each symbol in the list is an alias -that refers to the same event data item. - -@table @var -@item event-codes -An event type keyword or a list of event type keywords. -@item slot-declarations -A list of clauses defining event slot symbols. -@end table - -@end defmac - - -@node Releasing Queued Events, , Event Types, Events and Input -@section Releasing Queued Events - - -A client grabbing the keyboard or pointer can freeze the reporting of -events on that device. When an input device is thus frozen, the server -queues events until explicitly requested to release them by the grabbing -client. CLX programs can use the @var{allow-events} function to release -queued events from a frozen input device. - -@defun allow-events display mode &optional time - -@table @var -@item display -A @var{display}. - -@item mode -One of: @var{:async-pointer}, @var{:sync-pointer}, -@var{:reply-pointer}, @var{:async-keyboard}, @var{:sync-keyboard}, -@var{:replay-keyboard}, @var{:async-both}, @var{:sync-both}. - -@item time -A @var{timestamp}. -@end table - -Releases some queued events if the client has caused a device to -freeze. The request has no effect if the @emph{time} is earlier than -the last-grab time of the most recent active grab for the client, or -if the @emph{time} is later than the current server time. If -@emph{time} is @var{nil}, the current server time is used. The -effect of this function depends on the specified @emph{mode}. -@itemize @bullet - -@item -@var{:async-pointer} -- If the pointer is frozen by the client, -pointer event processing continues normally. If the pointer is -frozen twice by the client on behalf of two separate grabs, -@var{:async-pointer} releases events for both -grab@emph{s}. @var{:async-pointer} has no effect if the pointer -is not frozen by the client, but the pointer need not be grabbed -by the client. - -@item -@var{:sync-pointer} -- If the pointer is frozen and actively -grabbed by the client, pointer event processing continues normally -until the next @var{:button-press} or @var{:button-release} -event is reported to the client, at which time the pointer again -appears to freeze. However, if the reported event causes the -pointer grab to be released, the pointer does not -freeze. @var{:sync-pointer} has no effect if the pointer is not -frozen by the client, or if the pointer is not grabbed by the -client. - -@item -@var{:replay-pointer} -- If the pointer is actively grabbed by -the client and is frozen as the result of an event having been -sent to the client (either from the activation of a -@var{grab-button}, or from a previous @var{allow-events} with -mode @var{:sync-pointer}, but not from a @var{grab-pointer}), -the pointer grab is released and that event is completely -reprocessed, but this time ignoring any passive grabs at or above -(towards the root) the @var{grab-window} of the grab just -released. The request has no effect if the pointer is not grabbed -by the client, or if the pointer is not frozen as the result of an -event. - -@item -@var{:async-keyboard} -- If the keyboard is frozen by the client, -keyboard event processing continues normally. If the keyboard is -frozen twice by the client on behalf of two separate grabs, -@var{:async-keyboard} releases events for both grabs. -@var{:async-keyboard} has no effect if the keyboard is not frozen -by the client, but the keyboard need not be grabbed by the client. - -@item -@var{:sync-keyboard} -- If the keyboard is frozen and actively -grabbed by the client, keyboard event processing continues -normally until the next @var{:key-press} or @var{:key-release} -event is reported to the client, at which time the keyboard again -appears to freeze. However if the reported event causes the -keyboard grab to be released, the keyboard does not -freeze. @var{:sync-keyboard} has no effect if the keyboard is not -frozen by the client, or if the keyboard is not grabbed by the -client. - -@item -@var{:replay-keyboard} -- If the keyboard is actively grabbed by -the client and is frozen as the result of an event having been -sent to the client (either from the activation of a grab-key, or -from a previous @var{allow-events} with mode -@var{:sync-keyboard}, but not from a @var{grab-keyboard}), the -keyboard grab is released and that event is completely -reprocessed, but this time ignoring any passive grabs at or above -(towards the root) the @var{grab-window} of the grab just -released. The request has no effect if the keyboard is not grabbed -by the client, or if the keyboard is not frozen as the result of -an event. - -@item -@var{:sync-both} -- If both pointer and keyboard are frozen by -the client, event processing (for both devices) continues normally -until the next @var{:button-press}, @var{:button-release}, -@var{:key-press}, or @var{:key-release} event is reported to the -client for a grabbed device (button event for the pointer, key -event for the keyboard). At this time, the devices again appear to -freeze. If the reported event causes the grab to be released, the -devices do not freeze. However, if the other device is still -grabbed, then a subsequent event for it will still cause both -devices to freeze. @var{:sync-both} has no effect unless both -pointer and keyboard are frozen by the client. If the pointer of -keyboard is frozen twice by the client on behalf of two separate -grabs, @var{:sync-both} @emph{thaws} for both, but a subsequent -freeze for @var{:sync-both} will only freeze each device once. - -@item -@var{:async-both} -- If the pointer and the keyboard are frozen -by the client, event processing for both devices continues -normally. If a device is frozen twice by the client on behalf of -two separate grabs, @var{:async-both} @emph{thaws} for -both. @var{:async-both} has no effect unless both pointer and -keyboard are frozen by the client. -@end itemize - -@var{:async-pointer}, @var{:sync-pointer}, and -@var{:replay-pointer} have no effect on processing of keyboard -events. @var{:async-keyboard}, @var{:sync-keyboard}, and -@var{:replay-keyboard} have no effect on processing of pointer -events. - -It is possible for both a pointer grab and a keyboard grab to be -active simultaneously by the same or different clients. When a -device is frozen on behalf of either grab, no event processing is -performed for the device. It is possible for a single device to be -frozen due to both grabs. In this case, the freeze must be released -on behalf of both grabs before events can again be processed. - - - -@end defun - -@node Resources, Control Functions, Events and Input, Top -@chapter Resources - -Users need a way to specify preferences for various user interface -values (for example, colors, fonts, title strings, and so -forth). Applications need a consistent method for determining the -default interface values that are specific to them. It is also useful if -application interface values can be modified by users without changes to -the program code. For example, this capability can make it easy to -change the color scheme of a user interface. In CLX, such interface -values are referred to as @emph{resources}. CLX defines functions for -storing and retrieving interface resources from a resource database. A -user can store various user interface values as resources in a resource -database; a CLX application can then read these resource values and -modify its user interface accordingly. - -@var{NOTE:} The general term @emph{resource} refers to any application -user interface value stored in a resource database. The term @emph{server -resource} is used more specifically to refer to the types of objects -allocated by an X server and referenced by clients (for example, -windows, fonts, graphics contexts, and so forth). - -@menu -* Resource Binings:: -* Basic Resource Database Functions:: -* Accessing Resource Values:: -* Resource Database Files:: -@end menu - -@node Resource Binings, Basic Resource Database Functions, Resources, Resources -@section Resource Binings - - -Conceptually, a resource database is a set of resource name-value pairs -(or @emph{resource bindings}). The name in a resource binding is a list -that is the concatenation of a @emph{path list} and an @emph{attribute -name}. - -A path list is a list of symbols (or strings) that corresponds to a path -through a tree-structured hierarchy. For example, the path: - -@lisp -'(top middle bottom) -@end lisp - - -corresponds to a three-level hierarchy in which @code{middle} is -the child of @code{top}, and @code{bottom} is the child of -@code{middle}. - -Typically, the path of a resource name corresponds to a path in a -hierarchy of windows, and each symbol/string names a window in the -hierarchy. However, the first element of the path can also represent the -overall name of the entire program, and subsequent path elements can -refer to an application-specific hierarchy of resource names not -strictly related to windows. In addition, a resource name can contain a -partially-specified path list. The asterisk symbol (*) is a wildcard -that can correspond to any sequence of levels in the hierarchy -(including the null sequence). For example, the path: - -@lisp -'(top * bottom) -@end lisp - - -corresponds to a hierarchy of two or more levels in which -@code{top} is at the top level and @code{bot-} -@code{tom} is at the bottom level. An element of a path list can -be the name of an individual window or the name of a class of windows. - -The final element of a resource name list is an attribute name. This -symbol (or string) identifies a specific attribute of the object(s) -named by the preceding path list. The attribute name can also be the -symbol * or the string "*", in which case the resource name refers to -all attributes of the path object(s). However, this form of resource -name is rarely useful. - -Some examples of resource bindings are shown below. In these examples, -assume that @code{mail} is the resource name of a mail reading -application. @code{mail} uses a window of the class -@code{button} whose name is @code{reply}. - -@multitable {Resource Name} {Resource Value} -@item @code{(mail screen-1 reply background)} @tab @code{'green} -@item @code{(mail * background)} @tab @code{'red} -@item @code{(* button background)} @tab @code{'blue} -@end multitable - -These resource bindings specify the following: -@itemize @bullet - -@item -The @code{background} attribute resource of @code{mail} -application@emph{'}s @code{reply} button has the value of -@code{green} on @code{screen-1}. - -@item -The @code{background} attribute for the rest of the -@code{mail} application is always @code{red} on all -screens. - -@item -In general, the @code{background} attribute for all -@code{button} windows is @code{blue}. -@end itemize - -@node Basic Resource Database Functions, Accessing Resource Values, Resource Binings, Resources -@section Basic Resource Database Functions - - -A @var{resource-database} structure is a CLX object that represents a -set of resource bindings. The following paragraphs describe the CLX -functions used to: -@itemize @bullet - -@item Create a resource database - -@item Add a resource binding - -@item Remove a resource binding - -@item Merge two resource databases - -@item Map a function over the contents of a resource database -@end itemize - -@defun make-resource-database - -@table @var -@item resource-database -Type @var{resource-database}. -@end table - -Returns an empty resource database. -@end defun - - -@defun add-resource database name-list value - -@table @var -@item database -The @var{resource-database} for the new resource binding. -@item name-list -A list containing strings or symbols specifying the name for the resource binding. -@item value -The value associated with the @emph{name-list} in the resource binding. This can be an object of any type. -@end table - -Adds the resource binding specified by @emph{name-list} and -@emph{value} to the given @emph{database}. Only one value can be -associated with the @emph{name-list} in the @emph{database}. This -function replaces any value previously associated with the -@emph{name-list}. - - - -@end defun - - -@defun delete-resource database name-list - -@table @var -@item database -The @var{resource-database} containing the resource binding. -@item name-list -A list containing strings or symbols specifying the name for the deleted resource binding. -@end table - -Removes the resource binding specified by @emph{name-list} from the given @emph{database}. - - - -@end defun - - -@defun map-resource database function &rest args - -@table @var -@item database -A @var{resource-database}. -@item function -A @var{function} object or function symbol. -@item args -A list of arguments to the @emph{function}. -@end table - -Calls the function for each resource binding in the -@emph{database}. For each resource binding consisting of a -@emph{name-list} and a @emph{value}, the form -(@var{apply} @emph{function name-list value args}) -is executed. - - - -@end defun - - -@defun merge-resources from-database to-database - -@table @var -@item from-database -The @var{resource-database} from which resource bindings are read. -@item to-database -The @var{resource-database} to which resource bindings are added. -@end table - - -Merges the contents of the @emph{from-database} with the -@emph{to-database}. @var{map-resource} invokes @var{add-resource} -in order to add each resource binding in the @emph{from-database} to -the @emph{to-database}. The updated @emph{to-database} is returned. - -@table @var -@item to-database -Type @var{resource-database}. -@end table - -@end defun - - -@node Accessing Resource Values, Resource Database Files, Basic Resource Database Functions, Resources -@section Accessing Resource Values - - -The power and flexibility of resource management is the result of the -way resource values in a resource database are accessed. A resource -binding binding stored in the database generally contains only a partial -resource name consisting of a mixture of name and class identifiers and -wildcard elements (that is, *). To look up a resource value, an -application program starts with two resource name lists of the same -length containing no wildcard elements -- a @emph{complete resource -name} and a @emph{complete} @emph{resource class}. The lookup -algorithm returns the value for the resource binding whose resource name -is the closest match to the complete name and class given. The -definition of @emph{closest match} takes into account the top-down, -parent-child hierarchy of resource names and also the distinction -between individual names and class names. - -@menu -* Complete Names and Classes:: -* Matching Resource Names:: -* Resource Access Functions:: -@end menu - -@node Complete Names and Classes, Matching Resource Names, Accessing Resource Values, Accessing Resource Values -@subsection Complete Names and Classes - -A resource binding contains a resource name list that can contain names, -class names, or a mixture of both. A class name is a symbol or string -that represents a group of related objects. The set of names used as -class names are not specified by CLX. Instead, class names are defined -by agreement between those who use class names when creating resource -bindings (that is, users) and those who use class names when accessing -resource values (that is, application programmers). - -In order to access a value in a resource database, an application uses a -key consisting of two items: a @emph{complete resource name} and a -@emph{complete resource class}. A complete resource name is a resource -name list containing no wildcard elements. A complete resource class is -a list of exactly the same form. The distinction between a complete -resource name and a complete resource class lies in how they are used to -access resource bindings. The elements of a complete resource name are -interpreted as names of individual objects; the elements of a complete -resource class are interpreted as names of object classes. The complete -resource name and class lists used in a resource database access must -have the same length. - -Like any resource name list, a complete resource name consists of a path -list and an attribute name. The first path list element is typically a -symbol (or string) identifying the application as a whole. The second -element can be a screen root identifier. Subsequent elements can be -identifiers for each ancestor window of an application window. Thus, a -path list typically identifies a specific window by tracing a path to it -through the application window hierarchy. The final element of a -complete resource name (its attribute name) is typically the name of a -specific attribute of the window given by the path list (for example, -@code{'background}). An attribute name can refer to a feature -associated with the window by the application but not by the X server -(for example, a font identifier). Similarly, a complete resource class -typically represents a path to a window in the application window -hierarchy and a specific window attribute. However, a complete resource -class contains the class name for each window and for the window -attribute. - -For instance, in the previous example, the @code{mail} application -can attempt to look up the value of the @code{background} resource -for the @code{reply button} window by using the following complete -resource name: - -@lisp -(mail screen-1 reply background) -@end lisp - -and the following complete resource class: - -@lisp -(application root button fill) -@end lisp - - -This complete resource name contains a path list identifying the reply -button window -- @code{(mail screen-1 reply)} -- and an attribute -name for the window background. The corresponding resource class -contains the class names for the same path list and window attribute. - -@node Matching Resource Names, Resource Access Functions, Complete Names and Classes, Accessing Resource Values -@subsection Matching Resource Names - - -The resource lookup algorithm searches a specified resource data base -and returns the value for the resource binding whose resource name is -the closest match to a given complete resource name and class. The -intent of the lookup algorithm is to formalize an intuitive notion of -the closest match. - -Precedence is given to a match which begins @emph{higher} in the -parent-child contact hierarchy. This allows a resource binding with a -partial name to define a resource value shared by all members of a -window subtree. For example, suppose the resource database contained the -following resource bindings: - -@multitable {Resource Name} {Resource Value} -@item @code{(mail * background)} @tab @code{'red} -@item @code{(* reply background)} @tab @code{'blue} -@end multitable - - -Suppose an application program searched by using the following complete -resource name: - -@lisp -(mail screen-1 reply background) -@end lisp - - -then the closest matching value returned would be @code{'red}. - -Precedence is given to the more specific match. A name match is more -specific than a class match. Either a name or class match is more -specific than a wildcard match. For example, suppose the resource -database contained the following resource bindings: - -@multitable {Resource Name} {Resource Value} -@item @code{(mail * background)} @tab @code{'red} -@item @code{(mail * fill)} @tab @code{'blue} -@end multitable - - -Suppose an application program searched by using the following complete -resource name and complete resource class: - -@lisp -(mail screen-1 reply background) -(application root button fill) -@end lisp - - -then the closest matching value returned would be -@code{'red}. However, suppose the resource database contained the -following resource bindings: - -@multitable {Resource Name} {Resource Value} -@item @code{(mail * background)} @tab @code{'red} -@item @code{(mail * button background)} @tab @code{'blue} -@end multitable - - -then the closest matching value returned would be @code{'blue}. - -@node Resource Access Functions, , Matching Resource Names, Accessing Resource Values -@subsection Resource Access Functions - - -The following paragraphs describe the CLX functions used to return a -value from a resource database. - -@defun get-resource database attribute-name attribute-class path-name path-class - -@table @var -@item database -A @var{resource-database}. -@item attribute-name -A string or symbol giving an attribute name from a complete resource name. -@item attribute-class -A string or symbol giving an attribute class name from a complete resource class. -@item path-name -The path list from a complete resource name. @emph{path-name} and @emph{path-class} must have the same length. -@item path-class -The path list from a complete resource class. @emph{path-name} and @emph{path-class} must have the same length. -@end table - - -Returns the value of the resource binding in the @emph{database} -whose resource name most closely matches the complete resource -name/class given by the @emph{path-name}, @emph{path-class}, -@emph{attribute-name}, and @emph{attribute-class}. The lookup -algorithm implements the precedence rules described previously to -determine the closest match. When comparing name elements, case is -significant only if both elements are strings; otherwise, element -matching is case-insensitive. - -@table @var -@item value -Type @var{t}. -@end table - -@end defun - - - - - -@defun get-search-table database path-name path-class - -@table @var -@item database -A @var{resource-database}. -@item path-name -The path list from a complete resource name. @emph{path-name} and @emph{path-class}must have the same length. -@item path-class -The path list from a complete resource class. @emph{path-name} and @emph{path-class} must have the same length. -@end table - - -Returns a table containing the subset of the @emph{database} that -matches the @emph{path-name} and @emph{path-class}. Resources using -the same @emph{path-name} and @emph{path-class} can be accessed much -more efficiently by using this table as an argument to -@var{get-search-resource}. - -@table @var -@item search-table -Type @var{list}. -@end table - -@end defun - - -@defun get-search-resource table attribute-name attribute-class - -@table @var -@item table -A search table returned by @var{get-search-table}. -@item attribute-name -A string or symbol giving an attribute name from a complete resource name. -@item attribute-class -A string or symbol giving an attribute class name from a complete resource class. -@end table - - -Returns the value of the resource binding in the search @emph{table} -that most closely matches the @emph{attribute-name} and -@emph{attribute-class}. The @emph{table} is computed by -@var{get-search-table} and represents a set of resource -bindings. The closest match is determined by the same algorithm used -in @var{get-resource}. - -The following two forms are functionally equivalent: - -@lisp -(get-resource - database attribute-name attribute-class path-name path-class) - -(get-search-resource - (get-search-table database path-name path-class) - attribute-name attribute-class) -@end lisp - - -However, the hard part of the search is done by -@var{get-search-table}. Looking up values for several resource -attributes that share the same path list can be done much more -efficiently with calls to @var{get-search-resource}. -@table @var -@item value -Type @var{t}. -@end table - -@end defun - -@node Resource Database Files, , Accessing Resource Values, Resources -@section Resource Database Files - - -X users and application programs can save resource bindings in a file, -using a standard file format shared by all X clients. The following -paragraphs describe the CLX functions used to convert between the -standard external format of resource files and the internal -resource-database format used by application programs. - -@defun read-resources database pathname &key :key :test :test-not - -@table @var -@item database -The @var{resource-database} to merge. -@item pathname -A pathname for the resource file to read. -@item :key -A function used to convert a value from the resource file into a resource binding value. -@item :test -@itemx :test-not -Functions used to select which resource bindings from the resource file are merged with the @emph{database}. -@end table - - - - -Reads resource bindings from a resource file in standard X11 format -and merges them with the given resource @emph{database}. The -@var{:key} function is called to convert a file resource value into -the value stored in the @emph{database}. By default, @var{:key} is -@var{#'identity}. The @var{:test} and @var{:test-not} functions -are predicates that select resource bindings to merge, based on the -result of the @var{:key} function. For each file resource binding -consisting of a @emph{resource-name} and a @emph{resource-value}, -the @var{:test} (or @var{:test-not}) function is called with the -arguments @emph{resource-name} and (@var{funcall} @emph{key -resource-value}). - -@table @var -@item database -Type @var{resource-database}. -@end table - -@end defun - - -@defun write-resources database pathname &key :write :test :test-not - -@table @var -@item database -The @var{resource-database} to write. -@item pathname -A pathname of the file to write. -@item :write -A function for writing resource values. -@item :test -@itemx :test-not -Functions used to select which resource bindings from the resource file are merged with the @emph{database}. -@end table - -Writes resource bindings found in the @emph{database} to the file -given by the @emph{pathname}. The output file is written in the -standard X11 format. The @var{:write} function is used for writing -resource values; the default is @var{#'princ}. The @var{:write} -function is passed two arguments: a @emph{resource-value} and a -@emph{stream}. The @var{:test} and @var{:test-not} functions are -predicates which select resource bindings to write. For each -resource binding consisting of a @emph{resource-name} and a -@emph{resource-value}, the @var{:test} (or @var{:test-not}) -function is called with the arguments @emph{resource-name} and -@emph{resource-value}. - - -@end defun - - -@node Control Functions, Extensions, Resources, Top -@chapter Control Functions - -@menu -* Grabbing the Server:: -* Pointer Control:: -* Keyboard Control:: -* Keyboard Encodings:: -* Client Termination:: -* Managing Host Access:: -* Screen Saver:: -@end menu - -@node Grabbing the Server, Pointer Control, Control Functions, Control Functions -@section Grabbing the Server - - -Certain cases may require that a client demand exclusive access to the -server, causing the processing for all other clients to be -suspended. Such exclusive access is referred to as @emph{grabbing the -server}. CLX provides functions to grab and release exclusive access -to the server. These function should be used rarely and always with -extreme caution, since they have the potential to disrupt the entire -window system for all clients. - -@defun grab-server display - -@table @var -@item display -A @var{display}. -@end table - -Disables processing of requests and close-downs on all connections -other than the one on which this request arrived. - - -@end defun - -@defun ungrab-server display - -@table @var -@item display -A @var{display}. -@end table - -Restarts processing of requests and close-downs on other -connections. - - -@end defun - - -@defmac with-server-grabbed display &body body - -Grabs the @emph{display} server only within the dynamic extent of -the @emph{body}. @var{ungrab-server} is automatically called upon -exit from the @emph{body}. This macro provides the most reliable way -for CLX clients to grab the server. - -@table @var -@item display -A @var{display}. -@item body -The forms to execute while the server is grabbed. -@end table - -@end defmac - - -@node Pointer Control, Keyboard Control, Grabbing the Server, Control Functions -@section Pointer Control - - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item Return or change the pointer acceleration and acceleration threshold - -@item Return or change the mapping of pointer button numbers -@end itemize - -@defun change-pointer-control display &key :acceleration :threshold - -@table @var -@item display -A @var{display}. -@item :acceleration -A number for the acceleration ratio. -@item :threshold -The number of pixels required for acceleration to take effect. -@end table - -Changes the acceleration and/or the acceleration threshold of the -pointer for the @emph{display}. The @var{:acceleration} number is -used as a multiplier, typically specified as a rational number of -the form @emph{C/P}, where @emph{C} is the number of pixel positions -of cursor motion displayed for @emph{P} units of pointer device -motion. The acceleration only occurs if the pointer moves more that -@var{:threshold} pixels at once, and only applies to the motion -beyond the @var{:threshold}. Either @var{:acceleration} or -@var{:threshold} can be set to @var{:default}, that restores the -default settings of the server. - - -@end defun - - -@defun pointer-control display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the acceleration and threshold for the @emph{display} -pointer. -@table @var -@item acceleration -@itemx threshold -Type @var{number}. -@end table - -@end defun - - -@defun pointer-mapping display &key (:result-type 'list) - -@table @var -@item display -A @var{display}. -@item :result-type -The type of sequence to return. -@end table - - -Returns or (with @code{setf}) changes the mapping of button numbers -for the @emph{display} pointer. The @var{:result-type} is not used -when changing the mapping. If element @emph{i} of the mapping -sequence is @emph{j}, then the events from pointer button @emph{j} -are reported by the server as events for button @emph{i}+1. (Note -that pointer buttons are numbered beginning with one, while the -mapping sequence itself is indexed normally from zero.) If element -@emph{i} of the mapping sequence is zero, then button @emph{i}+1 is -disabled and can no longer generate input events. No two elements of -the mapping can have the same non-zero value. - -The length of the mapping sequence indicates the actual number of -buttons on the device. When changing the mapping, the new mapping -must have this same length. -@table @var -@item mapping -Type @var{sequence} or @var{card8}@emph{.} -@end table - -@end defun - - -@node Keyboard Control, Keyboard Encodings, Pointer Control, Control Functions -@section Keyboard Control - - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item Return or change keyboard controls - -@item Ring the keyboard bell - -@item Return or change the mapping of modifiers - -@item Return the current up/down state of all keys -@end itemize - -@defun bell display &optional (percent-from-normal 0) - -@table @var -@item display -A @var{display}. -@item percent-from-normal -An integer (-100 through 100). -@end table - -Rings the bell on the keyboard at a volume relative to the base volume for the keyboard, -if possible. Percent can range from -100 to 100 inclusive, or else a Value error occurs. -The following is the bell volume when percent is non-negative: - -@lisp -(- (+ @emph{base percent}) (@var{quotient} (* @emph{base percent}) 100)) -@end lisp - -and when percent is negative: - -@lisp -(+ @emph{base} (@var{quotient} (* @emph{base percent}) 100)) -@end lisp - - - -@end defun - - -@defun change-keyboard-control display &key :key-click-percent :bell-percent :bell-pitch :bell-duration :led :led-mode :key :auto-repeat-mode - -@table @var -@item display -A @var{display}. -@item :key-click-percent -An integer (0 100). -@item :bell-percent -An integer (0 100). -@item :bell-pitch -A @var{card16}. -@item :bell-duration -A @var{card16}. -@item :led -A @var{card8}. -@item :led-mode -Either @var{:on} or @var{:off}. -@item :key -A @var{card8} keycode. -@item :auto-repeat-mode -Either @var{:on}, @var{:off}, or @var{:default}. -@end table - -Changes the various aspects of the keyboard. The keyword arguments -specify which controls to change. - -The @var{:key-click-percent} keyword sets the volume for key -clicks, if possible. A value of 0 implies off, while a value of 100 -implies loud. Setting @var{:key-click-percent} to @var{:default} -restores the default value. - -The @var{:bell-percent} sets the base volume for the bell between 0 -(off) and 100 (loud) if possible. Setting @var{:bell-percent} to -@var{:default} restores the default value. - -The @var{:bell-pitch} sets the pitch (specified in Hz) of the bell, -if possible. Setting the @var{:bell-pitch} to @var{:default} -restores the default value. The @var{:bell-duration} sets the -duration ( specified in milliseconds) of the bell, if -possible. Setting @var{:bell-pitch} to @var{:default} restores the -default. Note that a bell generator connected with the console but -not directly on the keyboard is treated as if it were part of the -keyboard. - -If both @var{:led-mode} and @var{:led} are specified, then the -state of that LED is changed, if possible. If only @var{:led-mode} -is specified, the state of all LEDs are changed, if possible. At -most 32 LEDs are supported, numbered from one. No standard -interpretation of the LEDs are defined. - -If both @var{:auto-repeat-mode} and @var{:key} are specified, the -auto-repeat mode of that key is changed, if possible. If only -@var{:auto-repeat-mode} is specified, the global auto-repeat mode -for the entire keyboard is changed, if possible, without affecting -the per-key settings. An error occurs if @var{:key} is specified -without @var{:auto-repeat-mode}. - - -@end defun - - -@defun keyboard-control display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the current control values for the keyboard. For the LEDs, -the least significant bit of @emph{led-mask} corresponds to LED one, -and each one bit in @emph{led-mask} indicates an LED that is -lit. @emph{auto-repeats} is a bit vector; each one bit indicates -that auto-repeat is enabled for the corresponding key. The vector is -represented as 32 bytes. Byte @emph{n} (from 0) contains the bits -for keys 8@emph{n} to 8@emph{n}+7, with the least significant bit in -the byte representing key 8@emph{n}. -@table @var -@item key-click-percent -@itemx bell-percent -Type @var{card8}. -@item bell-pitch -@itemx bell-duration -Type @var{card16}. -@item led-mask -Type @var{card32}. -@item global-auto-repeat -Either @var{:on} or @var{:off}. -@item auto-repeats -Type @var{bit-vector}. -@end table - -@end defun - - -@defun modifier-mapping display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the set of keycodes used for each modifier on the -@emph{display} keyboard. Each return value is a list of the -@var{card8} keycodes used for each modifier key. The order of -keycodes within each list is server-dependent. -@table @var -@item shift-keycodes -@itemx lock-keycodes -@itemx control-keycodes -@itemx mod1-keycodes -@itemx mod2-keycodes -@itemx mod3-keycodes -@itemx mod4-keycodes -@itemx mod5-keycodes -Type @var{list} of @var{card8}. -@end table - -@end defun - - -@defun query-keymap display - -@table @var -@item display -A @var{display}. -@end table - -Returns a bit vector that describes the state of the keyboard. Each -one bit indicates that the corresponding key is currently -pressed. The vector is represented as 32 bytes. Byte @emph{n} (from -0) contains the bits for keys 8@emph{n} to 8@emph{n}+7, with the -least significant bit in the byte representing key 8@emph{n}. -@table @var -@item keymap -Type @var{bit-vector} 256. -@end table - -@end defun - - -@defun set-modifier-mapping display &key :shift :lock :control :mod1 :mod2 :mod3 :mod4 :mod5 - -@table @var -@item display -A @var{display}. -@item :shift -@itemx :lock -@itemx :control -@itemx :mod1 -@itemx :mod2 -@itemx :mod3 -@itemx :mod4 -@itemx :mod5 -A sequence of @var{card8} keycodes for the given modifier. -@end table - - -Changes the set of keycodes mapped to the specified modifier keys on -the @emph{display} keyboard. Each keyword argument contains a -sequence of new @var{card8} keycodes for a specific modifier. The -return value indicates whether the change was completed -successfully. - -A status of @var{:failed} is returned if hardware limitations -prevent the requested change. For example, multiple keycodes per -modifier may not be supported, up transitions on a given keycode may -not be supported, or autorepeat may be mandatory for a given -keycode. If @var{:failed} is returned, the mappings for all -modifiers remain unchanged. - -A status of @var{:device-busy} is returned if a new keycode given -for a modifier was not previously mapped to that modifier and is -currently in the down state. In this case, the mappings for all -modifiers remain unchanged. -@table @var -@item status -One of @var{:success}, @var{:failed}, or @var{:device-busy}. -@end table - -@end defun - - -@node Keyboard Encodings, Client Termination, Keyboard Control, Control Functions -@section Keyboard Encodings - - -Handling the great diversity of keyboard devices and international -language character encodings is a difficult problem for interactive -programs that need to receive text input but must also be portable. The -X Window System solves this problem by using different sets of encodings -for device keys (@emph{keycodes}) and for character symbols -(@emph{keysyms}). Each X server maintains a @emph{keyboard mapping} that -associates keycodes and keysyms, and which can be returned or changed by -client programs. - -To handle text input, a CLX client program must follow these steps: -@enumerate - -@item -Receive a @var{:key-press} (or @var{:key-release}) event containing -a keycode. - -@item -Convert the keycode into its corresponding keysym, based on the -current keyboard mapping. See @var{keycode->keysym}. - -@item -Convert the keysym into the corresponding Common Lisp character. See -@var{keysym->character}. -@end enumerate - -@menu -* Keycodes and Keysyms:: -* Keyboard Mapping:: -* Using Keycodes and Keysyms:: -@end menu - -@node Keycodes and Keysyms, Keyboard Mapping, Keyboard Encodings, Keyboard Encodings -@subsection Keycodes and Keysyms - - -A @emph{keycode} represents a physical (or logical) key. In CLX, -keycodes are values of type (@var{integer} 8 255). A keycode value -carries no intrinsic information, although server implementors may -attempt to encode geometry (for example, matrix) information in some -fashion so it can be interpreted in a server- dependent fashion. The -mapping between keys and keycodes cannot be changed. - -A @emph{keysym} is an encoding of a symbol on the cap of a key. In CLX, -keysyms are values of type @var{card32}. The set of defined keysyms -include the ISO Latin character sets (1-4), Katakana, Arabic, Cyrillic, -Greek, Technical, Special, Publishing, APL, Hebrew, and miscellaneous -keys found on keyboards (RETURN, HELP, TAB, and so on). The encoding of -keysyms is defined by the X Protocol. - -A list of keysyms is associated with each keycode. The length of the -list can vary with each keycode. The list is intended to convey the set -of symbols on the corresponding key. By convention, if the list contains -a single keysym and if that keysym is alphabetic and case distinction is -relevant, then it should be treated as equivalent to a two-element list -of the lowercase and uppercase keysyms. For example, if the list -contains the single keysym for uppercase A, the client should treat it -as if it were a pair with lowercase as the first keysym and uppercase A -as the second keysym. - -For any keycode, the first keysym in the list should be chosen as the -interpretation of a key press when no modifier keys are down. The second -keysym in the list normally should be chosen when the @var{:shift} -modifier is on, or when the @var{:lock} modifier is on and @var{:lock} -is interpreted as @var{:shift-lock}. When the @var{:lock} modifier is -on and is interpreted as @var{:caps-lock}, it is suggested that the -@var{:shift} modifier first be applied to choose a keysym, but if that -keysym is lowercase alphabetic, the corresponding uppercase keysym -should be used instead. - -Other interpretations of @var{:caps-lock} are possible; for example, it -may be viewed as equivalent to @var{:shift-lock}, but only applying -when the first keysym is lowercase alphabetic and the second keysym is -the corresponding uppercase alphabetic. No interpretation of keysyms -beyond the first two in a list is suggested here. No spatial geometry of -the symbols on the key is defined by their order in the keysym list, -although a geometry might be defined on a vendor-specific basis. The X -server does not use the mapping between keycodes and keysyms. Rather, -the X server stores the mapping merely for reading and writing by -clients. - -@node Keyboard Mapping, Using Keycodes and Keysyms, Keycodes and Keysyms, Keyboard Encodings -@subsection Keyboard Mapping - -The X server maintains a keyboard mapping that associates each keycode -with one or more keysyms. The following paragraphs describe the CLX -functions used to return or change the mapping of keycodes. - -@defun change-keyboard-mapping display keysyms &key (:start 0) :end - -@table @var -@item display -A @var{display}. -@item keysyms -A two-dimensional array of keysym (@var{card32}) values. -@item :start -@itemx :end -Indexes for the subsequence of @emph{keysyms} used. -@item :first-keycode -A @var{card8} defining the first keycode mapping changed. -@end table - -(@var{:first-keycode :start}) - -Changes the mapping of keycodes to @emph{keysyms}. A -@var{:mapping-notify} event is generated for all clients. - -The new @emph{keysyms} are specified as a two-dimensional array in -which: - -(@var{aref} @emph{keysyms} (+ @var{:start} @emph{i}) @emph{j}) - -is @emph{keysym j} associated with keycode (+ @var{:first-keycode} -@emph{i}). The maximum number of @emph{keysyms} associated with any -one keycode is given by: - -(@var{array-dimension} @emph{keysyms} 1) - -@emph{keysyms} should contain @var{nil} elements to represent those -keysyms that are undefined for a given keycode. @var{:start} and -@var{:end} define the subsequence of the @emph{keysyms} array that -defines the new mapping, and the number of keycode mappings -changed. By default, @var{:end} is given by: - -(@var{array-dimension} @emph{keysyms} 0) - -The keycodes whose mappings are changed are given by -@var{:first-keycode} through the following: - -(+ @var{:first-keycode} (- @var{:end :start}) -1) - -keycodes outside this range of are not -affected. @var{:first-keycode} must not be less than -(@var{display-min-keycode} @emph{display}), and the last keycode -modified must not be greater than (@var{display-max-keycode} -@emph{display}). - - -@end defun - - - -@defun keyboard-mapping display &key :first-keycode :start :end :data - -@table @var -@item display -A @var{display}. -@item :first-keycode -A @var{card8} defining the first keycode mapping returned. -@item :start -@itemx :end -Indexes for the subsequence of the returned array which is modified. -@item :data -If given, a two-dimensional array to receive the returned keysyms. -@end table -Returns the keysyms mapped to the given range of keycodes for the -@emph{display} keyboard. The mappings are returned in the form of a -two-dimensional array of @var{card32} keysym values. The -@var{:data} argument, if given, must be a two-dimensional array in -which the returned mappings will be stored. In this case: - -(@var{array-dimension :data} 1) - -defines the maximum number of keysyms returned for any -keycode. Otherwise, a new array is created and returned. - -Upon return: - -(@var{aref} @emph{mappings} (+ @emph{:start i}) @emph{j}) - -will contain keysym @emph{j} associated with keycode (+ -@var{:first-keycode i}) (or @var{nil}, if keysym @emph{j} is -undefined for that keycode). - -@var{:first-keycode} specifies the first keycode whose mapping is -returned; by default, @var{:first-keycode} is -(@var{display-min-keycode} @emph{display}). @var{:start} and -@var{:end} define the subsequence of the returned array in which -the returned mappings are stored. By default, @var{:start} is given -by @var{:first-keycode} and @var{:end} is given by: - -(1+ (@var{display-max-keycode} @emph{display})) - -@var{:first-keycode} must not be less than -(@var{display-min-keycode} @emph{display}), and the last keycode -returned must not be greater than (@var{display-max-keycode} -@emph{display}). -@table @var -@item mappings -Type (@var{array card32} (* *)). -@end table - -@end defun - - -@node Using Keycodes and Keysyms, , Keyboard Mapping, Keyboard Encodings -@subsection Using Keycodes and Keysyms - - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item Convert a keycode into a keysym - -@item Convert a keysym into a character -@end itemize - -@defun keycode->keysym display keycode keysym-index - -@table @var -@item display -A @var{display}. -@item keycode -A @var{card8}. -@item keysym-index -A @var{card8}. -@end table - - -Returns the @emph{keysym} at the given @emph{keysym-index} from the -keysym list for the @emph{keycode} in the current keyboard mapping -for the @emph{display} server. -@emph{This function was called keycode-keysym in X11R4 and older versions of CLX.} -@table @var -@item keysym -Type @var{keysym}. -@end table - -@end defun - - -@defun keysym->character display keysym &optional (state 0) - -@table @var -@item display -A @var{display}. -@item keysym -A @var{keysym}. -@item state -A @var{mask16}. -@end table - -Returns the @emph{character} associated with the @emph{keysym} and -the @emph{state}. The @emph{state} is a @var{mask16} bit mask -representing the state of the @emph{display} modifier keys and -pointer buttons. See @var{state-mask-key} in @ref{Data Types}. If the @emph{keysym} does not represent a Common Lisp -character, then @var{nil} is returned. -@emph{This function was called keysym-character in X11R4 and older versions of CLX.} - -The @emph{state} determines the bits attribute of the returned -@emph{character}, as follows: -@table @var -@item :control -@var{char-control-bit} -@item :mod-1 -@var{char-meta-bit} -@item :mod-2 -@var{char-super-bit} -@item :mod-3 -@var{char-hyper-bit} -@end table - -@c Of course *we* know that this mapping is bull shit! -@table @var -@item character -Type @var{character} or @var{null}. -@end table - -@end defun - - -@node Client Termination, Managing Host Access, Keyboard Encodings, Control Functions -@section Client Termination - - -The CLX functions affecting client termination are discussed in the -following paragraphs. - -When a display connection to an X server is closed, whether by an -explicit call to @var{close-display} or by some external condition, the -server automatically performs a sequence of operations to clean up -server state information associated with the closed connection. The -effect of these operations depends the @emph{close-down mode} and the -@emph{save-set} that the client has specified for the closed display -connection. The close-down mode of a display determines whether server -resources allocated by the connection are freed or not. The save-set -identifies windows that will remain after the connection is closed. - -The display save-set is used primarily by window managers that reparent -the top-level windows of other clients. For example, such a window -manager can automatically create a frame window that encloses a -top-level client window, along with a set of controls used for window -management. Ordinarily, termination of the window manager client would -then destroy all client windows! However, the window manager can prevent -this by adding to its save-set those windows created by other clients -that should be preserved. - -When a display connection closes, an X server performs the following -operations: -@enumerate - -@item -For each selection owned by a window created on the connection, the -selection owner is set to @var{nil}. - -@item -An active or passive grab established for a window created on the -connection is released. - -@item -If the connection has grabbed the server, the server is ungrabbed. - -@item -Server resources and colormap cells allocated by the connection are -freed and destroyed, depending on the close-down mode, as follows: -@itemize @bullet - -@item -@var{:retain-permanent} -- All resources are marked -@emph{permanent}, and no resources are destroyed. These resources -can later be destroyed by a call to @var{kill-client}. - -@item -@var{:retain-temporary} -- All resources are marked -@emph{temporary}, and no resources are destroyed. These resources -can later be destroyed by a call to @var{kill-client} or -@var{kill-temporary-clients}. - -@item -@var{:destroy} -- All resources are destroyed. -@end itemize -@end enumerate - -When server resources allocated by a display connection are destroyed -- -whether by closing the connection with close-down mode @var{:destroy} -or by later calling @var{kill-client} or @var{kill-temporary-clients} --- then an X server performs the following operations on each member of -the save-set before actually destroying resources. -@enumerate - -@item -If the save-set window is a descendant of a window created on the -connection, the save-set window is reparented. The new parent is the -closest ancestor such that the save-set window is no longer a -descendant of any window created on the connection. The position of -the reparented window with respect to its parent remains unchanged. - -@item -If the save-set window is unmapped, then it is mapped. -@end enumerate - -If the last connection open to an X server is closed with close-down -mode @var{:destroy}, the server resets its state to restore all initial -defaults. The server state after reset is the same as its initial state -when first started. When an X server resets, it performs the following -operations: -@itemize @bullet - -@item -All permanent and temporary server resources from previously-closed -connections are destroyed. - -@item -All but the predefined atoms are deleted. - -@item -All root window properties are deleted. - -@item -All device control attributes and mappings are restored to their -original default values. - -@item -The default background and cursor for all root windows are restored. - -@item -The default font path is restored. - -@item -The input focus is set to @var{:pointer-root}. - -@item -The access control list is reset. -@end itemize - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item -Add or remove a window from a display save-set. - -@item -Return or change the display close-down mode. - -@item -Force a connection to be closed or all its server resources to be -destroyed. - -@item -Force a connection to be closed and all temporary resources to be -destroyed. -@end itemize - -@defun add-to-save-set window - -@table @var -@item window -A @var{window}. -@end table - -Adds the specified @emph{window} to the save-set of the -@emph{window} display. The @emph{window} must have been created by -some other display. Windows are removed automatically from the -save-set when they are destroyed. - - -@end defun - - -@defun close-down-mode display - -@table @var -@item display -A @var{display}. -@end table -Returns and (with @code{setf}) sets the close-down mode of the -client's resources at connection close. -@table @var -@item mode -One of @var{:destroy}, @var{:retain-permanent}, or @var{:retain-temporary}. -@end table - -@end defun - - -@defun kill-client display resource-id - -@table @var -@item display -A @var{display}. -@item resource-id -A valid @var{card29} resource ID. -@end table - -Closes the display connection which created the given -@emph{resource-id}. The @emph{resource-id} must be valid, but need -not belong to the given @emph{display}. - -If the closed connection was previously open, the connection is -closed according to its close-down mode. Otherwise, if the -connection had been previously terminated with close-down mode -@var{:retain-permanent} or @var{:retain-temporary}, then all its -retained server resources -- both permanent and temporary -- are -destroyed. - - -@end defun - - -@defun kill-temporary-clients display - -@table @var -@item display -A @var{display}. -@end table - -Closes the @emph{display} connection and destroys all retained -temporary server resources for this and all previously-terminated -connections. - -If the @emph{display} connection was previously open, the connection -is closed according to its close-down mode. Otherwise, if the -@emph{display} connection had been previously terminated with -close-down mode @var{:retain-permanent} or -@var{:retain-temporary}, then all its retained server resources -- -both permanent and temporary -- are destroyed. - - -@end defun - - -@defun remove-from-save-set window - -@table @var -@item window -A @var{window}. -@end table - -Removes the specified @emph{window} from the save-set of the -@emph{window} display. The @emph{window} must have been created by -some other display. Windows are removed automatically from the -save-set when they are destroyed. - - -@end defun - - -@node Managing Host Access, Screen Saver, Client Termination, Control Functions -@section Managing Host Access - - -An X server maintains a list of hosts from which client programs can be -run. Only clients executing on hosts that belong to this @emph{access -control list} are allowed to open a connection to the -server. Typically, the access control list can be changed by clients -running on the same host as the server. Some server implementations can -also implement other authorization mechanisms in addition to, or in -place of, this mechanism. The action of this mechanism can be -conditional based on the authorization protocol name and data received -by the server at connection setup. - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item Add or remove hosts on the access control list. - -@item Return the hosts on the access control list. - -@item Return or change the state of the access control list mechanism -@end itemize - -@defun access-control display - -@table @var -@item display -A @var{display}. -@end table -Returns and (with @code{setf}) changes the state of the access -control list mechanism for the @emph{display} server. Returns true -if access control is enabled; otherwise, @var{nil} is returned. If -enabled, the access control list is used to validate each client -during connection setup. - -Only a client running on the same host as the server is allowed to -enable or disable the access control list mechanism. -@table @var -@item enabled-p -Type @var{boolean}. -@end table - -@end defun - - -@defun access-hosts display &key (:result-type 'list) - -@table @var -@item display -A @var{display}. -@item :result-type -The type of hosts sequence to return. -@end table -Returns a sequence containing the @emph{hosts} that belong to the -access control list of the @emph{display} server. Elements of the -returned @emph{hosts} sequence are either strings or some other type -of object recognized as a host name by @var{add-access-host} and -@var{remove-access-host}. The second returned value specifies -whether the access control list mechanism is currently enabled or -disabled (see @var{access-control}). -@table @var -@item hosts -@var{sequence} of @var{string}. -@item enabled-p -Type @var{boolean}. -@end table - -@end defun - - -@defun add-access-host display host - -@table @var -@item display -A @var{display}. -@item host -A host name. Either a string or some other implementation-dependent type. -@end table - -Adds the specified @emph{host} to the access control list. Only a -client running on the same host as the server can change the access -control list. - - -@end defun - - -@defun remove-access-host display host - -@table @var -@item display -A @var{display}. -@item host -A host name. Either a string or some other implementation-dependent type. -@end table - -Removes the specified @emph{host} from the access control list. Only -a client running on the same host as the server can change the -access control list. - - -@end defun - - -@node Screen Saver, , Managing Host Access, Control Functions -@section Screen Saver - - -To prevent monitor damage, an X server implements a screen saver -function which blanks screens during periods of unuse. The screen saver -can be in one of three states: -@itemize @bullet - -@item -Disabled -- No screen blanking is done and screen content remains unchanged. - -@item -Deactivated -- The server is being used. When the server input devices -are unused for a specific amount of time, the screen saver becomes -activated. - -@item -Activated -- The server input devices are unused. The screen saver -blanks all server screens or displays a server-dependent image. As -soon as an input event from either the pointer or the keyboard occurs, -the screen saver is deactivated and its timer is reset. -@end itemize - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item -Return or change screen saver control values. - -@item -Activate or reset the screen saver -@end itemize - -@defun activate-screen-saver display - -@table @var -@item display -A @var{display}. -@end table - -Activates the screen saver for the @emph{display} server. - - -@end defun - - -@defun reset-screen-saver display - -@table @var -@item display -A @var{display}. -@end table - -Deactivates the screen saver for the @emph{display} server (if -necessary) and resets its timer, just as if a pointer or keyboard -event had occurred. - - -@end defun - - -@defun screen-saver display - -@table @var -@item display -A @var{display}. -@end table -Returns the current control values for the @emph{display} server -screen saver. See @var{set-screen-saver}. -@table @var -@item timeout -@itemx period -Type @var{int16}. -@item blanking -@itemx exposures -One of @var{:yes} or @var{:no}. -@end table - -@end defun - - -@defun set-screen-saver display timeout period blanking exposures - -@table @var -@item display -A @var{display}. -@item timeout -Specifies the delay until timeout takes over. -@item period -Specifies the periodic change interval, if used. -@item blanking -Specifies whether the blanking option is available. -@item exposures -Specifies whether exposures are allowed during blanking. -@end table - -Changes the current control values for the @emph{display} server -screen saver. The screen saver is reset. The screen saver is also -disabled if: -@itemize @bullet - -@item -@emph{timeout} is zero, or - -@item -Both @emph{blanking} and @emph{exposures} are disabled and the -server cannot regenerate the screen contents without sending -@var{:exposure} events. -@end itemize - -The @emph{timeout} specifies the (non-negative) number of seconds of -input device inactivity that must elapse before the screen saver is -activated. The @emph{timeout} can be set to @var{:default} to -restore the server default timeout interval. - -If @emph{blanking} is @var{:yes} and the screen hardware supports -blanking, blanking is enabled; that is, the screen saver will simply -blank all screens when it is activated. @emph{blanking} can be set -to @var{:default} to restore the server default state for blanking. - -If @emph{exposures} is @var{:yes}, exposures are enabled. If -exposures are enabled, or if the server is capable of regenerating -screen contents without sending @var{:exposure} events, the screen -saver will display some server-dependent image when -activated. Frequently, this image will consist of a repeating -animation sequence, in which case @emph{period} specifies the ( -non-negative) number of seconds for each repetition. A @emph{period} -of zero is a hint that no repetition should occur. - - -@end defun - - - -@node Extensions, Errors, Control Functions, Top -@chapter Extensions -@menu -* Extensions (Extensions):: -* SHAPE - The X11 Nonrectangular Window Shape Extension:: -* RENDER - A new rendering system for X11:: -* DPMS - The X11 Display Power Management Signaling Extension:: -* BIG-REQUESTS - Big Requests Extension:: -@end menu - -@node Extensions (Extensions), SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions, Extensions -@section Extensions - - -The X Window System is based on a core protocol which can be extended to -provide new functionality. An extension is generally represented by an -additional set of requests or event types that are implemented by an X -server supporting the extension. By definition, a client program using -an extension may not be portable to other servers. However, extensions -allow different server implementations and different sites to add their -own special features to X, without disrupting clients that rely only on -the core protocol. - -Extensions are identified by assigning them unique name strings and -major protocol numbers. A client program can request an X server to use -a protocol extension by furnishing the extension protocol number as an -argument to @var{open-display}. The X Consortium maintains a registry -of standard extension names and protocol numbers. - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item List all supported extensions. - -@item Find out if a given extension is supported. -@end itemize - - -@defun list-extensions display &key (:result-type 'list) - -@table @var -@item display -A @var{display}. -@item :result-type -The type of name sequence to return. -@end table -Returns a sequence containing the @emph{names} of all extensions -supported by the @emph{display} server. -@table @var -@item names -Type @var{sequence} of @var{string}. -@end table - -@end defun - - -@defun query-extension display name - -@table @var -@item display -A @var{display}. -@item name -An extension name string. -@end table - - -Returns the @emph{major-opcode} for the given extension @emph{name} -support by the @emph{display} server. If the extension is not -supported, only @var{nil} values are returned. The extension -@emph{name} must contain only ISO Latin-1 characters; case is -significant. - -If the extension involves additional event types, the -@emph{first-event} returned is the base event type code for new -events; otherwise, the @emph{first-event} is @var{nil}. If the -extension involves additional error codes, the @emph{first-error} -returned is the base code for new errors; otherwise, the -@emph{first-error} is @var{nil}. The formats of error and event -messages sent by the server are completely defined by the extension. -@table @var -@item major-opcode -@itemx first-event -@itemx first-error -Type @var{card8} or @var{null}. -@end table - -@end defun - - -@node SHAPE - The X11 Nonrectangular Window Shape Extension, RENDER - A new rendering system for X11, Extensions (Extensions), Extensions -@section SHAPE - The X11 Nonrectangular Window Shape Extension - - -This documentation is yet to be written. - -@node RENDER - A new rendering system for X11, DPMS - The X11 Display Power Management Signaling Extension, SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions -@section RENDER - A new rendering system for X11 - - -XRENDER is an experimental step in building a newer and modern graphics rendering -system that can keep up with the demands of visual appearance on current user -interfaces. - -The X Rendering Extension (Render) introduces digital image composition as -the foundation of a new rendering model within the X Window System. -Rendering geometric figures is accomplished by client-side tesselation into -either triangles or trapezoids. Text is drawn by loading glyphs into the -server and rendering sets of them. - -@menu -* Picture formats:: -* The picture object:: -* Glyphs and Glyphsets:: -* Using glyphs:: -* Errors (Extensions):: -@end menu - -@node Picture formats, The picture object, RENDER - A new rendering system for X11, RENDER - A new rendering system for X11 -@subsection Picture formats - -The following is what the X protocol rendering spec has to say about picture formats. -@url{http://www.xfree86.org/~keithp/render/protocol.html} - - -The @var{picture-format} object holds information needed to translate pixel values -into red, green, blue and alpha channels. The server has a list of picture -formats corresponding to the various visuals on the screen. There are two -classes of formats, Indexed and Direct. Indexed picture-formats hold a list of -pixel values and RGBA values while Direct picture-formats hold bit masks for each -of R, G, B and A. - - -The server must support a direct @var{picture-format} with 8 bits each of red, green, -blue and alpha as well as a direct @var{picture-format} with 8 bits of red, green and -blue and 0 bits of alpha. The server must also support direct @var{picture-format}s -with 1, 4 and 8 bits of alpha and 0 bits of r, g and b. - - -Pixel component values lie in the closed range [0,1]. These values are -encoded in a varying number of bits. Values are encoded in a straight -forward manner. For a component encoded in m bits, a binary encoding b -is equal to a component value of b/(2^m-1). - - -A direct @var{picture-format} with zero bits of alpha component is declared to have -alpha == 1 everywhere. A direct @var{picture-format} with zero bits of red, green and -blue is declared to have red, green, blue == 0 everywhere. If any of red, -green or blue components are of zero size, all are of zero size. Direct -@var{picture-format}s never have colormaps and are therefore screen independent. - - -Indexed @var{picture-format}s never have alpha channels and the direct component is all -zeros. Indexed @var{picture-format}s always have a colormap in which the specified -colors are allocated read- only and are therefore screen dependent. - -These are valid accessors for picture-format objects. - -@table @var -@item picture-format-display -A display -@item picture-format-id -The X protocol @var{resource-id} -@item picture-format-type -@code{(member :indexed :direct)} -@item picture-format-depth -Bitdepth as @var{card8} -@item picture-format-red-byte -A bitmask -@item picture-format-green-byte -@itemx picture-format-blue-byte -@itemx picture-format-alpha-byte -@itemx picture-format-colormap -A @var{colormap} or nil -@end table - -@node The picture object, Glyphs and Glyphsets, Picture formats, RENDER - A new rendering system for X11 -@subsection The picture object - - -The @var{picture} object contains a @var{drawable}, a @var{picture-format} and some -rendering state. More than one @var{picture} can refer to the same @var{drawable}. - - -A @var{picture} is almost like a @var{gcontext}, except that it is tied in use to -a single @var{drawable}. Another similarity it has with @var{gcontext} is that it is -a cached object. Updates are not processed until the @var{picture} is used. This also -makes it possible to query state, as there is no such request in XRENDER to do so. - - -The @var{picture} object is also a lot like a @var{drawable}, in that it is used as a -target for graphics operations. Or at least that it occurs where you would expect a -drawable in XRENDER requests. - -@defun render-create-picture drawable &key format picture ... - -@table @var -@item drawable -A @var{Drawable} -@item format -A @var{picture-format} -@item picture -An existing @var{picture} object to use, -one is created if not specified. -@item repeat -@code{(member :off :on)} -@item alpha-map -A @var{picture} or @var{:none} -@item alpha-x-origin -@var{int16} -@item alpha-y-origin -@var{int16} -@item clip-x-origin -@var{int16} -@item clip-y-origin -@var{int16} -@item clip-mask -A @var{Pixmap} or @var{:none} -@item graphics-exposures -@code{(member :off :on)} -@item subwindow-mode -@code{(member :clip-by-children :include-inferiors)} -@item poly-edge -@code{(member :sharp :smooth)} -@item poly-mode -@code{(member :precise :imprecise)} -@item dither -@var{xatom} or @var{:none} -@item component-alpha -@code{(member :off :on)} -@end table -This request creates a Picture object. If the @emph{drawable} is a Window -then the Red, Green and Blue masks must match those in the visual for the -window else a Match error is generated. - -@table @var -@item picture -A @var{picture} -@end table - -@end defun - - - -@defun render-free-picture picture This request deletes all server resources associated with the picture object. - -@table @var -@item picture -The @var{picture} object to free -@end table - - - -@end defun - -@node Glyphs and Glyphsets, Using glyphs, The picture object, RENDER - A new rendering system for X11 -@subsection Glyphs and Glyphsets - - -A glyph in XRENDER is an alpha mask and an associated orgin, advancement and numeric id. The application refers to them -by the numeric id. - -Glyphs are stored in a glyph-set. The client is responsible for making sure the glyphs it uses are stored in -the glyph-set, or there will be a Glyph-error. - -@defun render-create-glyph-set format &key glyph-set - -@table @var -@item format -A @var{picture-format} for the alpha masks that this font will use. -@item glyph-set -An optional @var{glyph-set} object to initialize with a server side glyphset resource. -@end table - - - -Creates an initially empty glyph-set for the client to use. -@emph{Format} must be a Direct format. When it contains RGB values, the glyphs are composited using -component-alpha True, otherwise they are composited using component-alpha False. -@end defun - - -@defun render-reference-glyph-set existing-glyph-set &key glyph-set - -@table @var -@item existing-glyph-set -An existing @var{glyph-set} -@item glyph-set -An optional @var{glyph-set}, just like in @var{render-create-glyph-set} -@end table - - - -Creates a new id refering to the existing-glyph-set. The glyph-set itself will not be freed until all -ids has been removed. -@end defun - -@defun render-free-glyph-set glyph-set - -@table @var -@item glyph-set -A glyphset resource to free -@end table - -Removes an id to a glyph-set. When all ids have been removed the glyph-set itself is removed. - - - -@end defun - -@defun render-add-glyph glyph-set id &key x-origin y-origin x-advance y-advance data - -@table @var -@item glyph-set -A @var{glyph-set} -@item id -@var{card32} -@item x-orgin -@var{int16} -@item y-orgin -@var{int16} -@item x-advance -@var{int16} -@item y-advance -@var{int16} -@item data -An @var{array} of @var{card8} bytes. -@end table - -Associates id with the given description of a glyph. An existing glyph -with the same id is replaced. - -At the time of writing, only 8bit alpha masks are -supported. Experimentation with glyph-sets in other pict-formats -needed. - - - -@end defun - -@defun render-add-glyph-from-picture glyph-set picture &key x-origin y-origin x-advance y-advance width height - -@table @var -@item glyph-set -glyph-set -@item picture -picture -@item x-origin -int16 -@item y-origin -int16 -@item x-advance -int16 -@item y-advance -int16 -@item x -int16 -@item y -int16 -@item width -card16 -@item height -card16 -@end table - - - -This request add a glyph to @emph{glyph-set} by copying it from the @emph{x,y} location in the @emph{picture}. - -Existing glyphs with the same names are replaced. -The source @emph{picture} may be in a different @var{picture-format} than @emph{glyph-set}, in which case the images are converted to the glyph-set's format. -@end defun - -@defun render-free-glyphs glyph-set glyphs - -@table @var -@item glyph-set -A @var{glyph-set} -@item glyphs -sequence of @var{card32} -@end table - - - - -This request removes @emph{glyphs} from @emph{glyph-set}. -Each glyph must exist in @emph{glyph-set} (else a @var{Match} error results). -@end defun - -@node Using glyphs, Errors (Extensions), Glyphs and Glyphsets, RENDER - A new rendering system for X11 -@subsection Using glyphs - -@defun render-composite-glyph dest glyph-set source dest-x dest-y sequence &key op src-x src-y mask-format start end - -@table @var -@item dest -picture -@item glyph-set -glyph-set -@item source -picture -@item dest-x -int16 -@item dest-y -int16 -@item sequence - -@item op -(member clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum) -@item src-x -int16 -@item src-y -iny16 -@item mask-format -picture-format -@item start -blah -@item end -blah -@end table - - - - -Requests the sequence of glyphs to be drawn with the glyph-set. -@end defun - - - -@node Errors (Extensions), , Using glyphs, RENDER - A new rendering system for X11 -@subsection Errors - -What new errors Xrender defines... - - -@node DPMS - The X11 Display Power Management Signaling Extension, BIG-REQUESTS - Big Requests Extension, RENDER - A new rendering system for X11, Extensions -@section DPMS - The X11 Display Power Management Signaling Extension - -@defun dpms-get-version display &optional (major-version 1) (minor-version 1) -@table @var -@item display -@var{display} -@item major-version -@var{card16} -@item minor-version -@var{card16} -@end table - - -Return two values: the major and minor version of the DPMS -implementation the server supports. - -If supplied, the @var{major-version} and @var{minor-version} -indicate what version of the protocol the client wants the server to -implement. -@end defun - -@defun dpms-capable display -@table @var -@item display -@var{display} -@end table - - -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. -@end defun - - -@defun dpms-get-timeouts display -@table @var -@item display -@var{display} -@end table - - -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. -@end defun - -@defun dpms-set-timeouts display standby suspend off -@table @var -@item display -@var{display} -@item standby -@var{card16} -@item suspend -@var{card16} -@item off -@var{card16} -@end table - - -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. -@end defun - -@defun dpms-enable display -@table @var -@item display -@var{display} -@end table - - -Enable the DPMS characteristics of the server using the server's -currently stored timeouts. If DPMS is already enabled, no change is -affected. -@end defun - -@defun dpms-disable display -@table @var -@item display -@var{display} -@end table - - -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. -@end defun - -@defun dpms-force-level display power-level -@table @var -@item display -@var{display} -@item power-level -(member :dpms-mode-on :dpms-mode-standby :dpms-mode-suspend :dpms-mode-off) -@end table - - -Forces a specific DPMS level on the server. -@end defun - -@defun dpms-info display -@table @var -@item display -@var{display} -@end table - - -Returns two values: 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. -@end defun - -@node BIG-REQUESTS - Big Requests Extension, , DPMS - The X11 Display Power Management Signaling Extension, Extensions -@section BIG-REQUESTS - Big Requests Extension - -@defun display-extended-max-request-length display -@end defun -@defun enable-big-requests display -@end defun - -@chapter Errors -@node Errors, Undocumented, Extensions, Top - -@menu -* Introduction (Errors):: -@end menu - -@node Introduction (Errors), , Errors, Errors -@section Introduction - -CLX error conditions are hierarchial. The base error condition is -@var{x-error}, and all other conditions are built on top of -@var{x-error}. @var{x-error} can be built on a lower-level condition -that is implementation dependent (this is probably the @var{error} -condition). - -@defmac define-condition name (parent-types*) [({slot-specifier*}) {option*}] - -Any new condition type must be defined with the -@var{define-condition} macro. A condition type has a name, parent -types, report message, and any number of slot items. See the -@emph{Lisp} @emph{Reference} manual for further information -regarding @var{define-condition}. - -The following are the predefined error conditions that can occur in CLX. -@end defmac - - -@deftp {Condition} access-error - -An @var{access-error} can occur for several reasons: -@itemize @bullet - -@item -A client attempted to grab a key/button combination already -grabbed by another client - -@item -A client attempted to free a colormap entry that it did not already allocate - -@item -A client attempted to store into a read-only colormap entry - -@item -A client attempted to modify the access control list from other -than the local (or otherwise authorized) host - -@item -A client attempted to select an event type that another client -has already selected, and, that at most, one client can select -at a time -@end itemize - -An @var{access-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} alloc-error - -The server failed to allocate the requested resource or server memory. - -An @var{alloc-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} atom-error - -A value for an @emph{atom} argument does not name a defined atom. - -An @var{atom-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} closed-display - -The @var{closed-display} condition is signaled when trying to read -or write a closed display (that is, @var{close-display} has been -called on the @var{display} object, or a server-disconnect -occurred). The @var{closed-display} object is reported with the -error. - -A @var{closed-display} condition is a special case of the more -general @var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} colormap-error - -A value for a @emph{colormap} argument does not name a defined -colormap. - -A @var{colormap-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} connection-failure - -Signaled when an X11 server refuses a connection. The following -items are reported along with the error: -@itemize @bullet - -@item @emph{major-version} -- The major version of the X server code. - -@item @emph{minor-version} -- The minor version of the X server code. - -@item @emph{host} -- The host name for the X server. - -@item @emph{display} -- The display on which the error occurred. - -@item @emph{reason} -- A string indicating why the connection failed. -@end itemize - -A @var{connection-failure} is a special case of the more general -@var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} cursor-error - -A value for a @emph{cursor} argument does not name a defined cursor. - -A @var{cursor-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} device-busy - -Signaled by (@code{setf} (@var{pointer-mapping} @emph{display}) -@var{mapping}) when the @var{set-pointer-mapping} request returns -a busy status. A similar condition occurs in -@var{set-modifier-mapping}, but in this case, it returns a boolean -indicating success, rather than signaling an error. The -@var{device-busy} condition returns the display object as part of -the error. - -A @var{device-busy} condition is a special case of the more general -@var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} drawable-error - -A value for a @emph{drawable} argument does not name a defined window or pixmap. - -A @var{drawable-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} font-error - -A value for a @emph{font} or @emph{gcontext} argument does not name a defined font. - -A @var{font-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} gcontext-error - -A value for a @emph{gcontext} argument does not name a defined GContext. - -A @var{gcontext-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} id-choice-error - -The value chosen for a resource identifier is either not included in -the range assigned to the client or is already in use. Under normal -circumstances, this cannot occur and should be considered a server -or CLX library error. - -An @var{id-choice-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} implementation-error - -The server does not implement some aspect of the request. A server -that generates this error for a core request is deficient. As such, -this error is not listed for any of the requests. However, clients -should be prepared to receive such errors and either handle or -discard them. - -An @var{implementation-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} length-error - -The length of a request is shorter or longer than that minimally -required to contain the arguments. This usually means an internal -CLX error. - -A @var{length-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} lookup-error - -CLX has the option of caching different resource types (see -@var{*clx-cached-types*}) in a hash table by resource ID. When -looking up an object in the hash table, if the type of the object is -wrong, a @var{lookup-error} is signaled. - -For example: The cursor with ID 123 is interned in the hash -table. An event is received with a field for window 123. When 123 is -looked up in the hash table, a cursor is found. Since a window was -expected, a @var{lookup-error} is signaled. This error indicates a -problem with the extension code being used. The following items are -reported along with the error: -@itemize @bullet - -@item @emph{id} -- The resource ID. - -@item @emph{display} -- The display being used. - -@item @emph{type} -- The resource type. - -@item @emph{object} -- The @var{resource} object. -@end itemize - -A @var{lookup-error} is a special case of the more general -@var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} match-error - -In a graphics request, the root and depth of the GContext does not -match that of the drawable. An @var{:input-only} window is used as -a drawable. Some argument or pair of arguments has the correct type -and range but fails to match in some other way required by the -request. An @var{:input-only} window locks this attribute. The -values do not exist for an @var{:input-only} window. - -A @var{match-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} missing-parameter - -One or more of the required keyword parameters is missing or -@var{nil}. The missing parameters are reported along with the -error. - -A @var{missing-parameter} condition is a special case of the more -general @var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} name-error - -A font or color of the specified name does not exist. - -A @var{name-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} pixmap-error - -A value for a @emph{pixmap} argument does not name a defined pixmap. - -A @var{pixmap-error} is a special case of the more general -@var{resource-error}. (@pxref{resource-error}.) -@end deftp - - -@deftp {Condition} reply-length-error (x-error) (slots*) - -The reply to a request has an unexpected length. The following items -are reported along with the error: -@itemize @bullet - -@item @emph{reply-length} -- The actual reply length. - -@item @emph{expected-length} -- The expected reply length. - -@item @emph{display} -- The display on which the error occurred. -@end itemize - -A @var{reply-length-error} is a special case of the more general -@var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} reply-timeout - -The @var{*reply-timeout*} parameter specifies the maximum number of -seconds to wait for a request reply, or @var{nil} to wait forever -(the default). When a reply has not been received after -*@var{reply-timeout}* seconds, the @var{reply-timeout} condition -is signaled. The @emph{timeout} @emph{period} and @emph{display} are -reported along with the error. - -A @var{reply-timeout} condition is a special case of the more -general @var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} request-error -@anchor{request-error} - -The following items are reported along with the error: - -The major or minor opcode does not specify a valid request. -@itemize @bullet - -@item @emph{display} -- The display on which the error occurred. - -@item @emph{error-key} -- The error (sub)type. - -@item @emph{major} -- The major opcode. - -@item @emph{minor} -- The minor opcode. - -@item @emph{sequence} -- The actual sequence number. - -@item @emph{current-sequence} -- The current sequence number. -@end itemize - -A @var{request-error} condition is a special case of the more -general @var{x-error} (@pxref{x-error}). -@end deftp - -@deftp {Condition} resource-error -@anchor{resource-error} - -All X11 errors for incorrect resource IDs are built on top of -@var{resource-error}. These are @var{colormap-error}, -@var{cursor-error}, @var{drawable-error}, @var{font-error}, -@var{gcontext-error}, @var{id-choice-error}, @var{pixmap-error} -and @var{window-error}. @var{resource-error} is never signaled -directly. - -A @var{resource-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} sequence-error - -All X11 request replies contain the sequence number of their -request. If a reply's sequence does not match the request count, a -@var{sequence-error} is signaled. A @var{sequence-error} usually -indicates a locking problem with a multi-processing Lisp. The -following items are reported along with the error: -@itemize @bullet - -@item @emph{display} -- The display on which the error occurred. - -@item @emph{req-sequence} -- The sequence number in the reply. - -@item @emph{msg-sequence} -- The current sequence number. -@end itemize - -A @var{sequence-error} condition is a special case of the more -general @var{x-error}. (@pxref{x-error}) -@end deftp - - -@deftp {Condition} server-disconnect - -The connection to the server was lost. The display on which the -error occurred is reported along with the error. - -A @var{server-disconnect} condition is a special case of the more -general @var{x-error}. (@pxref{x-error}) -@end deftp - - -@deftp {Condition} unexpected-reply - -A reply was found when none was expected. This indicates a problem -with the extension code. The following items are reported along with -the error: - -@table @code -@item display -The display on which the error occurred. - -@item req-sequence -The sequence number in the reply. - -@item msg-sequence -The current sequence number. - -@item length -The message length of the reply. -@end table - - -An @var{unexpected-reply} condition is a special case of the more general -@var{x-error}. (@pxref{x-error}.) -@end deftp - - -@deftp {Condition} unknown-error (request-error) (error-code) - -An error was received from the server with an unknown error -code. This indicates a problem with the extension code. The -undefined error code is reported. - -An @var{unknown-error} is a special case of the more general -@var{request-error}. (@pxref{request-error}) -@end deftp - - -@deftp {Condition} value-error (request-error) (value) - -Some numeric value falls outside the range of values accepted by the -request. Unless a specific range is specified for an argument, the -full range defined by the argument's type is accepted. Any argument -defined as a set of alternatives can generate this error. The -erroneous value is reported. - -A @var{value-error} is a special case of the more general -@var{request-error}. (@pxref{request-error}) -@end deftp - - -@deftp {Condition} window-error (resource-error) - - -A value for a @emph{window} argument does not name a defined window. - -A @var{window-error} is a special case of the more general -@var{resource-error}. (@pxref{resource-error}.) -@end deftp - - -@deftp {Condition} x-error -@anchor{x-error} - -This is the most general error condition upon which all other conditions are defined. -@end deftp - - - -@ignore -@var{PROTOCOL VS. CLX FUNCTIONAL} - -@var{CROSS-REFERENCE LISTING} - -@var{X11 Request Name CLX Function Name} - -AllocColor @var{alloc-color} -AllocColorCells @var{alloc-color-cells} -AllocColorPlanes@var{alloc-color-planes} -AllocNamedColor @var{alloc-color} -AllowEvents @var{allow-events} -Bell @var{bell} -ChangeAccessControl (@code{setf} (@var{access-control} @emph{display}) -ChangeActivePointerGrab @var{change-active-pointer-grab} -ChangeCloseDownMode (@code{setf} (@var{close-down-mode} @emph{display})) -ChangeGC @var{force-gcontext-changes} -(See @var{with-gcontext}) -(@code{setf} (@var{gcontext-function} @emph{gc})) -(@code{setf} (@var{gcontext-plane-mask} @emph{gc})) -(@code{setf} (@var{gcontext-foreground} @emph{gc})) -(@code{setf} (@var{gcontext-background} @emph{gc})) -(@code{setf} (@var{gcontext-line-width} @emph{gc})) -(@code{setf} (@var{gcontext-line-style} @emph{gc})) -(@code{setf} (@var{gcontext-cap-style} @emph{gc})) -(@code{setf} (@var{gcontext-join-style} @emph{gc})) -(@code{setf} (@var{gcontext-fill-style} @emph{gc})) -(@code{setf} (@var{gcontext-fill-rule} @emph{gc})) -(@code{setf} (@var{gcontext-tile} @emph{gc})) -(@code{setf} (@var{gcontext-stipple} @emph{gc})) -(@code{setf} (@var{gcontext-ts-x} @emph{gc})) -(@code{setf} (@var{gcontext-ts-y} @emph{gc})) -(@code{setf} (@var{gcontext-font} @emph{gc} &optional -@var{metrics-p})) -(@code{setf} (@var{gcontext-subwindow-mode} @emph{gc})) -(@code{setf} (@var{gcontext-exposures} @emph{gc}))) -(@code{setf} (@var{gcontext-clip-x} @emph{gc})) -(@code{setf} (@var{gcontext-clip-y} @emph{gc})) -(@code{setf} (@var{gcontext-clip-mask} @emph{gc} -&optional @var{ordering})) -(@code{setf} (@var{gcontext-dash-offset} @emph{gc})) -(@code{setf} (@var{gcontext-dashes} @emph{gc})) -(@code{setf} (@var{gcontext-arc-mode} @emph{gc})) -(@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) - -@var{X11 Request Name CLX Function Name} - -ChangeHosts @var{add-access-host} -ChangeHosts @var{remove-access-host} -ChangeKeyboardControl @var{change-keyboard-control} -ChangePointerControl @var{change-pointer-control} -ChangeProperty @var{change-property} -ChangeSaveSet @var{remove-from-save-set} -ChangeSaveSet @var{add-to-save-set} -ChangeWindowAttributes (See @var{with-state}) -(@code{setf} (@var{window-background} @emph{window})) -(@code{setf} (@var{window-border} @emph{window})) -(@code{setf} (@var{window-bit-gravity} @emph{window})) -(@code{setf} (@var{window-gravity} @emph{window})) -(@code{setf} (@var{window-backing-store} @emph{window})) -(@code{setf} (@var{window-backing-planes} @emph{window})) -(@code{setf} (@var{window-backing-pixel} @emph{window})) -(@code{setf} (@var{window-override-redirect} @emph{window}) -@code{(setf (window-save-under} @emph{window}@var{))} -(@code{setf} (@var{window-colormap} @emph{window})) -(@code{setf} (@var{window-cursor} @emph{window})) -(@code{setf} (@var{window-event-mask} @emph{window})) -(@code{setf} (@var{window-do-not-propagate-mask} -@emph{window})) -CirculateWindow @var{circulate-window-down} -CirculateWindow @var{circulate-window-up} -ClearToBackground @var{clear-area} -CloseFont @var{close-font} -ConfigureWindow (See @var{with-state}) -(@code{setf} (@var{drawable-x} @emph{drawable})) -(@code{setf} (@var{drawable-y} @emph{drawabl}e)) -(@code{setf} (@var{drawable-width} @emph{drawable})) -(@code{setf} (@var{drawable-height} @emph{drawable})) -(@code{setf} (@var{drawable-depth} @emph{drawable})) -(@code{setf} (@var{drawable-border-width} @emph{drawable})) -(@code{setf} (@var{window-priority} @emph{window} &optional -@var{sibling})) -ConvertSelection@var{convert-selection} -CopyArea @var{copy-area} -CopyColormapAndFree @var{copy-colormap-and-free} -CopyGC@var{copy-gcontext} -CopyGC@var{copy-gcontext-components} -CopyPlane @var{copy-plane} -CreateColormap @var{create-colormap} -CreateCursor @var{create-cursor} -CreateGC @var{create-gcontext} -CreateGlyphCursor @var{create-glyph-cursor} -CreatePixmap @var{create-pixmap} -CreateWindow @var{create-window} -DeleteProperty @var{delete-property} -DestroySubwindows @var{destroy-subwindows} -DestroyWindow @var{destroy-window} -FillPoly @var{draw-lines} -ForceScreenSaver@var{reset-screen-saver} -ForceScreenSaver@var{activate-screen-saver} -FreeColormap @var{free-colormap} -FreeColors @var{free-colors} -FreeCursor @var{free-cursor} - -@var{X11 Request Name CLX Function Name} - -FreeGC@var{free-gcontext} -FreePixmap @var{free-pixmap} -GetAtomName @var{atom-name} -GetFontPath @var{font-path} -GetGeometry (See @var{with-state}) -@var{drawable-root} -@var{drawable-x} -@var{drawable-y} -@var{drawable-width} -@var{drawable-height} -@var{drawable-depth} -@var{drawable-border-width} -GetImage @var{get-raw-image} -GetInputFocus @var{input-focus} -GetKeyboardControl @var{keyboard-control} -GetKeyboardMapping @var{keyboard-mapping} -GetModifierMapping @var{modifier-mapping} -GetMotionEvents @var{motion-events} -GetPointerControl @var{pointer-control} -GetPointerMapping @var{pointer-mapping} -GetProperty @var{get-property} -GetScreenSaver @var{screen-saver} -GetSelectionOwner @var{selection-owner} -GetWindowAttributes (See @var{with-state}) -@var{window-visual} -@var{window-class} -@var{window-bit-gravity} -@var{window-gravity} -@var{window-backing-store} -@var{window-backing-planes} -@var{window-backing-pixel} -@var{window-save-under} -@var{window-override-redirect} -@var{window-event-mask} -@var{window-do-not-propagate-mask} -@var{window-colormap} -@var{window-colormap-installed-p} -@var{window-all-event-masks} -@var{window-map-state} -GrabButton @var{grab-button} -GrabKey @var{grab-key} -GrabKeyboard @var{grab-keyboard} -GrabPointer @var{grab-pointer} -GrabServer @var{grab-server} -ImageText16 @var{draw-image-glyphs} -ImageText16 @var{draw-image-glyph} -ImageText8 @var{draw-image-glyphs} -InstallColormap @var{install-colormap} -InternAtom @var{find-atom} -InternAtom @var{intern-atom} -KillClient @var{kill-temporary-clients} -KillClient @var{kill-client} -ListExtensions @var{list-extensions} -ListFonts @var{list-font-names} -ListFontsWithInfo @var{list-fonts} -ListHosts @var{access-control} - -@var{X11 Request Name CLX Function Name} - -ListHosts @var{access-hosts} -ListInstalledColormaps @var{installed-colormaps} -ListProperties @var{list-properties} -LookupColor @var{lookup-color} -MapSubwindows @var{map-subwindows} -MapWindow @var{map-window} -OpenFont @var{open-font} -PolyArc @var{draw-arc} -PolyArc @var{draw-arcs} -PolyFillArc @var{draw-arc} -PolyFillArc @var{draw-arcs} -PolyFillRectangle @var{draw-rectangle} -PolyFillRectangle @var{draw-rectangles} -PolyLine @var{draw-line} -PolyLine @var{draw-lines} -PolyPoint @var{draw-point} -PolyPoint @var{draw-points} -PolyRectangle @var{draw-rectangle} -PolyRectangle @var{draw-rectangles} -PolySegment @var{draw-segments} -PolyText16 @var{draw-glyph} -PolyText16 @var{draw-glyphs} -PolyText8 @var{draw-glyphs} -PutImage @var{put-raw-image} -QueryBestSize @var{query-best-cursor} -QueryBestSize @var{query-best-stipple} -QueryBestSize @var{query-best-tile} -QueryColors @var{query-colors} -QueryExtension @var{query-extension} -QueryFont @var{font-name} -@var{font-name} -@var{font-direction} -@var{font-min-char} -@var{font-max-char} -@var{font-min-byte1} -@var{font-max-byte1} -@var{font-min-byte2} -@var{font-max-byte2} -@var{font-all-chars-exist-p} -@var{font-default-char} -@var{font-ascent} -@var{font-descent} -@var{font-properties} -@var{font-property} -@var{char-left-bearing} -@var{char-right-bearing} -@var{char-width} -@var{char-ascent} -@var{char-descent} -@var{char-attributes} -@var{min-char-left-bearing} -@var{min-char-right-bearing} -@var{min-char-width} -@var{min-char-ascent} -@var{min-char-descent} -@var{min-char-attributes} - -@var{X11 Request Name CLX Function Name} - -@var{max-char-left-bearing} -@var{max-char-right-bearing} -@var{max-char-width} -@var{max-char-ascent} -@var{max-char-descent} -@var{max-char-attributes} -QueryKeymap @var{query-keymap} -QueryPointer @var{global-pointer-position} -QueryPointer @var{pointer-position} -QueryPointer @var{query-pointer} -QueryTextExtents@var{text-extents} -QueryTextExtents@var{text-width} -QueryTree @var{query-tree} -RecolorCursor @var{recolor-cursor} -ReparentWindow @var{reparent-window} -RotateProperties@var{rotate-properties} -SendEvent @var{send-event} -SetClipRectangles @var{force-gcontext-changes} -(See @var{with-gcontext}) -(@code{setf} (@var{gcontext-clip-x} @emph{gc})) -(@code{setf} (@var{gcontext-clip-y} @emph{gc})) -(@code{setf} (@var{gcontext-clip-mask} @emph{gc} &optional -@var{ordering})) -(@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) -SetDashes @var{force-gcontext-changes} -(See @var{with-gcontext}) -(@code{setf} (@var{gcontext-dash-offset} @emph{gc})) -(@code{setf} (@var{gcontext-dashes} @emph{gc})) -SetFontPath (@code{setf} (@var{font-path} @emph{font}) -SetInputFocus @var{set-input-focus} -SetKeyboardMapping @var{change-keyboard-mapping} -SetModifierMapping @var{set-modifier-mapping} -SetPointerMapping @var{set-pointer-mapping} -SetScreenSaver @var{set-screen-saver} -SetSelectionOwner @var{set-selection-owner} -StoreColors @var{store-color} -StoreColors @var{store-colors} -StoreNamedColor @var{store-color} -StoreNamedColor @var{store-colors} -TranslateCoords @var{translate-coordinates} -UngrabButton @var{ungrab-button} -UngrabKey @var{ungrab-key} -UngrabKeyboard @var{ungrab-keyboard} -UngrabPointer @var{ungrab-pointer} -UngrabServer @var{ungrab-server} -UninstallColormap @var{uninstall-colormap} -UnmapSubwindows @var{unmap-subwindows} -UnmapWindow @var{unmap-window} -WarpPointer @var{warp-pointer} -WarpPointer @var{warp-pointer-if-inside} -WarpPointer @var{warp-pointer-relative} -WarpPointer @var{warp-pointer-relative-if-inside} -ListHosts @var{access-control} -ListHosts @var{access-hosts} -ForceScreenSaver@var{activate-screen-saver} -ChangeHosts @var{add-access-host} - -@var{X11 Request Name CLX Function Name} - -ChangeSaveSet @var{add-to-save-set} -AllocColor @var{alloc-color} -AllocNamedColor @var{alloc-color} -AllocColorCells @var{alloc-color-cells} -AllocColorPlanes@var{alloc-color-planes} -AllowEvents @var{allow-events} -GetAtomName @var{atom-name} -Bell @var{bell} -ChangeActivePointerGrab @var{change-active-pointer-grab} -ChangeKeyboardControl @var{change-keyboard-control} -SetKeyboardMapping @var{change-keyboard-mapping} -ChangePointerControl @var{change-pointer-control} -ChangeProperty @var{change-property} -QueryFont @var{char-ascent} -QueryFont @var{char-attributes} -QueryFont @var{char-descent} -QueryFont @var{char-left-bearing} -QueryFont @var{char-right-bearing} -QueryFont @var{char-width} -CirculateWindow @var{circulate-window-down} -CirculateWindow @var{circulate-window-up} -ClearToBackground @var{clear-area} -CloseFont @var{close-font} -ConvertSelection@var{convert-selection} -CopyArea @var{copy-area} -CopyColormapAndFree @var{copy-colormap-and-free} -CopyGC@var{copy-gcontext} -CopyGC@var{copy-gcontext-components} -CopyPlane @var{copy-plane} -CreateColormap @var{create-colormap} -CreateCursor @var{create-cursor} -CreateGC @var{create-gcontext} -CreateGlyphCursor @var{create-glyph-cursor} -CreatePixmap @var{create-pixmap} -CreateWindow @var{create-window} -DeleteProperty @var{delete-property} -DestroySubwindows @var{destroy-subwindows} -DestroyWindow @var{destroy-window} -PolyArc @var{draw-arc} -PolyArc @var{draw-arcs} -PolyText16 @var{draw-glyph} -PolyText16 @var{draw-glyphs} -PolyText8 @var{draw-glyphs} -ImageText16 @var{draw-image-glyph} -ImageText16 @var{draw-image-glyphs} -ImageText8 @var{draw-image-glyphs} -PolyLine @var{draw-line} -PolyLine @var{draw-lines} -PolyPoint @var{draw-point} -PolyPoint @var{draw-points} -PolyFillRectangle @var{draw-rectangle} -PolyRectangle @var{draw-rectangle} -PolyFillRectangle @var{draw-rectangles} -PolyRectangle @var{draw-rectangles} -PolySegment @var{draw-segments} -GetGeometry @var{drawable-border-width} - -@var{X11 Request Name CLX Function Name} - -GetGeometry @var{drawable-depth} -GetGeometry @var{drawable-height} -GetGeometry @var{drawable-root} -GetGeometry @var{drawable-width} -GetGeometry @var{drawable-x} -GetGeometry @var{drawable-y} -FillPoly @var{fill-polygon} -InternAtom @var{find-atom} -QueryFont @var{font-all-chars-exist-p} -QueryFont @var{font-ascent} -QueryFont @var{font-default-char} -QueryFont @var{font-descent} -QueryFont @var{font-direction} -QueryFont @var{font-max-byte1} -QueryFont @var{font-max-byte2} -QueryFont @var{font-max-char} -QueryFont @var{font-min-byte1} -QueryFont @var{font-min-byte2} -QueryFont @var{font-min-char} -QueryFont @var{font-name} -QueryFont @var{font-name} -GetFontPath @var{font-path} -QueryFont @var{font-properties} -QueryFont @var{font-property} -ChangeGC @var{force-gcontext-changes} -SetClipRectangles @var{force-gcontext-changes} -SetDashes @var{force-gcontext-changes} -FreeColormap @var{free-colormap} -FreeColors @var{free-colors} -FreeCursor @var{free-cursor} -FreeGC@var{free-gcontext} -FreePixmap @var{free-pixmap} -GetProperty @var{get-property} -GetImage @var{get-raw-image} -QueryPointer @var{global-pointer-position} -GrabButton @var{grab-button} -GrabKey @var{grab-key} -GrabKeyboard @var{grab-keyboard} -GrabPointer @var{grab-pointer} -GrabServer @var{grab-server} -GrabServer @var{with-server-grabbed} -GetInputFocus @var{input-focus} -InstallColormap @var{install-colormap} -ListInstalledColormaps @var{installed-colormaps} -InternAtom @var{intern-atom} -GetKeyboardControl @var{keyboard-control} -GetKeyboardMapping @var{keyboard-mapping} -KillClient @var{kill-client} -KillClient @var{kill-temporary-clients} -ListExtensions @var{list-extensions} -ListFonts @var{list-font-names} -ListFontsWithInfo @var{list-fonts} -ListProperties @var{list-properties} -LookupColor @var{lookup-color} -MapSubwindows @var{map-subwindows} -MapWindow @var{map-window} - -@var{X11 Request Name CLX Function Name} - -QueryFont @var{max-char-ascent} -QueryFont @var{max-char-attributes} -QueryFont @var{max-char-descent} -QueryFont @var{max-char-left-bearing} -QueryFont @var{max-char-right-bearing} -QueryFont @var{max-char-width} -QueryFont @var{min-char-ascent} -QueryFont @var{min-char-attributes} -QueryFont @var{min-char-descent} -QueryFont @var{min-char-left-bearing} -QueryFont @var{min-char-right-bearing} -QueryFont @var{min-char-width} -GetModifierMapping @var{modifier-mapping} -GetMotionEvents @var{motion-events} -OpenFont @var{open-font} -GetPointerControl @var{pointer-control} -GetPointerMapping @var{pointer-mapping} -QueryPointer @var{pointer-position} -PutImage @var{put-raw-image} -QueryBestSize @var{query-best-cursor} -QueryBestSize @var{query-best-stipple} -QueryBestSize @var{query-best-tile} -QueryColors @var{query-colors} -QueryExtension @var{query-extension} -QueryKeymap @var{query-keymap} -QueryPointer @var{query-pointer} -QueryTree @var{query-tree} -RecolorCursor @var{recolor-cursor} -ChangeHosts @var{remove-access-host} -ChangeSaveSet @var{remove-from-save-set} -ReparentWindow @var{reparent-window} -ForceScreenSaver@var{reset-screen-saver} -RotateProperties@var{rotate-properties} -GetScreenSaver @var{screen-saver} -GetSelectionOwner @var{selection-owner} -SendEvent @var{send-event} -ChangeAccessControl @var{set-access-control} -ChangeCloseDownMode @var{set-close-down-mode} -SetInputFocus @var{set-input-focus} -SetModifierMapping @var{set-modifier-mapping} -SetPointerMapping @var{set-pointer-mapping} -SetScreenSaver @var{set-screen-saver} -SetSelectionOwner @var{set-selection-owner} -StoreColors @var{store-color} -StoreColors @var{store-colors} -StoreNamedColor @var{store-color} -StoreNamedColor @var{store-colors} -QueryTextExtents@var{text-extents} -QueryTextExtents@var{text-width} -TranslateCoords @var{translate-coordinates} -UngrabButton @var{ungrab-button} -UngrabKey @var{ungrab-key} -UngrabKeyboard @var{ungrab-keyboard} -UngrabPointer @var{ungrab-pointer} -UngrabServer @var{ungrab-server} -UngrabServer @var{with-server-grabbed} - -@var{X11 Request Name CLX Function Name} - -UninstallColormap @var{uninstall-colormap} -UnmapSubwindows @var{unmap-subwindows} -UnmapWindow @var{unmap-window} -WarpPointer @var{warp-pointer} -WarpPointer @var{warp-pointer-if-inside} -WarpPointer @var{warp-pointer-relative} -WarpPointer @var{warp-pointer-relative-if-inside} -GetWindowAttributes @var{window-all-event-masks} -GetWindowAttributes @var{window-backing-pixel} -GetWindowAttributes @var{window-backing-planes} -GetWindowAttributes @var{window-backing-store} -GetWindowAttributes @var{window-bit-gravity} -GetWindowAttributes @var{window-class} -GetWindowAttributes @var{window-colormap} -GetWindowAttributes @var{window-colormap-installed-p} -GetWindowAttributes @var{window-do-not-propagate-mask} -GetWindowAttributes @var{window-event-mask} -GetWindowAttributes @var{window-gravity} -GetWindowAttributes @var{window-map-state} -GetWindowAttributes @var{window-override-redirect} -GetWindowAttributes @var{window-save-under} -GetWindowAttributes @var{window-visual} -ConfigureWindow (@code{setf} (@var{drawable-border-width} @emph{drawable})) -ConfigureWindow (@code{setf} (@var{drawable-depth} @emph{drawable})) -ConfigureWindow (@code{setf} (@var{drawable-height} @emph{drawable})) -ConfigureWindow (@code{setf} (@var{drawable-width} @emph{drawabl}e)) -ConfigureWindow (@code{setf} (@var{drawable-x} @emph{drawable})) -ConfigureWindow (@code{setf} (@var{drawable-y} @emph{drawable})) -SetFontPath (@code{setf} (@var{font-path} @emph{font}) @var{paths}) -ChangeGC (@code{setf} (@var{gcontext-arc-mode} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-background} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-cap-style} @emph{gc})) -SetClipRectangles (@code{setf} (@var{gcontext-clip-mask} @emph{gc} &optional -@var{ordering})) -SetClipRectangles (@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) -SetClipRectangles (@code{setf} (@var{gcontext-clip-x} @emph{gc})) -SetClipRectangles (@code{setf} (@var{gcontext-clip-y} @emph{gc})) -SetDashes (@code{setf} (@var{gcontext-dash-offset} @emph{gc})) -SetDashes (@code{setf} (@var{gcontext-dashes} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-exposures} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-fill-rule} @emph{gc}) @var{keyword}) -ChangeGC (@code{setf} (@var{gcontext-fill-style} @emph{gc}) @var{keyword}) -ChangeGC (@code{setf} (@var{gcontext-font} @emph{gc} &optional -@var{metrics-p}) -ChangeGC (@code{setf} (@var{gcontext-foreground} @emph{gc}) @var{card32}) -ChangeGC (@code{setf} (@var{gcontext-function} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-join-style} @emph{gc}) @var{keyword}) -ChangeGC (@code{setf} (@var{gcontext-line-style} @emph{gc}) @var{keyword}) -ChangeGC (@code{setf} (@var{gcontext-line-width} @emph{gc}) @var{card16}) -ChangeGC (@code{setf} (@var{gcontext-plane-mask} @emph{gc}) @var{card32}) -ChangeGC (@code{setf} (@var{gcontext-stipple} @emph{gc}) @var{pixmap}) -ChangeGC (@code{setf} (@var{gcontext-subwindow-mode} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-tile} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-ts-x} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-ts-y} @emph{gc})) -ChangeWindowAttributes (@code{setf} (@var{window-background} @emph{window})) - -@var{X11 Request Name CLX Function Name} - -ChangeWindowAttributes (@code{setf} (@var{window-backing-pixel} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-backing-planes} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-backing-store} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-bit-gravity} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-border} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-colormap} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-cursor} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-do-not-propagate-mask} -@emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-event-mask} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-gravity} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-override-redirect} @emph{window})) -ConfigureWindow (@code{setf} (@var{window-priority} @emph{window} &optional -@var{sibling})) -ChangeWindowAttributes (@code{setf} (@var{window-save-under} @emph{window})) -@end ignore - -@node Undocumented, Glossary, Errors, Top -@chapter Undocumented - -This section just lists all symbols exported from the -@var{XLIB} package but not documented in this manual. - -@defun bitmap-image &optional plist &rest patterns -@end defun - - -@defun character->keysyms character &optional display -@end defun - - -@defun character-in-map-p display character keymap - -@table @var -@item display -A @var{display}. -@end table - -@end defun - -@defun decode-core-error display event &optional arg -@end defun - -@defun default-error-handler display error-key &rest key-vals &key asynchronous &allow-other-keys -@end defun - -@defun default-keysym-index display keycode state -@end defun - -@defun default-keysym-translate display state object -@end defun - -@defun define-keysym object keysym &key lowercase translate modifiers mask display -@end defun - -@defun define-keysym-set set first-keysym last-keysym -@end defun - -@defun display-invoke-after-function display - - -Explicitly invokes the @emph{after-function} of the display. -(see @var{display-after-function}). This function is -internally called after every request. -@end defun - -@defun display-nscreens display -@end defun - -@defun display-release-number object -@end defun - -@defun event-handler handlers event-key -@end defun - -@defun get-external-event-code display event -@end defun - -@defun get-standard-colormap window property -@end defun - -@defun get-wm-class window -@end defun - -@defun icon-sizes window -@end defun - -@defun iconify-window window screen -@end defun - -@defun keysym->keycodes display keysym -@end defun - -@defun keysym-in-map-p display keysym keymap -@end defun - -@defun keysym-set keysym -@end defun - -@defun mapping-notify display request start count - -Called on a @var{:mapping-notify} event to update -the keyboard-mapping cache in @emph{display}. -@end defun - -@defun no-operation display -@end defun - -@defun parse-color colormap spec -@end defun - -@defun resource-database-timestamp database -@end defun - -@defun resource-key stringable -@end defun - -@defun rgb-colormaps window property -@end defun - -@defun root-resources screen &key database key test test-not - -Returns a resource database containing the contents of the -root window @var{RESOURCE_MANAGER} property for the given -@emph{screen}. If @emph{screen} is a display, then its -default screen is used. If an existing @emph{database} is -given, then resource values are merged with the -@emph{database} and the modified @emph{database} is -returned. - -@emph{test} and @emph{test-not} are predicates for selecting -which resources are read. Arguments are a resource name list -and a resource value. The @emph{key} function, if given, is -called to convert a resource value string to the value given -to @emph{test} or @emph{test-not}. -@end defun - -@defun rotate-cut-buffers display &optional (delta 1) (careful-p t) -@end defun - -@defun set-access-control display enabled-p -@end defun - -@defun set-close-down-mode display mode -@anchor{set-close-down-mode} -@end defun - -@defun set-pointer-mapping display map -@end defun - -@defun set-selection-owner display selection owner &optional time -@end defun - -@defun set-standard-colormap window property colormap base-pixel max-color mult-color -@end defun - -@defun set-standard-properties window &rest options -@end defun - -@defun set-wm-class window resource-name resource-class -@end defun - -@defun set-wm-properties window &rest options &key name icon-name resource-name resource-class command client-machine hints normal-hints zoom-hints (user-specified-position-p nil usppp) (user-specified-size-p nil usspp) (program-specified-position-p nil psppp) (program-specified-size-p nil psspp) x y width height min-width min-height max-width max-height width-inc height-inc min-aspect max-aspect base-width base-height win-gravity input initial-state icon-pixmap icon-window icon-x icon-y icon-mask window-group -@end defun - -@defun set-wm-resources database window &key write test test-not -@end defun - -@defun transient-for window -@end defun - -@defun translate-default src src-start src-end font dst dst-start -@end defun - -@defun undefine-keysym object keysym &key display modifiers &allow-other-keys -@end defun - -@defun visual-info-blue-mask object -@end defun - -@defun visual-info-green-mask object -@end defun - -@defun visual-info-red-mask object -@end defun - -@defun window-cursor window -@end defun - -@defun window-visual-info window -@end defun - -@defun withdraw-window window screen -@end defun - -@defun wm-client-machine window -@end defun - -@defun wm-colormap-windows window -@end defun - -@defun wm-command window -@end defun - -@defun wm-hints window -@end defun - -@defun wm-hints-flags object -@end defun - -@defun wm-icon-name window -@end defun - -@defun wm-name window -@end defun - -@defun wm-normal-hints window -@end defun - -@defun wm-protocols window -@end defun - -@defun wm-resources database window &key key test test-not -@end defun - -@defun wm-zoom-hints window -@end defun - -@ignore -XLIB:STATE-KEYSYM-P is undocumented. -XLIB:*VERSION* is undocumented. -XLIB:BITMAP-FORMAT-LSB-FIRST-P ??? [Function] -XLIB:BITMAP-FORMAT-P ??? [Function] -XLIB:BITMAP-FORMAT-PAD ???[Function] -XLIB:BITMAP-FORMAT-UNIT ??? [Function] -XLIB:CARD8->CHAR (card8) [Function] -XLIB:CHAR->CARD8 (char) [Function] -XLIB:COLORMAP-VISUAL-INFO ??? [Function] -XLIB:CUT-BUFFER (display &key (buffer 0) (type :string) (result-type 'string) -(transform #'card8->char) (start 0) end) [Function] -XLIB:DEFINE-ERROR ??? [Function] -XLIB:DEFINE-EXTENSION ??? [Function] -XLIB:DEFINE-GCONTEXT-ACCESSOR ??? [Function] -XLIB:DISPLAY-DEFAULT-SCREEN ??? [Function] -XLIB:DISPLAY-HOST ??? [Function] -XLIB:DISPLAY-REPORT-ASYNCHRONOUS-ERRORS ??? [Function] -XLIB:DISPLAY-XDEFAULTS ???[Function] -XLIB:EXTENSION-OPCODE ??? [Function] -XLIB:GCONTEXT-CLIP-ORDERING is undocumented. -XLIB:GENERALIZED-BOOLEAN is undocumented. -XLIB:ILLEGAL-REQUEST-ERROR is undocumented. -XLIB:IMAGE is undocumented. -XLIB:IMAGE-PIXMAP (drawable image &key gcontext width height depth) [Function] -XLIB:IMAGE-X is undocumented. -XLIB:IMAGE-X-P ??? [Function] -XLIB:IMAGE-XY is undocumented. -XLIB:IMAGE-XY-P ??? [Function] -XLIB:IMAGE-Z is undocumented. -XLIB:IMAGE-Z-P ??? [Function] -XLIB:INVALID-FONT is undocumented. -XLIB:KEYCODE->CHARACTER (display keycode state &key keysym-index -(keysym-index-function #'default-keysym-index)) [Function] -XLIB:MAKE-EVENT-HANDLERS (&key (type 'array) default) [Function] -XLIB:MAKE-WM-HINTS (&key ((:input #:g0) nil) ((:initial-state #:g1) nil) ((:icon-pixmap #:g2) nil) -((:icon-window #:g3) nil) ((:icon-x #:g4) nil) ((:icon-y #:g5) nil) -((:icon-mask #:g6) nil) ((:window-group #:g7) nil) ((:flags #:g8) 0)) [Function] -XLIB:MAKE-WM-SIZE-HINTS (&key ((:user-specified-position-p #:g0) nil) -((:user-specified-size-p #:g1) nil) ((:x #:g2) nil) ((:y #:g3) nil) -((:width #:g4) nil) ((:height #:g5) nil) ((:min-width #:g6) nil) -((:min-height #:g7) nil) ((:max-width #:g8) nil) ((:max-height #:g9) nil) -((:width-inc #:g10) nil) ((:height-inc #:g11) nil) ((:min-aspect #:g12) nil) -((:max-aspect #:g13) nil) ((:base-width #:g14) nil) ((:base-height #:g15) nil) -((:win-gravity #:g16) nil) ((:program-specified-position-p #:g17) nil) -((:program-specified-size-p #:g18) nil)) [Function] -XLIB:PIXMAP-FORMAT-BITS-PER-PIXEL ??? [Function] -XLIB:PIXMAP-FORMAT-DEPTH ??? [Function] -XLIB:PIXMAP-FORMAT-P ??? [Function] -XLIB:PIXMAP-FORMAT-SCANLINE-PAD ??? [Function] -XLIB:RESOURCE-DATABASE is undocumented. -XLIB:SCREEN-ROOT-VISUAL-INFO ??? [Function] -XLIB:TRANSLATION-FUNCTION is undocumented. -XLIB:VISUAL-INFO-BITS-PER-RGB ??? [Function] -XLIB:VISUAL-INFO-CLASS ???[Function] -XLIB:VISUAL-INFO-COLORMAP-ENTRIES ??? [Function] -XLIB:VISUAL-INFO-DISPLAY ??? [Function] -XLIB:VISUAL-INFO-ID ??? [Function] -XLIB:VISUAL-INFO-P ??? [Function] -XLIB:VISUAL-INFO-PLIST ???[Function] -XLIB:WINDOW-BACKGROUND is undocumented. -XLIB:WINDOW-BORDER is undocumented. -XLIB:WINDOW-PRIORITY is undocumented. -XLIB:WM-HINTS-ICON-MASK ??? [Function] -XLIB:WM-HINTS-ICON-PIXMAP ??? [Function] -XLIB:WM-HINTS-ICON-WINDOW ??? [Function] -XLIB:WM-HINTS-ICON-X ??? [Function] -XLIB:WM-HINTS-ICON-Y ??? [Function] -XLIB:WM-HINTS-INITIAL-STATE ??? [Function] -XLIB:WM-HINTS-INPUT ??? [Function] -XLIB:WM-HINTS-P ??? [Function] -XLIB:WM-HINTS-WINDOW-GROUP ??? [Function] -XLIB:WM-SIZE-HINTS is undocumented. -XLIB:WM-SIZE-HINTS-BASE-HEIGHT ??? [Function] -XLIB:WM-SIZE-HINTS-BASE-WIDTH ??? [Function] -XLIB:WM-SIZE-HINTS-HEIGHT ??? [Function] -XLIB:WM-SIZE-HINTS-HEIGHT-INC ??? [Function] -XLIB:WM-SIZE-HINTS-MAX-ASPECT ??? [Function] -XLIB:WM-SIZE-HINTS-MAX-HEIGHT ??? [Function] -XLIB:WM-SIZE-HINTS-MAX-WIDTH ??? [Function] -XLIB:WM-SIZE-HINTS-MIN-ASPECT ??? [Function] -XLIB:WM-SIZE-HINTS-MIN-HEIGHT ??? [Function] -XLIB:WM-SIZE-HINTS-MIN-WIDTH ??? [Function] -XLIB:WM-SIZE-HINTS-P ??? [Function] -XLIB:WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P ??? [Function] -XLIB:WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P ??? [Function] -XLIB:WM-SIZE-HINTS-WIDTH ??? [Function] -XLIB:WM-SIZE-HINTS-WIDTH-INC ??? [Function] -XLIB:WM-SIZE-HINTS-WIN-GRAVITY ??? [Function] -XLIB:WM-SIZE-HINTS-X ??? [Function] -XLIB:WM-SIZE-HINTS-Y ??? [Function] -@end ignore - -@node Glossary, Function Index, Undocumented, Top -@appendix Glossary - -@table @asis -@item access control list -X maintains a list of hosts from which client programs can be run. By -default, only programs on the local host can use the display, plus any -hosts specified in an initial list read by the server. This @emph{access -control list} can be changed by clients on the local host. Some -server implementations can also implement other authorization -mechanisms in addition to or in place of this mechanism. The action of -this mechanism can be conditional based on the authorization protocol -name and data received by the server at connection setup. - -@item action -A function that is designed to handle an input event. CLUE input -processing consists of matching an event with an event specification -found in a contact's @var{event-translations} slot and then calling -actions associated with the matching event specification. - -@item active grab -A grab is @emph{active} when the pointer or keyboard is actually owned -by the single grabbing client. - -@item ancestors -If W is an inferior of A, then A is an @emph{ancestor} of W. - -@item atom -A unique ID corresponding to a string name. Atoms are used to identify -properties, types, and selections. - -@item backing store -When a server maintains the contents of a window, the off-screen saved -pixels are known as a @emph{backing store}. - -@item before action -An action of a @var{contact-display} that is called when an event is -dispatched to a contact, but before any other contact input processing -is performed. - -@item bit gravity -When a window is resized, the contents of the window are not -necessarily discarded. It is possible to request the server to -relocate the previous contents to some region of the window. This -attraction of window contents for some location of a window is known -as @emph{bit} @emph{gravity}. - -@item bitmap -A pixmap of depth one. - -@item button grabbing -Buttons on the pointer can be passively @emph{grabbed} by a -client. When the button is pressed, the pointer is then actively -grabbed by the client. - -@item byte order -For image (pixmap/bitmap) data, byte order is defined by the server, -and clients with different native byte ordering must swap bytes as -necessary. For all other parts of the protocol, the byte order is -defined by the client, and the server swaps bytes as necessary. - -@item callback -A function that represents a connection between a contact and the rest -of an application program. A contact calls a callback function in -order to report the results of the user interface component that it -represents. - -@item children -First-level subwindows of a window. - -@item class event -Event translations that belong to all instances of a contact class. A -class event @var{translations} translation is created by the -@var{defevent} macro. - -@item class resources -Resources defined for each instance of a contact class. Also see -constraint resources. - -@item click -A @var{:button-press} event followed immediately by a -@var{:button-release} event for the same button, with no intervening -change in pointer position or modifier key state. - -@item client -An application program connects to the window system server by some -interprocess communication (IPC) path, such as a TCP connection or a -shared memory buffer. This program is referred to as a @emph{client} -of the window system server. More precisely, the client is the IPC -path itself. A program with multiple paths open to the server is -viewed as multiple clients by the protocol. Resource lifetimes are -controlled by connection lifetimes, not by program lifetimes. - -@item clipping regions -In a graphics context, a bitmap or list of rectangles can be specified -to restrict output to a particular region of the window. The image -defined by the bitmap or rectangles is called a @emph{clipping -region}. - -@item colormap -A set of entries defining color values. The colormap associated with a -window is used to display the contents of the window. Each pixel value -indexes the colormap to produce RGB values that drive the guns of a -monitor. Depending on hardware limitations, one or more colormaps can -be installed at one time, such that windows associated with those maps -display with correct colors. - -@item composite -A subclass of @var{contact} representing contacts that are the -parents of other contacts. A composite provides geometry management -and input focus management services for the contacts that are its -children. - -@item complete resource class -A list of symbols containing the class of the contact, the class of -the contact's @var{parent} (and so on), and the class of the -@var{contact-display} to which the contact belongs. The complete -resource class is one of the two items used as a key by a CLUE -application in order to access a contact resource value in a resource -database. - -@item complete resource name -A list of symbols containing the @var{name} of the contact, the -@var{name} of the contact's @var{parent} (and so on), and the name -of the @var{contact-display} to which the contact belongs. The -complete resource name is one of the two items used as a key by a CLUE -application in order to access a contact resource value in a resource -database. - -@item connection -The IPC path between the server and client program. A client program -typically has one connection to the server over which requests and -events are sent. - -@item constraint resources -Resources defined for each child belonging to a member of a composite -class. Constraint resources are typically used to control the -parent's geometry management policy. Also see class resources. - -@item contact -The basic CLUE object for programming a user interface. - -@item contact-display -The CLUE object type that represents a connection to an X server and -that supports an event loop for application input. - -@item contact initialization -The process of collecting initial values for all contact -attributes. No server resources (windows and so on) are actually -allocated until contact realization. - -@item contact realization -The process of allocating contact resources. This process completes -contact creation. - -@item containment -A window contains the pointer if the window is viewable and the hot -spot of the cursor is within a visible region of the window or a -visible region of one of its inferiors. The border of the window is -included as part of the window for containment. The pointer is in a -window if the window contains the pointer but no inferior contains the -pointer. - -@item content -The single child of a shell. The basic geometry management policy -implemented by the @var{shell} class constrains a shell and its -content to have the same width and height; size changes to one are -automatically applied to the other. - -@item coordinate system -The coordinate system has x horizontal and y vertical, with the origin -[0, 0] at the upper left. Coordinates are discrete and are in terms of -pixels. Each window and pixmap has its own coordinate system. For a -window, the origin is at the inside upper left, inside the border. - -@item cursor -The visible shape of the pointer on a screen. It consists of a -hot-spot, a source bitmap, a shape bitmap, and a pair of colors. The -cursor defined for a window controls the visible appearance when the -pointer is in that window. - -@item depth -The depth of a window or pixmap is number of bits per pixel it -has. The depth of a graphics context is the depth of the drawables it -can be used in conjunction with for graphics output. - -@item descendant -If W is an inferior of A, then W is a @emph{descendant} of A. - -@item device -Keyboards, mice, tablets, track-balls, button boxes, and so forth, are -all collectively known as input @emph{devices}. The core protocol only -deals with two devices: the keyboard and the pointer. - -@item direct color -A class of colormap in which a pixel value is decomposed into three -separate subfields for indexing. One subfield indexes an array to -produce red intensity values, the second subfield indexes a second -array to produce blue intensity values, and the third subfield indexes -a third array to produce green intensity values. The RGB values can be -changed dynamically. - -@item dispatching an event -The process of finding the appropriate contact and its actions. - -@item double-click -A sequence of two clicks of the same button in rapid succession. - -@item drawable -Both windows and pixmaps can be used as sources and destinations in -graphics operations. These are collectively known as -@emph{drawables}. However, an @var{:input-only} window cannot be used -as a source or destination in a graphics operation. - -@item event -Clients receive information asynchronously via @emph{events}. These -events can be either asynchronously generated from devices, or -generated as side effects of client requests. Events are grouped into -types; events are never sent to a client by the server unless the -client has specifically asked to be informed of that type of event, -but clients can force events to be sent to other clients. Events are -typically reported relative to a window. - -@item event compression -Ignoring (or compressing) certain redundant input events. Compression -of redundant events is controlled by the class slots -@var{compress-exposures} and @var{compress-motion}, which are shared -by all instances of a contact class. - -@item event loop -The fundamental application control structure: wait for an event, -figure out how to handle it, process the event, then go back and wait -for the next one. In CLUE, the event loop is implemented using the -@var{process-next-event} function. - -@item event mask -Events are requested relative to a window. The set of event types a -client requests relative to a window are described using an @emph{event -mask}. - -@item event propagation -Device-related events @emph{propagate} from the source window to -ancestor windows until some client has expressed interest in handling -that type of event, or until the event is discarded explicitly. - -@item event specification -A notation for describing a certain sort of event. CLUE input -processing consists of matching an event with an event specification -found in a contact's @var{event-translations} slot and then calling -actions associated with the matching event specification. - -@item event synchronization -Certain race conditions are possible when demultiplexing device events -to clients (in particular deciding where pointer and keyboard events -should be sent when in the middle of window management -operations). The event synchronization mechanism allows synchronous -processing of device events. - -@item event source -The smallest window containing the pointer is the @emph{source} of a -device related event. - -@item event translation -The process of determining which contact action functions will be -executed. An event translation is a list found in a contact's -@var{event-translations} slot associating an event specification with -one or more action names. Also see class event translations. - -@item exposure event -Servers do not guarantee to preserve the contents of windows when -windows are obscured or reconfigured. @emph{Exposure} events are sent -to clients to inform them when contents of regions of windows have -been lost. - -@item extension -Named @emph{extensions} to the core protocol can be defined to extend -the system. Extension to output requests, resources, and event types -are all possible, and expected. - -@item focus window -Another term for the input focus. - -@item font -A matrix of glyphs (typically characters). The protocol does no -translation or interpretation of character sets. The client simply -indicates values used to index the glyph array. A font contains -additional metric information to determine inter-glyph and inter-line -spacing. - -@item geometry management -The process whereby a composite controls the geometrical properties of -its child contacts; the composite is referred to as the geometry -manager. - -@item glyph -An image, typically of a character, in a font. - -@item grab -Keyboard keys, the keyboard, pointer buttons, the pointer, and the -server can be @emph{grabbed} for exclusive use by a client. In -general, these facilities are not intended to be used by normal -applications but are intended for various input and window managers to -implement various styles of user interfaces. - -@item gcontext -Shorthand for graphics context. - -@item graphics context -Various information for graphics output is stored in a @emph{graphics -context} (or gcontext), such as foreground pixel, background pixel, -line width, clipping region, and so forth. A graphics context can only -be used with drawables that have the same root and the same depth as -the graphics context. - -@item gray scale -A degenerate case of pseudo color, in which the red, green, and blue -values in any given colormap entry are equal, thus producing shades of -gray. The gray values can be changed dynamically. - -@item hot spot -A cursor has an associated @emph{hot spot} that defines a point in the -cursor that corresponds to the coordinates reported for the pointer. - -@item identifier -Each resource has an @emph{identifier}, a unique value associated with -it that clients use to name the resource. An identifier can be used -over any connection to name the resource. - -@item inferiors -All of the subwindows nested below a window: the children, the -children's children, and so on. - -@item initialization -See contact initialization. - -@item input event -See event. - -@item input focus -Normally a window defining the scope for processing of keyboard -input. If a generated keyboard event would normally be reported to -this window or one of its inferiors, the event is reported normally; -otherwise, the event is reported with respect to the focus window. The -input focus also can be set such that all keyboard events are -discarded and that the focus window is dynamically taken to be the -root window of whatever screen the pointer is on at each keyboard -event. - -@item input-only window -A window that cannot be used for graphics requests. @emph{input-only} -windows are invisible, and can be used to control such things as -cursors, input event generation, and grabbing. @emph{input-only} -windows cannot have @emph{input/output} windows as inferiors. - -@item input/output window -The normal kind of opaque window, used for both input and -output. Input/output windows can have both @emph{input/output} and -input-only windows as inferiors. - -@item insensitivity -See sensitivity. - -@item interactive-stream -A contact subclass designed to integrate CLUE with the conventional -stream-based I/O of Common Lisp. - -@item key grabbing -Keys on the keyboard can be passively @emph{grabbed} by a client. When -the key is pressed, the keyboard is then actively grabbed by the -client. - -@item keyboard grabbing -A client can actively @emph{grab} control of the keyboard, and key -events will be sent to that client rather than the client to which the -events would normally have been sent. - -@item keysym -An encoding of a symbol on a keycap on a keyboard. - -@item managed -A contact under geometry management control. - -@item mapped -A window is said to be @emph{mapped} if a map call has been performed -on it. Unmapped windows and their inferiors are never viewable or -visible. - -@item modifier keys -SHIFT, CONTROL, META, SUPER, HYPER, ALT, Compose, Apple, CAPS LOCK, -Shift Lock, and similar keys are called @emph{modifier keys}. - -@item monochrome -A special case of static gray, in which there are only two colormap -entries. - -@item obscure -A window is @emph{obscured} if some other window obscures it. For -example, window A obscures window B if: -@itemize @bullet - -@item Both windows are viewable @var{:input-output} windows - -@item Window A is higher in the global stacking order than window B - -@item The rectangle defined by the outside edges of window A intersects the rectangle -defined by the outside edges of window B -@end itemize - -Notice that window borders are included in the calculation, and that a window can be -obscured and yet still have visible regions. See occlude (there is a fine distinction -between obscure and occlude). - -@item occlude -A window is @emph{occluded} if some other window occludes it. For -example, window A occludes window B if: -@itemize @bullet - -@item Both windows are mapped - -@item Window A is higher in the global stacking order than window B - -@item The rectangle defined by the outside edges of window A intersects the rectangle -defined by the outside edges of window B -@end itemize - -Notice that window borders are included in the calculation. See -obscure (there is a fine distinction between occlude and obscure). - -@item override-shell -A subclass of @var{shell} used to override the window manager. This -subclass contains pop-up menus and other temporary objects that the -user can never resize and so on. - -@item padding -Some padding bytes are inserted in the data stream to maintain -alignment of the protocol requests on natural boundaries. This -increases ease of portability to some machine architectures. - -@item parent window -If C is a child of P, then P is the @emph{parent} of C. - -@item passive grab -Grabbing a key or button is a @emph{passive grab}. The grab activates -when the key or button is actually pressed. - -@item pixel value -An @emph{n}-bit value, where @emph{n} is the number of bit planes used -in (that is, the depth of) a particular window or pixmap. For a -window, a pixel value indexes a colormap to derive an actual color to -be displayed. - -@item pixmap -A three dimensional array of bits. A pixmap is normally thought of as -a two dimensional array of pixels, where each pixel can be a value -from 0 to (2@emph{n})-1, where @emph{n} is the depth (z axis) of -the pixmap. A pixmap can also be thought of as a stack of @emph{n} -bitmaps. - -@item plane -When a pixmap or window is thought of as a stack of bitmaps, each -bitmap is called a @emph{plane} or @emph{bit plane}. - -@item plane mask -Graphics operations can be restricted to only affect a subset of bit -planes of a destination. A @emph{plane mask} is a bit mask describing -which planes are to be modified, and it is stored in a graphics -context. - -@item pointer -The pointing device attached to the cursor and tracked on the screens. - -@item pointer grabbing -A client can actively @emph{grab} control of the pointer, and button -and motion events will be sent to that client rather than the client -to which the events would normally have been sent. - -@item pointing device -Typically a mouse or tablet, or some other device with effective -dimensional motion. There is only one visible cursor defined by the -core protocol, and it tracks whatever pointing device is attached as -the pointer. - -@item pop-up -One of the uses of a top-level shell (for example, a menu that pops up -when a command button contact is activated). Setting the @var{state} -of a shell to @var{:mapped} is sometimes referred to as -@emph{mapping} or @emph{popping up} the shell. Setting the -@var{state} of a shell to @var{:withdrawn} or @var{:iconic} is -sometimes referred to as @emph{unmapping} or @emph{popping down} the -shell. - -@item property -Windows can have associated @emph{properties}, consisting of a name, a -type, a data format, and some data. The protocol places no -interpretation on properties; they are intended as a general-purpose -naming mechanism for clients. For example, clients might share -information such as resize hints, program names, and icon formats with -a window manager via properties. - -@item property list -The list of properties that have been defined for a window. - -@item pseudo color -A class of colormap in which a pixel value indexes the colormap to -produce independent red, green, and blue values. That is, the colormap -is viewed as an array of triples (RGB values). The RGB values can be -changed dynamically. - -@item realization -See contact realization. - -@item redirecting control -Window managers (or client programs) may choose to enforce window -layout policy in various ways. When a client attempts to change the -size or position of a window, the operation can be @emph{redirected} -to a specified client, rather than the operation actually being -performed. - -@item reply -Information requested by a client program is sent back to the client -with a @emph{reply}. Both events and replies are multiplexed on the -same connection. Most requests do not generate replies. However, some -requests generate multiple replies. - -@item representation type -The type of representation of a resource value. For example, a color -value might be represented either as a namestring ("red"), a pixel -value, an RGB triplet, an HSV triplet, and so on. - -@item request -A command to the server is called a @emph{request}. It is a single -block of data sent over a connection. - -@item resource -A value of the user interface that can be changed by the user in a -resource database via CLX functions @var{add-resource}, -@var{get-resource}, and so forth. See server resource. - -@item resource class, complete -See complete resource class. - -@item resource database -Conceptually, a set of resource name/value pairs (or resource -bindings). CLX defines functions for storing and retrieving interface -resources from a resource database. - -@item resource name, complete -See complete resource name. - -@item RGB values -@emph{Red}, @emph{green}, and @emph{blue} intensity values used to -define color. These values are always represented as 16-bit unsigned -numbers, with zero being the minimum intensity and 65535 being the -maximum intensity. The values are scaled by the server to match the -display hardware. - -@item root -A special composite contact used to represent an entire display -screen. - -@item root window -Each screen has a @emph{root window} covering it. It cannot be -reconfigured or unmapped, but otherwise acts as a full-fledged -window. A root window has no parent. - -@item save set -The @emph{save set} of a client is a list of other client's windows -that, if they are inferiors of one of the client's windows at -connection close, should not be destroyed and that should be remapped -if it is unmapped. Save sets are typically used by window managers to -avoid lost windows if the manager should terminate abnormally. - -@item scanline -A list of pixel or bit values viewed as a horizontal row (all values -having the same y coordinate) of an image, with the values ordered by -increasing x coordinate. - -@item scanline order -An image represented in @emph{scanline order} contains scanlines -ordered by increasing y coordinate. - -@item screen -A server can provide several independent @emph{screens}, which -typically have physically independent monitors. This would be the -expected configuration when there is only a single keyboard and -pointer shared among the screens. - -@item selection - -A @emph{selection} can be thought of as an indirect property with -dynamic type. That is, rather than having the property stored in the -server, it is maintained by some client (the @emph{owner}). A -selection is global in nature, being thought of as belonging to the -user (but maintained by clients), rather than being private to a -particular window subhierarchy or a particular set of clients. When -a client asks for the contents of a selection, it specifies a -selection @emph{target type}. This target type can be used to -control the transmitted representation of the contents. - -For example, if the selection is "the last thing the user clicked -on" and that is currently an image, then the target type might -specify whether the contents of the image should be sent in XY -Format or Z Format. The target type can also be used to control the -class of contents transmitted; that is, asking for the looks (fonts, -line spacing, indentation, and so forth) of a paragraph selection, -rather than the text of the paragraph. The target type can also be -used for other purposes; the semantics is not constrained by the -protocol. - -@item sensitivity -A condition in which a user interface component of an application will -accept input. Conversely, when a contact is insensitive, events of -particular types are not dispatched to the contact and are ignored. - -@item server -The @emph{server} provides the basic windowing mechanism. It handles -IPC connections from clients, demultiplexes graphics requests onto the -screens, and multiplexes input back to the appropriate clients. - -@item server grabbing -The server can be @emph{grabbed} by a single client for exclusive -use. This prevents processing of any requests from other client -connections until the grab is complete. This is typically only a -transient state for such things as rubber-banding and pop-up menus, or -to execute requests indivisibly. - -@item server resource -Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are known -as resources. They all have unique identifiers associated with them -for naming purposes. The lifetime of a resource is bounded by the -lifetime of the connection over which the resource was created. See -resource. - -@item shell -A composite that handles the duties required by standard conventions -for top-level X windows. - -@item sibling -Children of the same parent window are known as @emph{sibling} -windows. - -@item static color -A degenerate case of pseudo color in which the RGB values are -predefined and read-only. - -@item static gray -A degenerate case of gray scale in which the gray values are -predefined and read-only. The values are typically (near-)linear -increasing ramps. - -@item stacking order -Sibling windows can @emph{stack} on top of each other. Windows above -both obscure and occlude lower windows. This is similar to paper on a -desk. The relationship between sibling windows is known as the -@emph{stacking order}. - -@item state -A slot of @var{contact} that controls the visual effect of the -contact. - -@item stipple -A bitmap that is used to tile a region to serve as an additional clip -mask for a fill operation with the foreground color. - -@item tile -A pixmap can be replicated in two dimensions to @emph{tile} a -region. The pixmap itself is also known as a tile. - -@item timer -A CLUE object that provides support for animation and other types of -time-sensitive user interfaces. A timer causes @var{:timer} events to -be dispatched to a specific contact for processing. - -@item timestamp -A time value, expressed in milliseconds, typically since the last -server reset. Timestamp values wrap around (after about 49.7 -days). The server, given its current time is represented by timestamp -T, always interprets timestamps from clients by treating half of the -timestamp space as being earlier in time than T and half of the -timestamp space as being later in time than T. One timestamp value -(named CurrentTime) is never generated by the server; this value is -reserved for use in requests to represent the current server time. - -@item top-level contact -A contact whose parent is a root. A top-level contact is usually a -composite at the top of a hierarchy of other contacts created by an -application program. - -@item top-level-session -A subclass of @var{shell} that is used to communicate with a session -manager. - -@item top-level-shell -A subclass of @var{shell} that provides full window manager -interaction. - -@item transient-shell -A subclass of @var{shell} that a window manager typically will unmap -when its owner becomes unmapped or iconified and will not allow to be -individually iconified. - -@item true color -A degenerate case of direct color in which the subfields in the pixel -value directly encode the corresponding RGB values. That is, the -colormap has predefined read-only RGB values. The values are typically -(near-)linear increasing ramps. - -@item type -An arbitrary atom used to identify the interpretation of property -data. Types are completely uninterpreted by the server; they are -solely for the benefit of clients. - -@item unmanaged -A contact that is not under geometry management control. - -@item user interface -A set of abstract interface objects used to control the dialog between -an application and its human user. - -@item viewable -A window is @emph{viewable} if it and all of its ancestors are -mapped. This does not imply that any portion of the window is actually -visible. Graphics requests can be performed on a window when it is not -viewable, but output will not be retained unless the server is -maintaining backing store. - -@item visible -A region of a window is @emph{visible} if someone looking at the screen -can actually see it; that is, the window is viewable and the region is -not occluded by any other window. - -@item window gravity -When windows are resized, subwindows can be repositioned automatically -relative to some position in the window. This attraction of a subwindow -to some part of its parent is known as @emph{window gravity}. - -@item window manager -Manipulation of windows on the screen, and much of the user interface -(policy) is typically provided by a @emph{window manager} client. - -@item window manager shell -A subclass of @var{shell} called @var{wm-shell} that interacts with -the window manager. - -@item XY Format -The data for a pixmap is said to be in @emph{XY Format} if it is -organized as a set of bitmaps representing individual bit planes, with -the planes appearing from most to least significant in bit order. - -@item Z Format -The data for a pixmap is said to be in @emph{Z Format} if it is -organized as a set of pixel values in scanline order. -@end table - -@node Function Index, Type Index, Glossary, Top -@appendix Function Index - -@printindex fn - -@node Type Index, , Function Index, Top -@appendix Type Index - -@printindex tp - -@bye diff --git a/src/clx/package.lisp b/src/clx/package.lisp deleted file mode 100644 index 04f91135b..000000000 --- a/src/clx/package.lisp +++ /dev/null @@ -1,397 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; -*- - -;;; Copyright 1990 Massachusetts Institute of Technology, Cambridge, -;;; Massachusetts. All Rights Reserved. -;;; -;;; Permission to use, copy, modify, and distribute this software and its -;;; documentation for any purpose and without fee is hereby granted, provided -;;; that the above copyright notice appear in all copies and that both that -;;; copyright notice and this permission notice appear in supporting -;;; documentation, and that the name MIT not be used in advertising or -;;; publicity pertaining to distribution of the software without specific, -;;; written prior permission. - -;;; The CLtL way - -#-clx-ansi-common-lisp -(lisp:in-package :xlib :use '(:lisp)) - -#+(and (or kcl ibcl) (not clx-ansi-common-lisp)) -(shadow - '( - rational - )) - -#+(and CMU (not clx-ansi-common-lisp)) -(shadow '(define-condition)) - -#+(and lispm (not clx-ansi-common-lisp)) -(import - '( - sys:arglist - sys:with-stack-list - sys:with-stack-list* - )) - -#+(and Genera (not clx-ansi-common-lisp)) -(import - '( - future-common-lisp:print-unreadable-object - future-common-lisp:with-standard-io-syntax - zwei:indentation - )) - -#+(and lcl3.0 (not clx-ansi-common-lisp)) -(import - '( - lcl:arglist - lcl:dynamic-extent - lcl:type-error - lucid::type-error-datum - lucid::type-error-expected-type - )) - -#+(and excl (not clx-ansi-common-lisp)) -(import - '( - excl::arglist - excl::dynamic-extent - excl::type-error - excl::type-error-datum - excl::type-error-expected-type - )) - -#+(and allegro (not clx-ansi-common-lisp)) -(import - '( - excl::without-interrupts - )) - -#-clx-ansi-common-lisp -(export - '( - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler - display-extended-max-request-length display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y generalized-boolean get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function type-error undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom - )) - - -;;; The ANSI Common Lisp way - -#+(and Genera clx-ansi-common-lisp) -(eval-when (:compile-toplevel :load-toplevel :execute) - (setf *readtable* si:*ansi-common-lisp-readtable*)) - -#+clx-ansi-common-lisp -(common-lisp:in-package :common-lisp-user) - -#+ecl -(eval-when (#-stage1 :compile-toplevel :load-toplevel #-stage1 :execute) - (require 'sockets)) - - -#+clx-ansi-common-lisp -(defpackage xlib - (:use common-lisp) - (:size 3000) - #+(or kcl ibcl) (:shadow rational) - #+allegro (:use cltl1) - #+allegro (:import-from excl without-interrupts) - #+excl (:import-from excl arglist) - #+Genera (:import-from zwei indentation) - #+lcl3.0 (:import-from lcl arglist) - #+lispm (:import-from lisp char-bit) - #+lispm (:import-from sys arglist with-stack-list with-stack-list*) - #+(or sbcl ecl) (:use sb-bsd-sockets) - (:export - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler - display-extended-max-request-length display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y generalized-boolean get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation - open-default-display open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom)) - - - diff --git a/src/clx/provide.lisp b/src/clx/provide.lisp deleted file mode 100644 index 7fd0daf3e..000000000 --- a/src/clx/provide.lisp +++ /dev/null @@ -1,56 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER; -*- - -;;;; Module definition for CLX - -;;; This file is a Common Lisp Module description, but you will have to edit -;;; it to meet the needs of your site. - -;;; Ideally, this file (or a file that loads this file) should be -;;; located in the system directory that REQUIRE searches. Thus a user -;;; would say -;;; (require :clx) -;;; to load CLX. If there is no such registry, then the user must -;;; put in a site specific -;;; (require :clx ) -;;; - -#-clx-ansi-common-lisp -(in-package :user) - -#+clx-ansi-common-lisp -(in-package :common-lisp-user) - -#-clx-ansi-common-lisp -(provide :clx) - -(defvar *clx-source-pathname* - (pathname "/src/local/clx/*.l")) - -(defvar *clx-binary-pathname* - (let ((lisp - (or #+lucid "lucid" - #+akcl "akcl" - #+kcl "kcl" - #+ibcl "ibcl" - (error "Can't provide CLX for this lisp."))) - (architecture - (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" - #+(or sun4 sparc) "sparc" - #+(and hp (or mc68000 mc68020)) "hp9000s300" - #+vax "vax" - #+prime "prime" - #+sunrise "sunrise" - #+ibm-rt-pc "ibm-rt-pc" - #+mips "mips" - #+prism "prism" - (error "Can't provide CLX for this architecture.")))) - (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) - -(defvar *compile-clx* - nil) - -(load (merge-pathnames "defsystem" *clx-source-pathname*)) - -(if *compile-clx* - (compile-clx *clx-source-pathname* *clx-binary-pathname*) - (load-clx *clx-binary-pathname*)) diff --git a/src/clx/requests.lisp b/src/clx/requests.lisp deleted file mode 100644 index e554d8dbc..000000000 --- a/src/clx/requests.lisp +++ /dev/null @@ -1,1491 +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) - -(defun create-window (&key - window - (parent (required-arg parent)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (depth 0) (border-width 0) - (class :copy) (visual :copy) - background border - bit-gravity gravity - backing-store backing-planes backing-pixel save-under - event-mask do-not-propagate-mask override-redirect - colormap cursor) - ;; Display is obtained from parent. Only non-nil attributes are passed on in - ;; the request: the function makes no assumptions about what the actual protocol - ;; defaults are. Width and height are the inside size, excluding border. - (declare (type (or null window) window) - (type window parent) ; required - (type int16 x y) ;required - (type card16 width height) ;required - (type card16 depth border-width) - (type (member :copy :input-output :input-only) class) - (type (or (member :copy) visual-info resource-id) visual) - (type (or null (member :none :parent-relative) pixel pixmap) background) - (type (or null (member :copy) pixel pixmap) border) - (type (or null bit-gravity) bit-gravity) - (type (or null win-gravity) gravity) - (type (or null (member :not-useful :when-mapped :always)) backing-store) - (type (or null pixel) backing-planes backing-pixel) - (type (or null event-mask) event-mask) - (type (or null device-event-mask) do-not-propagate-mask) - (type (or null (member :on :off)) save-under override-redirect) - (type (or null (member :copy) colormap) colormap) - (type (or null (member :none) cursor) cursor)) - (declare (clx-values window)) - (let* ((display (window-display parent)) - (window (or window (make-window :display display))) - (wid (allocate-resource-id display window 'window)) - back-pixmap back-pixel - border-pixmap border-pixel) - (declare (type display display) - (type window window) - (type resource-id wid) - (type (or null resource-id) back-pixmap border-pixmap) - (type (or null pixel) back-pixel border-pixel)) - (setf (window-id window) wid) - (case background - ((nil) nil) - (:none (setq back-pixmap 0)) - (:parent-relative (setq back-pixmap 1)) - (otherwise - (if (type? background 'pixmap) - (setq back-pixmap (pixmap-id background)) - (if (integerp background) - (setq back-pixel background) - (x-type-error background - '(or null (member :none :parent-relative) integer pixmap)))))) - (case border - ((nil) nil) - (:copy (setq border-pixmap 0)) - (otherwise - (if (type? border 'pixmap) - (setq border-pixmap (pixmap-id border)) - (if (integerp border) - (setq border-pixel border) - (x-type-error border '(or null (member :copy) integer pixmap)))))) - (when event-mask - (setq event-mask (encode-event-mask event-mask))) - (when do-not-propagate-mask - (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask))) - - ;Make the request - (with-buffer-request (display +x-createwindow+) - (data depth) - (resource-id wid) - (window parent) - (int16 x y) - (card16 width height border-width) - ((member16 :copy :input-output :input-only) class) - (resource-id (cond ((eq visual :copy) - 0) - ((typep visual 'resource-id) - visual) - (t - (visual-info-id visual)))) - (mask (card32 back-pixmap back-pixel border-pixmap border-pixel) - ((member-vector +bit-gravity-vector+) bit-gravity) - ((member-vector +win-gravity-vector+) gravity) - ((member :not-useful :when-mapped :always) backing-store) - (card32 backing-planes backing-pixel) - ((member :off :on) override-redirect save-under) - (card32 event-mask do-not-propagate-mask) - ((or (member :copy) colormap) colormap) - ((or (member :none) cursor) cursor))) - window)) - -(defun destroy-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-destroywindow+) - (window window))) - -(defun destroy-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-destroysubwindows+) - (window window))) - -(defun add-to-save-set (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-changesaveset+) - (data 0) - (window window))) - -(defun remove-from-save-set (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-changesaveset+) - (data 1) - (window window))) - -(defun reparent-window (window parent x y) - (declare (type window window parent) - (type int16 x y)) - (with-buffer-request ((window-display window) +x-reparentwindow+) - (window window parent) - (int16 x y))) - -(defun map-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-mapwindow+) - (window window))) - -(defun map-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-mapsubwindows+) - (window window))) - -(defun unmap-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-unmapwindow+) - (window window))) - -(defun unmap-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-unmapsubwindows+) - (window window))) - -(defun circulate-window-up (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-circulatewindow+) - (data 0) - (window window))) - -(defun circulate-window-down (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-circulatewindow+) - (data 1) - (window window))) - -(defun query-tree (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;;type specifier - (declare (clx-values (clx-sequence window) parent root)) - (let ((display (window-display window))) - (multiple-value-bind (root parent sequence) - (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32)) - ((window window)) - (values - (window-get 8) - (resource-id-get 12) - (sequence-get :length (card16-get 16) :result-type result-type - :index +replysize+))) - ;; Parent is NIL for root window - (setq parent (and (plusp parent) (lookup-window display parent))) - (dotimes (i (length sequence)) ; Convert ID's to window's - (setf (elt sequence i) (lookup-window display (elt sequence i)))) - (values sequence parent root)))) - -;; Although atom-ids are not visible in the normal user interface, atom-ids might -;; appear in window properties and other user data, so conversion hooks are needed. - -(defun intern-atom (display name) - (declare (type display display) - (type xatom name)) - (declare (clx-values resource-id)) - (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) - (declare (type symbol name)) - (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) - ((data 0) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (resource-id-get 8))) - (declare (type resource-id id)) - (setf (atom-id name display) id) - id))))) - -(defun find-atom (display name) - ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True - (declare (type display display) - (type xatom name)) - (declare (clx-values (or null resource-id))) - (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) - (declare (type symbol name)) - (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) - ((data 1) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (or-get 8 null resource-id))) - (declare (type (or null resource-id) id)) - (when id - (setf (atom-id name display) id)) - id))))) - -(defun atom-name (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (declare (clx-values keyword)) - (if (zerop atom-id) - nil - (or (id-atom atom-id display) - (let ((keyword - (kintern - (with-buffer-request-and-reply - (display +x-getatomname+ nil :sizes (16)) - ((resource-id atom-id)) - (values - (string-get (card16-get 8) +replysize+)))))) - (declare (type keyword keyword)) - (setf (atom-id keyword display) atom-id) - keyword)))) - -;;; For binary compatibility with older code -(defun lookup-xatom (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (atom-name display atom-id)) - -(defun change-property (window property data type format - &key (mode :replace) (start 0) end transform) - ; Start and end affect sub-sequence extracted from data. - ; Transform is applied to each extracted element. - (declare (type window window) - (type xatom property type) - (type (member 8 16 32) format) - (type sequence data) - (type (member :replace :prepend :append) mode) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (t) integer)) transform)) - (unless end (setq end (length data))) - (let* ((display (window-display window)) - (length (index- end start)) - (property-id (intern-atom display property)) - (type-id (intern-atom display type))) - (declare (type display display) - (type array-index length) - (type resource-id property-id type-id)) - (with-buffer-request (display +x-changeproperty+) - ((data (member :replace :prepend :append)) mode) - (window window) - (resource-id property-id type-id) - (card8 format) - (card32 length) - (progn - (ecase format - (8 (sequence-put 24 data :format card8 - :start start :end end :transform transform)) - (16 (sequence-put 24 data :format card16 - :start start :end end :transform transform)) - (32 (sequence-put 24 data :format card32 - :start start :end end :transform transform))))))) - -(defun delete-property (window property) - (declare (type window window) - (type xatom property)) - (let* ((display (window-display window)) - (property-id (intern-atom display property))) - (declare (type display display) - (type resource-id property-id)) - (with-buffer-request (display +x-deleteproperty+) - (window window) - (resource-id property-id)))) - -(defun get-property (window property - &key type (start 0) end delete-p (result-type 'list) transform) - ;; Transform is applied to each integer retrieved. - (declare (type window window) - (type xatom property) - (type (or null xatom) type) - (type array-index start) - (type (or null array-index) end) - (type generalized-boolean delete-p) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) - (declare (clx-values data (or null type) format bytes-after)) - (let* ((display (window-display window)) - (property-id (intern-atom display property)) - (type-id (and type (intern-atom display type)))) - (declare (type display display) - (type resource-id property-id) - (type (or null resource-id) type-id)) - (multiple-value-bind (reply-format reply-type bytes-after data) - (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32)) - (((data boolean) delete-p) - (window window) - (resource-id property-id) - ((or null resource-id) type-id) - (card32 start) - (card32 (index- (or end 64000) start))) - (let ((reply-format (card8-get 1)) - (reply-type (card32-get 8)) - (bytes-after (card32-get 12)) - (nitems (card32-get 16))) - (values - reply-format - reply-type - bytes-after - (and (plusp nitems) - (ecase reply-format - (0 nil) ;; (make-sequence result-type 0) ;; Property not found. - (8 (sequence-get :result-type result-type :format card8 - :length nitems :transform transform - :index +replysize+)) - (16 (sequence-get :result-type result-type :format card16 - :length nitems :transform transform - :index +replysize+)) - (32 (sequence-get :result-type result-type :format card32 - :length nitems :transform transform - :index +replysize+))))))) - (values data - (and (plusp reply-type) (atom-name display reply-type)) - reply-format - bytes-after)))) - -(defun rotate-properties (window properties &optional (delta 1)) - ;; Positive rotates left, negative rotates right (opposite of actual protocol request). - (declare (type window window) - (type sequence properties) ;; sequence of xatom - (type int16 delta)) - (let* ((display (window-display window)) - (length (length properties)) - (sequence (make-array length))) - (declare (type display display) - (type array-index length)) - (with-vector (sequence vector) - ;; Atoms must be interned before the RotateProperties request - ;; is started to allow InternAtom requests to be made. - (dotimes (i length) - (setf (aref sequence i) (intern-atom display (elt properties i)))) - (with-buffer-request (display +x-rotateproperties+) - (window window) - (card16 length) - (int16 (- delta)) - ((sequence :end length) sequence)))) - nil) - -(defun list-properties (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;; a sequence type - (declare (clx-values (clx-sequence keyword))) - (let ((display (window-display window))) - (multiple-value-bind (seq) - (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :index +replysize+))) - ;; lookup the atoms in the sequence - (if (listp seq) - (do ((elt seq (cdr elt))) - ((endp elt) seq) - (setf (car elt) (atom-name display (car elt)))) - (dotimes (i (length seq) seq) - (setf (aref seq i) (atom-name display (aref seq i)))))))) - -(defun selection-owner (display selection) - (declare (type display display) - (type xatom selection)) - (declare (clx-values (or null window))) - (let ((selection-id (intern-atom display selection))) - (declare (type resource-id selection-id)) - (multiple-value-bind (window) - (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32) - ((resource-id selection-id)) - (values - (resource-id-or-nil-get 8))) - (and window (lookup-window display window))))) - -(defun set-selection-owner (display selection owner &optional time) - (declare (type display display) - (type xatom selection) - (type (or null window) owner) - (type timestamp time)) - (let ((selection-id (intern-atom display selection))) - (declare (type resource-id selection-id)) - (with-buffer-request (display +x-setselectionowner+) - ((or null window) owner) - (resource-id selection-id) - ((or null card32) time)) - owner)) - -(defsetf selection-owner (display selection &optional time) (owner) - ;; A bit strange, but retains setf form. - `(set-selection-owner ,display ,selection ,owner ,time)) - -(defun convert-selection (selection type requestor &optional property time) - (declare (type xatom selection type) - (type window requestor) - (type (or null xatom) property) - (type timestamp time)) - (let* ((display (window-display requestor)) - (selection-id (intern-atom display selection)) - (type-id (intern-atom display type)) - (property-id (and property (intern-atom display property)))) - (declare (type display display) - (type resource-id selection-id type-id) - (type (or null resource-id) property-id)) - (with-buffer-request (display +x-convertselection+) - (window requestor) - (resource-id selection-id type-id) - ((or null resource-id) property-id) - ((or null card32) time)))) - -(defun send-event (window event-key event-mask &rest args - &key propagate-p display &allow-other-keys) - ;; Additional arguments depend on event-key, and are as specified further below - ;; with declare-event, except that both resource-ids and resource objects are - ;; accepted in the event components. The display argument is only required if the - ;; window is :pointer-window or :input-focus. - (declare (type (or window (member :pointer-window :input-focus)) window) - (type event-key event-key) - (type (or null event-mask) event-mask) - (type generalized-boolean propagate-p) - (type (or null display) display) - (dynamic-extent args)) - (unless event-mask (setq event-mask 0)) - (unless display (setq display (window-display window))) - (let ((internal-event-code (get-event-code event-key)) - (external-event-code (get-external-event-code display event-key))) - (declare (type card8 internal-event-code external-event-code)) - ;; Ensure keyword atom-id's are cached - (dolist (arg (cdr (assoc event-key '((:property-notify :atom) - (:selection-clear :selection) - (:selection-request :selection :target :property) - (:selection-notify :selection :target :property) - (:client-message :type)) - :test #'eq))) - (let ((keyword (getf args arg))) - (intern-atom display keyword))) - ;; Make the sendevent request - (with-buffer-request (display +x-sendevent+) - ((data boolean) propagate-p) - (length 11) ;; 3 word request + 8 words for event = 11 - ((or (member :pointer-window :input-focus) window) window) - (card32 (encode-event-mask event-mask)) - (card8 external-event-code) - (progn - (apply (svref *event-send-vector* internal-event-code) display args) - (setf (buffer-boffset display) (index+ buffer-boffset 44)))))) - -(defun grab-pointer (window event-mask - &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) - (declare (type window window) - (type pointer-event-mask event-mask) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor) - (type timestamp time)) - (declare (clx-values grab-status)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8) - (((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - ((or null card32) time)) - (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) - -(defun ungrab-pointer (display &key time) - (declare (type timestamp time)) - (with-buffer-request (display +x-ungrabpointer+) - ((or null card32) time))) - -(defun grab-button (window button event-mask - &key (modifiers :any) - owner-p sync-pointer-p sync-keyboard-p confine-to cursor) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers) - (type pointer-event-mask event-mask) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor)) - (with-buffer-request ((window-display window) +x-grabbutton+) - ((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - (card8 (if (eq button :any) 0 button)) - (pad8 1) - (card16 (encode-modifier-mask modifiers)))) - -(defun ungrab-button (window button &key (modifiers :any)) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-ungrabbutton+) - (data (if (eq button :any) 0 button)) - (window window) - (card16 (encode-modifier-mask modifiers)))) - -(defun change-active-pointer-grab (display event-mask &optional cursor time) - (declare (type display display) - (type pointer-event-mask event-mask) - (type (or null cursor) cursor) - (type timestamp time)) - (with-buffer-request (display +x-changeactivepointergrab+) - ((or null cursor) cursor) - ((or null card32) time) - (card16 (encode-pointer-event-mask event-mask)))) - -(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) - (declare (type window window) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type timestamp time)) - (declare (clx-values grab-status)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8) - (((data boolean) owner-p) - (window window) - ((or null card32) time) - (boolean (not sync-pointer-p) (not sync-keyboard-p))) - (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) - -(defun ungrab-keyboard (display &key time) - (declare (type display display) - (type timestamp time)) - (with-buffer-request (display +x-ungrabkeyboard+) - ((or null card32) time))) - -(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) - (declare (type window window) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-grabkey+) - ((data boolean) owner-p) - (window window) - (card16 (encode-modifier-mask modifiers)) - (card8 (if (eq key :any) 0 key)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)))) - -(defun ungrab-key (window key &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-ungrabkey+) - (data (if (eq key :any) 0 key)) - (window window) - (card16 (encode-modifier-mask modifiers)))) - -(defun allow-events (display mode &optional time) - (declare (type display display) - (type (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both) - mode) - (type timestamp time)) - (with-buffer-request (display +x-allowevents+) - ((data (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both)) - mode) - ((or null card32) time))) - -(defun grab-server (display) - (declare (type display display)) - (with-buffer-request (display +x-grabserver+))) - -(defun ungrab-server (display) - (with-buffer-request (display +x-ungrabserver+))) - -(defmacro with-server-grabbed ((display) &body body) - ;; The body is not surrounded by a with-display. - (let ((disp (if (symbolp display) display (gensym)))) - `(let ((,disp ,display)) - (declare (type display ,disp)) - (unwind-protect - (progn - (grab-server ,disp) - ,@body) - (ungrab-server ,disp))))) - -(defun query-pointer (window) - (declare (type window window)) - (declare (clx-values x y same-screen-p child mask root-x root-y root)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32)) - ((window window)) - (values - (int16-get 20) - (int16-get 22) - (boolean-get 1) - (or-get 12 null window) - (card16-get 24) - (int16-get 16) - (int16-get 18) - (window-get 8))))) - -(defun pointer-position (window) - (declare (type window window)) - (declare (clx-values x y same-screen-p)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16)) - ((window window)) - (values - (int16-get 20) - (int16-get 22) - (boolean-get 1))))) - -(defun global-pointer-position (display) - (declare (type display display)) - (declare (clx-values root-x root-y root)) - (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32)) - ((window (screen-root (first (display-roots display))))) - (values - (int16-get 16) - (int16-get 18) - (window-get 8)))) - -(defun motion-events (window &key start stop (result-type 'list)) - (declare (type window window) - (type timestamp start stop) - (type t result-type)) ;; a type specifier - (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time)))) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32) - ((window window) - ((or null card32) start stop)) - (values - (sequence-get :result-type result-type :length (index* (card32-get 8) 3) - :index +replysize+))))) - -(defun translate-coordinates (src src-x src-y dst) - ;; Returns NIL when not on the same screen - (declare (type window src) - (type int16 src-x src-y) - (type window dst)) - (declare (clx-values dst-x dst-y child)) - (let ((display (window-display src))) - (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32)) - ((window src dst) - (int16 src-x src-y)) - (and (boolean-get 1) - (values - (int16-get 12) - (int16-get 14) - (or-get 8 null window)))))) - -(defun warp-pointer (dst dst-x dst-y) - (declare (type window dst) - (type int16 dst-x dst-y)) - (with-buffer-request ((window-display dst) +x-warppointer+) - (resource-id 0) ;; None - (window dst) - (int16 0 0) - (card16 0 0) - (int16 dst-x dst-y))) - -(defun warp-pointer-relative (display x-off y-off) - (declare (type display display) - (type int16 x-off y-off)) - (with-buffer-request (display +x-warppointer+) - (resource-id 0) ;; None - (resource-id 0) ;; None - (int16 0 0) - (card16 0 0) - (int16 x-off y-off))) - -(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. - ;; A null src-width or src-height translates into a zero value in the protocol request. - (declare (type window dst src) - (type int16 dst-x dst-y src-x src-y) - (type (or null card16) src-width src-height)) - (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display dst) +x-warppointer+) - (window src dst) - (int16 src-x src-y) - (card16 (or src-width 0) (or src-height 0)) - (int16 dst-x dst-y)))) - -(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. - ;; A null src-width or src-height translates into a zero value in the protocol request. - (declare (type window src) - (type int16 x-off y-off src-x src-y) - (type (or null card16) src-width src-height)) - (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display src) +x-warppointer+) - (window src) - (resource-id 0) ;; None - (int16 src-x src-y) - (card16 (or src-width 0) (or src-height 0)) - (int16 x-off y-off)))) - -(defun set-input-focus (display focus revert-to &optional time) - (declare (type display display) - (type (or (member :none :pointer-root) window) focus) - (type (member :none :pointer-root :parent) revert-to) - (type timestamp time)) - (with-buffer-request (display +x-setinputfocus+) - ((data (member :none :pointer-root :parent)) revert-to) - ((or window (member :none :pointer-root)) focus) - ((or null card32) time))) - -(defun input-focus (display) - (declare (type display display)) - (declare (clx-values focus revert-to)) - (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) - () - (values - (or-get 8 window (member :none :pointer-root)) - (member8-get 1 :none :pointer-root :parent)))) - -(defun query-keymap (display &optional bit-vector) - (declare (type display display) - (type (or null (bit-vector 256)) bit-vector)) - (declare (clx-values (bit-vector 256))) - (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8) - () - (values - (bit-vector256-get 8 8 bit-vector)))) - -(defun create-pixmap (&key - pixmap - (width (required-arg width)) - (height (required-arg height)) - (depth (required-arg depth)) - (drawable (required-arg drawable))) - (declare (type (or null pixmap) pixmap) - (type card8 depth) ;; required - (type card16 width height) ;; required - (type drawable drawable)) ;; required - (declare (clx-values pixmap)) - (let* ((display (drawable-display drawable)) - (pixmap (or pixmap (make-pixmap :display display))) - (pid (allocate-resource-id display pixmap 'pixmap))) - (setf (pixmap-id pixmap) pid) - (with-buffer-request (display +x-createpixmap+) - (data depth) - (resource-id pid) - (drawable drawable) - (card16 width height)) - pixmap)) - -(defun free-pixmap (pixmap) - (declare (type pixmap pixmap)) - (let ((display (pixmap-display pixmap))) - (with-buffer-request (display +x-freepixmap+) - (pixmap pixmap)) - (deallocate-resource-id display (pixmap-id pixmap) 'pixmap))) - -(defun clear-area (window &key (x 0) (y 0) width height exposures-p) - ;; Passing in a zero width or height is a no-op. - ;; A null width or height translates into a zero value in the protocol request. - (declare (type window window) - (type int16 x y) - (type (or null card16) width height) - (type generalized-boolean exposures-p)) - (unless (or (eql width 0) (eql height 0)) - (with-buffer-request ((window-display window) +x-cleartobackground+) - ((data boolean) exposures-p) - (window window) - (int16 x y) - (card16 (or width 0) (or height 0))))) - -(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) - (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext) - (drawable src dst) - (gcontext gcontext) - (int16 src-x src-y dst-x dst-y) - (card16 width height))) - -(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type pixel plane) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) - (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext) - (drawable src dst) - (gcontext gcontext) - (int16 src-x src-y dst-x dst-y) - (card16 width height) - (card32 plane))) - -(defun create-colormap (visual-info window &optional alloc-p) - (declare (type (or visual-info resource-id) visual-info) - (type window window) - (type generalized-boolean alloc-p)) - (declare (clx-values colormap)) - (let ((display (window-display window))) - (when (typep visual-info 'resource-id) - (setf visual-info (visual-info display visual-info))) - (let* ((colormap (make-colormap :display display :visual-info visual-info)) - (id (allocate-resource-id display colormap 'colormap))) - (setf (colormap-id colormap) id) - (with-buffer-request (display +x-createcolormap+) - ((data boolean) alloc-p) - (card29 id) - (window window) - (card29 (visual-info-id visual-info))) - colormap))) - -(defun free-colormap (colormap) - (declare (type colormap colormap)) - (let ((display (colormap-display colormap))) - (with-buffer-request (display +x-freecolormap+) - (colormap colormap)) - (deallocate-resource-id display (colormap-id colormap) 'colormap))) - -(defun copy-colormap-and-free (colormap) - (declare (type colormap colormap)) - (declare (clx-values colormap)) - (let* ((display (colormap-display colormap)) - (new-colormap (make-colormap :display display - :visual-info (colormap-visual-info colormap))) - (id (allocate-resource-id display new-colormap 'colormap))) - (setf (colormap-id new-colormap) id) - (with-buffer-request (display +x-copycolormapandfree+) - (resource-id id) - (colormap colormap)) - new-colormap)) - -(defun install-colormap (colormap) - (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) +x-installcolormap+) - (colormap colormap))) - -(defun uninstall-colormap (colormap) - (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+) - (colormap colormap))) - -(defun installed-colormaps (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence colormap))) - (let ((display (window-display window))) - (flet ((get-colormap (id) - (lookup-colormap display id))) - (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :transform #'get-colormap :index +replysize+)))))) - -(defun alloc-color (colormap color) - (declare (type colormap colormap) - (type (or stringable color) color)) - (declare (clx-values pixel screen-color exact-color)) - (let ((display (colormap-display colormap))) - (etypecase color - (color - (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32)) - ((colormap colormap) - (rgb-val (color-red color) - (color-green color) - (color-blue color)) - (pad16 nil)) - (values - (card32-get 16) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)) - color))) - (stringable - (let* ((string (string color)) - (length (length string))) - (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32)) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (card32-get 8) - (make-color :red (rgb-val-get 18) - :green (rgb-val-get 20) - :blue (rgb-val-get 22)) - (make-color :red (rgb-val-get 12) - :green (rgb-val-get 14) - :blue (rgb-val-get 16))))))))) - -(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors planes) - (type generalized-boolean contiguous-p) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence pixel) (clx-sequence mask))) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors planes)) - (let ((pixel-length (card16-get 8)) - (mask-length (card16-get 10))) - (values - (sequence-get :result-type result-type :length pixel-length :index +replysize+) - (sequence-get :result-type result-type :length mask-length - :index (index+ +replysize+ (index* pixel-length 4)))))))) - -(defun alloc-color-planes (colormap colors - &key (reds 0) (greens 0) (blues 0) - contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors reds greens blues) - (type generalized-boolean contiguous-p) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32)) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors reds greens blues)) - (let ((red-mask (card32-get 12)) - (green-mask (card32-get 16)) - (blue-mask (card32-get 20))) - (values - (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+) - red-mask green-mask blue-mask))))) - -(defun free-colors (colormap pixels &optional (plane-mask 0)) - (declare (type colormap colormap) - (type sequence pixels) ;; Sequence of integers - (type pixel plane-mask)) - (with-buffer-request ((colormap-display colormap) +x-freecolors+) - (colormap colormap) - (card32 plane-mask) - (sequence pixels))) - -(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) - (declare (type colormap colormap) - (type pixel pixel) - (type (or stringable color) spec) - (type generalized-boolean red-p green-p blue-p)) - (let ((display (colormap-display colormap)) - (flags 0)) - (declare (type display display) - (type card8 flags)) - (when red-p (setq flags 1)) - (when green-p (incf flags 2)) - (when blue-p (incf flags 4)) - (etypecase spec - (color - (with-buffer-request (display +x-storecolors+) - (colormap colormap) - (card32 pixel) - (rgb-val (color-red spec) - (color-green spec) - (color-blue spec)) - (card8 flags) - (pad8 nil))) - (stringable - (let* ((string (string spec)) - (length (length string))) - (with-buffer-request (display +x-storenamedcolor+) - ((data card8) flags) - (colormap colormap) - (card32 pixel) - (card16 length) - (pad16 nil) - (string string))))))) - -(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) - ;; If stringables are specified for colors, it is unspecified whether all - ;; stringables are first resolved and then a single StoreColors protocol request is - ;; issued, or whether multiple StoreColors protocol requests are issued. - (declare (type colormap colormap) - (type sequence specs) - (type generalized-boolean red-p green-p blue-p)) - (etypecase specs - (list - (do ((spec specs (cddr spec))) - ((endp spec)) - (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p))) - (vector - (do ((i 0 (+ i 2)) - (len (length specs))) - ((>= i len)) - (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p))))) - -(defun query-colors (colormap pixels &key (result-type 'list)) - (declare (type colormap colormap) - (type sequence pixels) ;; sequence of integer - (type t result-type)) ;; a type specifier - (declare (clx-values (clx-sequence color))) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16)) - ((colormap colormap) - (sequence pixels)) - (let ((sequence (make-sequence result-type (card16-get 8)))) - (advance-buffer-offset +replysize+) - (dotimes (i (length sequence) sequence) - (setf (elt sequence i) - (make-color :red (rgb-val-get 0) - :green (rgb-val-get 2) - :blue (rgb-val-get 4))) - (advance-buffer-offset 8)))))) - -(defun lookup-color (colormap name) - (declare (type colormap colormap) - (type stringable name)) - (declare (clx-values screen-color true-color)) - (let* ((display (colormap-display colormap)) - (string (string name)) - (length (length string))) - (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (make-color :red (rgb-val-get 14) - :green (rgb-val-get 16) - :blue (rgb-val-get 18)) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)))))) - -(defun create-cursor (&key - (source (required-arg source)) - mask - (x (required-arg x)) - (y (required-arg y)) - (foreground (required-arg foreground)) - (background (required-arg background))) - (declare (type pixmap source) ;; required - (type (or null pixmap) mask) - (type card16 x y) ;; required - (type (or null color) foreground background)) ;; required - (declare (clx-values cursor)) - (let* ((display (pixmap-display source)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor))) - (setf (cursor-id cursor) cid) - (with-buffer-request (display +x-createcursor+) - (resource-id cid) - (pixmap source) - ((or null pixmap) mask) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background)) - (card16 x y)) - cursor)) - -(defun create-glyph-cursor (&key - (source-font (required-arg source-font)) - (source-char (required-arg source-char)) - mask-font - mask-char - (foreground (required-arg foreground)) - (background (required-arg background))) - (declare (type font source-font) ;; Required - (type card16 source-char) ;; Required - (type (or null font) mask-font) - (type (or null card16) mask-char) - (type color foreground background)) ;; required - (declare (clx-values cursor)) - (let* ((display (font-display source-font)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor)) - (source-font-id (font-id source-font)) - (mask-font-id (if mask-font (font-id mask-font) 0))) - (setf (cursor-id cursor) cid) - (unless mask-char (setq mask-char 0)) - (with-buffer-request (display +x-createglyphcursor+) - (resource-id cid source-font-id mask-font-id) - (card16 source-char) - (card16 mask-char) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background))) - cursor)) - -(defun free-cursor (cursor) - (declare (type cursor cursor)) - (let ((display (cursor-display cursor))) - (with-buffer-request (display +x-freecursor+) - (cursor cursor)) - (deallocate-resource-id display (cursor-id cursor) 'cursor))) - -(defun recolor-cursor (cursor foreground background) - (declare (type cursor cursor) - (type color foreground background)) - (with-buffer-request ((cursor-display cursor) +x-recolorcursor+) - (cursor cursor) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background)) - )) - -(defun query-best-cursor (width height drawable) - (declare (type card16 width height) - (type (or drawable display) drawable)) - (declare (clx-values width height)) - ;; Drawable can be a display for compatibility. - (multiple-value-bind (display drawable) - (if (type? drawable 'drawable) - (values (drawable-display drawable) drawable) - (values drawable (screen-root (display-default-screen drawable)))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 0) - (window drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-best-tile (width height drawable) - (declare (type card16 width height) - (type drawable drawable)) - (declare (clx-values width height)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 1) - (drawable drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-best-stipple (width height drawable) - (declare (type card16 width height) - (type drawable drawable)) - (declare (clx-values width height)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 2) - (drawable drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-extension (display name) - (declare (type display display) - (type stringable name)) - (declare (clx-values major-opcode first-event first-error)) - (let ((string (string name))) - (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8) - ((card16 (length string)) - (pad16 nil) - (string string)) - (and (boolean-get 8) ;; If present - (values - (card8-get 9) - (card8-get 10) - (card8-get 11)))))) - -(defun list-extensions (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence string))) - (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8) - () - (values - (read-sequence-string - buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+)))) - -(defun change-keyboard-control (display &key key-click-percent - bell-percent bell-pitch bell-duration - led led-mode key auto-repeat-mode) - (declare (type display display) - (type (or null (member :default) int16) key-click-percent - bell-percent bell-pitch bell-duration) - (type (or null card8) led key) - (type (or null (member :on :off)) led-mode) - (type (or null (member :on :off :default)) auto-repeat-mode)) - (when (eq key-click-percent :default) (setq key-click-percent -1)) - (when (eq bell-percent :default) (setq bell-percent -1)) - (when (eq bell-pitch :default) (setq bell-pitch -1)) - (when (eq bell-duration :default) (setq bell-duration -1)) - (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32)) - (mask - (integer key-click-percent bell-percent bell-pitch bell-duration) - (card32 led) - ((member :off :on) led-mode) - (card32 key) - ((member :off :on :default) auto-repeat-mode)))) - -(defun keyboard-control (display) - (declare (type display display)) - (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration - led-mask global-auto-repeat auto-repeats)) - (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32)) - () - (values - (card8-get 12) - (card8-get 13) - (card16-get 14) - (card16-get 16) - (card32-get 8) - (member8-get 1 :off :on) - (bit-vector256-get 20)))) - -;; The base volume should -;; be considered to be the "desired" volume in the normal case; that is, a -;; typical application should call XBell with 0 as the percent. Rather -;; than using a simple sum, the percent argument is instead used as the -;; percentage of the remaining range to alter the base volume by. That is, -;; the actual volume is: -;; if percent>=0: base - [(base * percent) / 100] + percent -;; if percent<0: base + [(base * percent) / 100] - -(defun bell (display &optional (percent-from-normal 0)) - ;; It is assumed that an eventual audio extension to X will provide more complete control. - (declare (type display display) - (type int8 percent-from-normal)) - (with-buffer-request (display +x-bell+) - (data (int8->card8 percent-from-normal)))) - -(defun pointer-mapping (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values sequence)) ;; Sequence of card - (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8) - () - (values - (sequence-get :length (card8-get 1) :result-type result-type :format card8 - :index +replysize+)))) - -(defun set-pointer-mapping (display map) - ;; Can signal device-busy. - (declare (type display display) - (type sequence map)) ;; Sequence of card8 - (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8) - ((data (length map)) - ((sequence :format card8) map)) - (values - (boolean-get 1))) - (x-error 'device-busy :display display)) - map) - -(defsetf pointer-mapping set-pointer-mapping) - -(defun change-pointer-control (display &key acceleration threshold) - ;; Acceleration is rationalized if necessary. - (declare (type display display) - (type (or null (member :default) number) acceleration) - (type (or null (member :default) integer) threshold)) - (flet ((rationalize16 (number) - ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers - (declare (type number number)) - (declare (clx-values numerator denominator)) - (do* ((rational (rationalize number)) - (numerator (numerator rational) (ash numerator -1)) - (denominator (denominator rational) (ash denominator -1))) - ((or (= numerator 1) - (and (< (abs numerator) #x8000) - (< denominator #x8000))) - (values - numerator (min denominator #x7fff)))))) - (declare (inline rationalize16)) - (let ((acceleration-p 1) - (threshold-p 1) - (numerator 0) - (denominator 1)) - (declare (type card8 acceleration-p threshold-p) - (type int16 numerator denominator)) - (cond ((eq acceleration :default) (setq numerator -1)) - (acceleration (multiple-value-setq (numerator denominator) - (rationalize16 acceleration))) - (t (setq acceleration-p 0))) - (cond ((eq threshold :default) (setq threshold -1)) - ((null threshold) (setq threshold -1 - threshold-p 0))) - (with-buffer-request (display +x-changepointercontrol+) - (int16 numerator denominator threshold) - (card8 acceleration-p threshold-p))))) - -(defun pointer-control (display) - (declare (type display display)) - (declare (clx-values acceleration threshold)) - (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16) - () - (values - (/ (card16-get 8) (card16-get 10)) ; Should we float this? - (card16-get 12)))) - -(defun set-screen-saver (display timeout interval blanking exposures) - ;; Timeout and interval are in seconds, will be rounded to minutes. - (declare (type display display) - (type (or (member :default) int16) timeout interval) - (type (member :on :off :default :yes :no) blanking exposures)) - (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off))) - (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off))) - (when (eq timeout :default) (setq timeout -1)) - (when (eq interval :default) (setq interval -1)) - (with-buffer-request (display +x-setscreensaver+) - (int16 timeout interval) - ((member8 :on :off :default) blanking exposures))) - -(defun screen-saver (display) - ;; Returns timeout and interval in seconds. - (declare (type display display)) - (declare (clx-values timeout interval blanking exposures)) - (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16)) - () - (values - (card16-get 8) - (card16-get 10) - (member8-get 12 :on :off :default) - (member8-get 13 :on :off :default)))) - -(defun activate-screen-saver (display) - (declare (type display display)) - (with-buffer-request (display +x-forcescreensaver+) - (data 1))) - -(defun reset-screen-saver (display) - (declare (type display display)) - (with-buffer-request (display +x-forcescreensaver+) - (data 0))) - -(defun add-access-host (display host &optional (family :internet)) - ;; A string must be acceptable as a host, but otherwise the possible types for - ;; host are not constrained, and will likely be very system dependent. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (change-access-host display host family nil)) - -(defun remove-access-host (display host &optional (family :internet)) - ;; A string must be acceptable as a host, but otherwise the possible types for - ;; host are not constrained, and will likely be very system dependent. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (change-access-host display host family t)) - -(defun change-access-host (display host family remove-p) - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (unless (consp host) - (setq host (host-address host family))) - (let ((family (car host)) - (address (cdr host))) - (with-buffer-request (display +x-changehosts+) - ((data boolean) remove-p) - (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family)) - (card16 (length address)) - ((sequence :format card8) address)))) - -(defun access-hosts (display &optional (result-type 'list)) - ;; The type of host objects returned is not constrained, except that the hosts must - ;; be acceptable to add-access-host and remove-access-host. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence host) enabled-p)) - (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16)) - () - (let* ((enabled-p (boolean-get 1)) - (nhosts (card16-get 8)) - (sequence (make-sequence result-type nhosts))) - (advance-buffer-offset +replysize+) - (dotimes (i nhosts) - (let ((family (card8-get 0)) - (len (card16-get 2))) - (setf (elt sequence i) - (cons (if (< family 3) - (svref '#(:internet :decnet :chaos) family) - family) - (sequence-get :length len :format card8 :result-type 'list - :index (+ buffer-boffset 4)))) - (advance-buffer-offset (+ 4 (* 4 (ceiling len 4)))))) - (values - sequence - enabled-p)))) - -(defun access-control (display) - (declare (type display display)) - (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED - (with-buffer-request-and-reply (display +x-listhosts+ 2 :sizes 8) - () - (boolean-get 1))) - -(defun set-access-control (display enabled-p) - (declare (type display display) - (type generalized-boolean enabled-p)) - (with-buffer-request (display +x-changeaccesscontrol+) - ((data boolean) enabled-p)) - enabled-p) - -(defsetf access-control set-access-control) - -(defun close-down-mode (display) - ;; setf'able - ;; Cached locally in display object. - (declare (type display display)) - (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil))) - (display-close-down-mode display)) - -(defun set-close-down-mode (display mode) - ;; Cached locally in display object. - (declare (type display display) - (type (member :destroy :retain-permanent :retain-temporary) mode)) - (setf (display-close-down-mode display) mode) - (with-buffer-request (display +x-changeclosedownmode+ :sizes (32)) - ((data (member :destroy :retain-permanent :retain-temporary)) mode)) - mode) - -(defsetf close-down-mode set-close-down-mode) - -(defun kill-client (display resource-id) - (declare (type display display) - (type resource-id resource-id)) - (with-buffer-request (display +x-killclient+) - (resource-id resource-id))) - -(defun kill-temporary-clients (display) - (declare (type display display)) - (with-buffer-request (display +x-killclient+) - (resource-id 0))) - -(defun no-operation (display) - (declare (type display display)) - (with-buffer-request (display +x-nooperation+))) diff --git a/src/clx/resource.lisp b/src/clx/resource.lisp deleted file mode 100644 index 50feec547..000000000 --- a/src/clx/resource.lisp +++ /dev/null @@ -1,700 +0,0 @@ -;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;; RESOURCE - Lisp version of XLIB's Xrm resource manager - -;;; -;;; 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 C version of this uses a 64 entry hash table at each entry. -;; Small hash tables lose in Lisp, so we do linear searches on lists. - -(defstruct (resource-database (:copier nil) (:predicate nil) - (:print-function print-resource-database) - (:constructor make-resource-database-internal) - #+explorer (:callable-constructors nil) - ) - (name nil :type stringable :read-only t) - (value nil) - (tight nil :type list) ;; List of resource-database - (loose nil :type list) ;; List of resource-database - ) - -(defun print-resource-database (database stream depth) - (declare (type resource-database database) - (ignore depth)) - (print-unreadable-object (database stream :type t) - (write-string (string (resource-database-name database)) stream) - (when (resource-database-value database) - (write-string " " stream) - (prin1 (resource-database-value database) stream)))) - -;; The value slot of the top-level resource-database structure is used for a -;; time-stamp. - -(defun make-resource-database () - ;; Make a resource-database with initial timestamp of 0 - (make-resource-database-internal :name "Top-Level" :value 0)) - -(defun resource-database-timestamp (database) - (declare (type resource-database database)) - (resource-database-value database)) - -(defun incf-resource-database-timestamp (database) - ;; Increment the timestamp - (declare (type resource-database database)) - (let ((timestamp (resource-database-value database))) - (setf (resource-database-value database) - (if (= timestamp most-positive-fixnum) - most-negative-fixnum - (1+ timestamp))))) - -;; DEBUG FUNCTION (not exported) -(defun print-db (entry &optional (level 0) type) - ;; Debug function to print a resource database - (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" - level - (resource-database-name entry) - (eq type 'loose) - (resource-database-value entry)) - (when (resource-database-tight entry) - (dolist (tight (resource-database-tight entry)) - (print-db tight (+ 2 level) 'tight))) - (when (resource-database-loose entry) - (dolist (loose (resource-database-loose entry)) - (print-db loose (+ 2 level) 'loose)))) - -;; DEBUG FUNCTION -#+comment -(defun print-search-table (table) - (terpri) - (dolist (dbase-list table) - (format t "~%~s" dbase-list) - (dolist (db dbase-list) - (print-db db) - (dolist (dblist table) - (unless (eq dblist dbase-list) - (when (member db dblist) - (format t " duplicate at ~s" db)))) - ))) - -;; -;; If this is true, resource symbols will be compared in a case-insensitive -;; manner, and converting a resource string to a keyword will uppercaseify it. -;; -(defparameter *uppercase-resource-symbols* nil) - -(defun resource-key (stringable) - ;; Ensure STRINGABLE is a keyword. - (declare (type stringable stringable)) - (etypecase stringable - (symbol - (if (keywordp (the symbol stringable)) - stringable - (kintern (symbol-name (the symbol stringable))))) - (string - (if *uppercase-resource-symbols* - (setq stringable (#-allegro string-upcase #+allegro correct-case - (the string stringable)))) - (kintern (the string stringable))))) - -(defun stringable-equal (a b) - ;; Compare two stringables. - ;; Ignore case when comparing to a symbol. - (declare (type stringable a b)) - (declare (clx-values generalized-boolean)) - (etypecase a - (string - (etypecase b - (string - (string= (the string a) (the string b))) - (symbol - (if *uppercase-resource-symbols* - (string-equal (the string a) - (the string (symbol-name (the symbol b)))) - (string= (the string a) - (the string (symbol-name (the symbol b)))))))) - (symbol - (etypecase b - (string - (if *uppercase-resource-symbols* - (string-equal (the string (symbol-name (the symbol a))) - (the string b)) - (string= (the string (symbol-name (the symbol a))) - (the string b)))) - (symbol - (string= (the string (symbol-name (the symbol a))) - (the string (symbol-name (the symbol b))))))))) - - -;;;----------------------------------------------------------------------------- -;;; Add/delete resource - -(defun add-resource (database name-list value) - ;; name-list is a list of either strings or symbols. If a symbol, - ;; case-insensitive comparisons will be used, if a string, - ;; case-sensitive comparisons will be used. The symbol '* or - ;; string "*" are used as wildcards, matching anything or nothing. - (declare (type resource-database database) - (type (clx-list stringable) name-list) - (type t value)) - (unless value (error "Null resource values are ignored")) - (incf-resource-database-timestamp database) - (do* ((list name-list (cdr list)) - (name (car list) (car list)) - (node database) - (loose-p nil)) - ((endp list) - (setf (resource-database-value node) value)) - ;; Key is the first name that isn't * - (if (stringable-equal name "*") - (setq loose-p t) - ;; find the entry associated with name - (progn - (do ((entry (if loose-p - (resource-database-loose node) - (resource-database-tight node)) - (cdr entry))) - ((endp entry) - ;; Entry not found - create a new one - (setq entry (make-resource-database-internal :name name)) - (if loose-p - (push entry (resource-database-loose node)) - (push entry (resource-database-tight node))) - (setq node entry)) - (when (stringable-equal name (resource-database-name (car entry))) - ;; Found entry - use it - (return (setq node (car entry))))) - (setq loose-p nil))))) - - -(defun delete-resource (database name-list) - (declare (type resource-database database) - (type list name-list)) - (incf-resource-database-timestamp database) - (delete-resource-internal database name-list)) - -(defun delete-resource-internal (database name-list) - (declare (type resource-database database) - (type (clx-list stringable) name-list)) - (do* ((list name-list (cdr list)) - (string (car list) (car list)) - (node database) - (loose-p nil)) - ((endp list) nil) - ;; Key is the first name that isn't * - (if (stringable-equal string "*") - (setq loose-p t) - ;; find the entry associated with name - (progn - (do* ((first-entry (if loose-p - (resource-database-loose node) - (resource-database-tight node))) - (entry-list first-entry (cdr entry-list)) - (entry (car entry-list) (car entry-list))) - ((endp entry-list) - ;; Entry not found - exit - (return-from delete-resource-internal nil)) - (when (stringable-equal string (resource-database-name entry)) - (when (cdr list) (delete-resource-internal entry (cdr list))) - (when (and (null (resource-database-loose entry)) - (null (resource-database-tight entry))) - (if loose-p - (setf (resource-database-loose node) - (delete entry (resource-database-loose node) - :test #'eq :count 1)) - (setf (resource-database-tight node) - (delete entry (resource-database-tight node) - :test #'eq :count 1)))) - (return-from delete-resource-internal t))) - (setq loose-p nil))))) - -;;;----------------------------------------------------------------------------- -;;; Get Resource - -(defun get-resource (database value-name value-class full-name full-class) - ;; Return the value of the resource in DATABASE whose partial name - ;; most closely matches (append full-name (list value-name)) and - ;; (append full-class (list value-class)). - (declare (type resource-database database) - (type stringable value-name value-class) - (type (clx-list stringable) full-name full-class)) - (declare (clx-values value)) - (let ((names (append full-name (list value-name))) - (classes (append full-class (list value-class)))) - (let* ((result (get-entry (resource-database-tight database) - (resource-database-loose database) - names classes))) - (when result - (resource-database-value result))))) - -(defun get-entry-lookup (table name names classes) - (declare (type list table names classes) - (symbol name)) - (dolist (entry table) - (declare (type resource-database entry)) - (when (stringable-equal name (resource-database-name entry)) - (if (null (cdr names)) - (return entry) - (let ((result (get-entry (resource-database-tight entry) - (resource-database-loose entry) - (cdr names) (cdr classes)))) - (declare (type (or null resource-database) result)) - (when result - (return result) - )))))) - -(defun get-entry (tight loose names classes &aux result) - (declare (type list tight loose names classes)) - (let ((name (car names)) - (class (car classes))) - (declare (type symbol name class)) - (cond ((and tight - (get-entry-lookup tight name names classes))) - ((and loose - (get-entry-lookup loose name names classes))) - ((and tight - (not (stringable-equal name class)) - (get-entry-lookup tight class names classes))) - ((and loose - (not (stringable-equal name class)) - (get-entry-lookup loose class names classes))) - (loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (when (setq result (get-entry-lookup loose name names classes)) - (return result)) - (when (and (not (stringable-equal name class)) - (setq result - (get-entry-lookup loose class names classes))) - (return result)) - ))))) - - -;;;----------------------------------------------------------------------------- -;;; Get-resource with search-table - -(defun get-search-resource (table name class) - ;; (get-search-resource (get-search-table database full-name full-class) - ;; value-name value-class) - ;; is equivalent to - ;; (get-resource database value-name value-class full-name full-class) - ;; But since most of the work is done by get-search-table, - ;; get-search-resource is MUCH faster when getting several resources with - ;; the same full-name/full-class - (declare (type list table) - (type stringable name class)) - (let ((do-class (and class (not (stringable-equal name class))))) - (dolist (dbase-list table) - (declare (type list dbase-list)) - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal name (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))) - (when do-class - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal class (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))))))) - -(defvar *get-table-result*) - -(defun get-search-table (database full-name full-class) - ;; Return a search table for use with get-search-resource. - (declare (type resource-database database) - (type (clx-list stringable) full-name full-class)) - (declare (clx-values value)) - (let* ((tight (resource-database-tight database)) - (loose (resource-database-loose database)) - (result (cons nil nil)) - (*get-table-result* result)) - (declare (type list tight loose) - (type cons result)) - (when (or tight loose) - (when full-name - (get-tables tight loose full-name full-class)) - - ;; Pick up bindings of the form (* name). These are the elements of - ;; top-level loose without further tight/loose databases. - ;; - ;; (Hack: these bindings belong in ANY search table, so recomputing them - ;; is a drag. True fix involves redesigning entire lookup - ;; data-structure/algorithm.) - ;; - (let ((universal-bindings - (remove nil loose :test-not #'eq - :key #'(lambda (database) - (or (resource-database-tight database) - (resource-database-loose database)))))) - (when universal-bindings - (setf (cdr *get-table-result*) (list universal-bindings))))) - (cdr result))) - -(defun get-tables-lookup (dbase name names classes) - (declare (type list dbase names classes) - (type symbol name)) - (declare (optimize speed)) - (dolist (entry dbase) - (declare (type resource-database entry)) - (when (stringable-equal name (resource-database-name entry)) - (let ((tight (resource-database-tight entry)) - (loose (resource-database-loose entry))) - (declare (type list tight loose)) - (when (or tight loose) - (if (cdr names) - (get-tables tight loose (cdr names) (cdr classes)) - (when tight - (let ((result *get-table-result*)) - ;; Put tight at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons tight nil)))))) - (when loose - (let ((result *get-table-result*)) - ;; Put loose at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons loose nil)))))))))) - -(defun get-tables (tight loose names classes) - (declare (type list tight loose names classes)) - (let ((name (car names)) - (class (car classes))) - (declare (type symbol name class)) - (when tight - (get-tables-lookup tight name names classes)) - (when loose - (get-tables-lookup loose name names classes)) - (when (and tight (not (stringable-equal name class))) - (get-tables-lookup tight class names classes)) - (when (and loose (not (stringable-equal name class))) - (get-tables-lookup loose class names classes)) - (when loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (get-tables-lookup loose name names classes) - (unless (stringable-equal name class) - (get-tables-lookup loose class names classes)) - )))) - - -;;;----------------------------------------------------------------------------- -;;; Utility functions - -(defun map-resource (database function &rest args) - ;; Call FUNCTION on each resource in DATABASE. - ;; FUNCTION is called with arguments (name-list value . args) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function) - (dynamic-extent args)) - (declare (clx-values nil)) - (labels ((map-resource-internal (database function args name) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - (type list name) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (let ((tight (resource-database-tight database)) - (loose (resource-database-loose database))) - (declare (type list tight loose)) - (dolist (resource tight) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name)))) - (dolist (resource loose) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list "*" (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name))))))) - (map-resource-internal database function args nil))) - -(defun merge-resources (database with-database) - (declare (type resource-database database with-database)) - (declare (clx-values resource-database)) - (map-resource - database - #'(lambda (name value database) - (add-resource database name value)) - with-database) - with-database) - -(defun char-memq (key char) - ;; Used as a test function for POSITION - (declare (type base-char char)) - (member char key)) - -(defmacro resource-with-open-file ((stream pathname &rest options) &body body) - ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the - ;; stream - (let ((abortp (gensym)) - (streamp (gensym))) - `(let* ((,abortp t) - (,streamp (streamp pathname)) - (,stream (if ,streamp pathname (open ,pathname ,@options)))) - (unwind-protect - (multiple-value-prog1 - (progn ,@body) - (setq ,abortp nil)) - (unless ,streamp - (close stream :abort ,abortp)))))) - -(defun read-resources (database pathname &key key test test-not) - ;; Merges resources from a file in standard X11 format with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (declare (clx-values resource-database)) - (resource-with-open-file (stream pathname) - (loop - (let ((string (read-line stream nil :eof))) - (declare (type (or string keyword) string)) - (when (eq string :eof) (return database)) - (let* ((end (length string)) - (i (position '(#\tab #\space) string - :test-not #'char-memq :end end)) - (term nil)) - (declare (type array-index end) - (type (or null array-index) i term)) - (when i ;; else blank line - (case (char string i) - (#\! nil) ;; Comment - skip - ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip - (#\# ;; Include - (setq term (position '(#\tab #\space) string :test #'char-memq - :start i :end end)) - (when (string-equal string "#INCLUDE" :start1 i :end1 term) - (let ((path (merge-pathnames - (string-trim '(#\tab #\space #\") - (subseq string (1+ term))) - (truename stream)))) - (read-resources database path - :key key :test test :test-not test-not)))) - (otherwise - (multiple-value-bind (name-list value) - (parse-resource string i end) - (when name-list - (when key (setq value (funcall key value))) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (add-resource database name-list value)))))))))))) - -(defun parse-resource (string &optional (start 0) end) - ;; Parse a resource specfication string into a list of names and a value - ;; string - (declare (type string string) - (type array-index start) - (type (or null array-index) end)) - (declare (clx-values name-list value)) - (do ((i start) - (end (or end (length string))) - (term) - (name-list)) - ((>= i end)) - (declare (type array-index end) - (type (or null array-index) i term)) - (setq term (position '(#\. #\* #\:) string - :test #'char-memq :start i :end end)) - (case (and term (char string term)) - ;; Name seperator - (#\. (when (> term i) - (push (subseq string i term) name-list))) - ;; Wildcard seperator - (#\* (when (> term i) - (push (subseq string i term) name-list)) - (push '* name-list)) - ;; Value separator - (#\: - (push (subseq string i term) name-list) - (return - (values - (nreverse name-list) - (string-trim '(#\tab #\space) (subseq string (1+ term)))))) - (otherwise - (return - (values - (nreverse name-list) - (subseq string i term))))) - (setq i (1+ term)))) - -(defun write-resources (database pathname &key write test test-not) - ;; Write resources to PATHNAME in the standard X11 format. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (resource-with-open-file (stream pathname :direction :output) - (map-resource - database - #'(lambda (name-list value stream write test test-not) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (let ((previous (car name-list))) - (princ previous stream) - (dolist (name (cdr name-list)) - (unless (or (stringable-equal name "*") - (stringable-equal previous "*")) - (write-char #\. stream)) - (setq previous name) - (princ name stream))) - (write-string ": " stream) - (funcall write value stream) - (terpri stream))) - stream (or write #'princ) test test-not)) - database) - -(defun wm-resources (database window &key key test test-not) - ;; Takes the resources associated with the RESOURCE_MANAGER property - ;; of WINDOW (if any) and merges them with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type window window) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (declare (clx-values resource-database)) - (let ((string (get-property window :RESOURCE_MANAGER :type :STRING - :result-type 'string - :transform #'xlib::card8->char))) - (when string - (with-input-from-string (stream string) - (read-resources database stream - :key key :test test :test-not test-not))))) - -(defun set-wm-resources (database window &key write test test-not) - ;; Sets the resources associated with the RESOURCE_MANAGER property - ;; of WINDOW. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type window window) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (xlib::set-string-property - window :RESOURCE_MANAGER - (with-output-to-string (stream) - (write-resources database stream :write write - :test test :test-not test-not)))) - -(defun root-resources (screen &key database key test test-not) - "Returns a resource database containing the contents of the root window - RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, - then its default screen is used. If an existing DATABASE is given, then - resource values are merged with the DATABASE and the modified DATABASE is - returned. - - TEST and TEST-NOT are predicates for selecting which resources are - read. Arguments are a resource name list and a resource value. The KEY - function, if given, is called to convert a resource value string to the - value given to TEST or TEST-NOT." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) test test-not) - (clx-values resource-database)) - (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen)) - (database (or database (make-resource-database)))) - (wm-resources database window :key key :test test :test-not test-not) - database)) - -(defun set-root-resources (screen &key test test-not (write #'princ) database) - "Changes the contents of the root window RESOURCE_MANAGER property for the - given SCREEN. If SCREEN is a display, then its default screen is used. - - TEST and TEST-NOT are predicates for selecting which resources from the - DATABASE are written. Arguments are a resource name list and a resource - value. The WRITE function is used to convert a resource value into a - string stored in the property." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (list t) generalized-boolean)) test test-not) - (type (or null (function (string stream) t)) write) - (clx-values resource-database)) - (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen))) - (set-wm-resources database window - :write write :test test :test-not test-not) - database)) - -(defsetf root-resources (screen &key test test-not (write #'princ))(database) - `(set-root-resources - ,screen :test ,test :test-not ,test-not :write ,write :database ,database)) - -(defun initialize-resource-database (display) - ;; This function is (supposed to be) equivalent to the Xlib initialization - ;; code. - (declare (type display display)) - (let ((rdb (make-resource-database)) - (rootwin (screen-root (car (display-roots display))))) - ;; First read the server defaults if present, otherwise from the default - ;; resource file - (if (get-property rootwin :RESOURCE_MANAGER) - (xlib:wm-resources rdb rootwin) - (let ((path (default-resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path)))) - ;; Next read from the resources file - (let ((path (resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path))) - (setf (display-xdefaults display) rdb))) diff --git a/src/clx/screensaver.lisp b/src/clx/screensaver.lisp deleted file mode 100644 index 42dcf48b0..000000000 --- a/src/clx/screensaver.lisp +++ /dev/null @@ -1,69 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: X11 MIT Screensaver extension -;;; Created: 2005-08-28 01:41 -;;; Author: Istvan Marko -;;; --------------------------------------------------------------------------- -;;; (c) copyright 2005 by Istvan Marko - -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -;;; - -;;; Description: -;;; -;;; This is a partial interface to the MIT-SCREEN-SAVER -;;; extension. Only the ScreenSaverQueryVersion and -;;; ScreenSaverQueryInfo requests are implemented because I couldn't -;;; think of a use for the rest. In fact, the only use I see for this -;;; extension is screen-saver-get-idle which provides and easy way to -;;; find out how long has it been since the last keyboard or mouse -;;; activity. - -;;; A description of this extension can be found at -;;; doc/hardcopy/saver/saver.PS.gz in the X11 distribution. - -(in-package :xlib) - -(export '(screen-saver-query-version - screen-saver-query-info - screen-saver-get-idle) - :xlib) - -(define-extension "MIT-SCREEN-SAVER") - -(defun screen-saver-query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") - nil) - ((data 0) - (card8 1) ;client major version - (card8 0) ;client minor version - (card16 0)) ; unused - (values - (card16-get 8) ; server major version - (card16-get 10)))) ; server minor version - -(defun screen-saver-query-info (display drawable) - (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") - nil) - ((data 1) - (drawable drawable)) - (values - (card8-get 1) ; state: off, on, disabled - (window-get 8) ; screen saver window if active - (card32-get 12) ; tilorsince msecs. how soon before the screen saver kicks in or how long has it been active - (card32-get 16) ; idle msecs - (card8-get 24)))) ; kind: Blanked, Internal, External - -(defun screen-saver-get-idle (display drawable) - "How long has it been since the last keyboard or mouse input" - (multiple-value-bind (state window tilorsince idle kind) (screen-saver-query-info display drawable) - (declare (ignore state window kind)) - (values idle tilorsince))) diff --git a/src/clx/shape.lisp b/src/clx/shape.lisp deleted file mode 100644 index 6171c67ca..000000000 --- a/src/clx/shape.lisp +++ /dev/null @@ -1,192 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: X11 Shape extension -;;; Created: 1999-05-14 11:31 -;;; Author: Gilbert Baumann -;;; --------------------------------------------------------------------------- -;;; (c) copyright 1999 by Gilbert Baumann - -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -;;; - -;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. -;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz - -(in-package :xlib) - -(export '(shape-query-version - shape-rectangles - shape-mask - shape-combine - shape-offset - shape-query-extents - shape-select-input - shape-input-selected-p - shape-get-rectangles) - :xlib) - -(define-extension "SHAPE" - :events (:shape-notify)) - -(declare-event :shape-notify - ((data (member8 :bounding :clip)) kind) ;shape kind - (card16 sequence) - (window (window event-window)) ;affected window - (int16 x) ;extents - (int16 y) - (card16 width) - (card16 height) - ((or null card32) time) ;timestamp - (boolean shaped-p)) - -(defun encode-shape-kind (kind) - (ecase kind - (:bounding 0) - (:clip 1))) - -(defun encode-shape-operation (operation) - (ecase operation - (:set 0) - (:union 1) - (:interset 2) - (:subtract 3) - (:invert 4))) - -(defun encode-shape-rectangle-ordering (ordering) - (ecase ordering - ((:unsorted :un-sorted nil) 0) - ((:y-sorted) 1) - ((:yx-sorted) 2) - ((:yx-banded) 3))) - -(defun shape-query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes 16) - ((data 0)) - (values - (card16-get 8) - (card16-get 10)))) - -(defun shape-rectangles (window rectangles - &key (kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set) - (ordering :unsorted)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 1) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card8 (encode-shape-rectangle-ordering ordering)) - (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - ((sequence :format int16) rectangles)))) - -(defun shape-mask (window pixmap - &key (kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 2) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card16 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - ((or pixmap (member :none)) pixmap)))) - -(defun shape-combine (window source-window - &key (kind :bounding) - (source-kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 3) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card8 (encode-shape-kind source-kind)) - (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - (window source-window)))) - -(defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 4) - (card8 (encode-shape-kind kind)) - (card8 0) (card8 0) (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset)))) - -(defun shape-query-extents (window) - (let* ((display (xlib:window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8 16 32)) - ((data 5) - (window window)) - (values - (boolean-get 8) ;bounding shaped - (boolean-get 9) ;clip shaped - (int16-get 12) ;bounding shape extents x - (int16-get 14) ;bounding shape extents y - (card16-get 16) ;bounding shape extents width - (card16-get 18) ;bounding shape extents height - (int16-get 20) ;clip shape extents x - (int16-get 22) ;clip shape extents y - (card16-get 24) ;clip shape extents width - (card16-get 26))))) ;clip shape extents height - -(defun shape-select-input (window selected-p) - (let* ((display (window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 6) - (window window) - (boolean selected-p)) )) - -(defun shape-input-selected-p (window) - (let* ((display (window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8)) - ((data 7) ;also wrong in documentation - (window window)) - (boolean-get 1)))) - -(defun shape-get-rectangles (window &optional (kind :bounding) - (result-type 'list)) - (let* ((display (window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8 16 32)) - ((data 8) ;this was wrong in the specification - (window window) - (card8 (ecase kind - (:bounding 0) - (:clip 1)))) - (values - (sequence-get :length (print (* 4 (card32-get 8))) - :result-type result-type - :format int16 - :index +replysize+) - (ecase (card8-get 1) - (0 :unsorted) - (1 :y-sorted) - (2 :yx-sorted) - (3 :yx-banded) ))))) diff --git a/src/clx/sockcl.lisp b/src/clx/sockcl.lisp deleted file mode 100644 index 67ac2ef05..000000000 --- a/src/clx/sockcl.lisp +++ /dev/null @@ -1,163 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;;; Server Connection for kcl and ibcl - -;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Massachussetts Institute of Technology provides this software "as is" -;;; without express or implied warranty. -;;; - -;;; Adapted from code by Roman Budzianowski - Project Athena/MIT - -;;; make-two-way-stream is probably not a reasonable thing to do. -;;; A close on a two way stream probably does not close the substreams. -;;; I presume an :io will not work (maybe because it uses 1 buffer?). -;;; There should be some fast io (writes and reads...). - -;;; Compile this file with compile-file. -;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") - -(in-package :xlib) - -;;; The cmpinclude.h file does not have this type definition from -;;; /h/object.h. We include it here so the -;;; compile-file will work without figuring out where the distribution -;;; directory is located. -;;; -(CLINES " -enum smmode { /* stream mode */ - smm_input, /* input */ - smm_output, /* output */ - smm_io, /* input-output */ - smm_probe, /* probe */ - smm_synonym, /* synonym */ - smm_broadcast, /* broadcast */ - smm_concatenated, /* concatenated */ - smm_two_way, /* two way */ - smm_echo, /* echo */ - smm_string_input, /* string input */ - smm_string_output, /* string output */ - smm_user_defined /* for user defined */ -}; -") - -#-akcl -(CLINES " -struct stream { - short t, m; - FILE *sm_fp; /* file pointer */ - object sm_object0; /* some object */ - object sm_object1; /* some object */ - int sm_int0; /* some int */ - int sm_int1; /* some int */ - short sm_mode; /* stream mode */ - /* of enum smmode */ -}; -") - - -;;;; Connect to the server. - -;;; A lisp string is not a reasonable type for C, so copy the characters -;;; out and then call connect_to_server routine defined in socket.o - -(CLINES " -int -konnect_to_server(host,display) - object host; /* host name */ - int display; /* display number */ -{ - int fd; /* file descriptor */ - int i; - char hname[BUFSIZ]; - FILE *fout, *fin; - - if (host->st.st_fillp > BUFSIZ - 1) - too_long_file_name(host); - for (i = 0; i < host->st.st_fillp; i++) - hname[i] = host->st.st_self[i]; - hname[i] = '\\0'; /* doubled backslash for lisp */ - - fd = connect_to_server(hname,display); - - return(fd); -} -") - -(defentry konnect-to-server (object int) (int "konnect_to_server")) - - -;;;; Make a one-way stream from a file descriptor. - -(CLINES " -object -konnect_stream(host,fd,flag,elem) - object host; /* not really used */ - int fd; /* file descriptor */ - int flag; /* 0 input, 1 output */ - object elem; /* 'string-char */ -{ - struct stream *stream; - char *mode; /* file open mode */ - FILE *fp; /* file pointer */ - enum smmode smm; /* lisp mode (a short) */ - vs_mark; - - switch(flag){ - case 0: - smm = smm_input; - mode = \"r\"; - break; - case 1: - smm = smm_output; - mode = \"w\"; - break; - default: - FEerror(\"konnect_stream : wrong mode\"); - } - - fp = fdopen(fd,mode); - - if (fp == NULL) { - stream = Cnil; - vs_push(stream); - } else { - stream = alloc_object(t_stream); - stream->sm_mode = (short)smm; - stream->sm_fp = fp; - stream->sm_object0 = elem; - stream->sm_object1 = host; - stream->sm_int0 = stream->sm.sm_int1 = 0; - vs_push(stream); - setbuf(fp, alloc_contblock(BUFSIZ)); - } - vs_reset; - return(stream); -} -") - -(defentry konnect-stream (object int int object) (object "konnect_stream")) - - -;;;; Open an X stream - -(defun open-socket-stream (host display) - (when (not (and (typep host 'string) ; sanity check the arguments - (typep display 'fixnum))) - (error "Host ~s or display ~s are bad." host display)) - - (let ((fd (konnect-to-server host display))) ; get a file discriptor - (if (< fd 0) - NIL - (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input - (stream-out (konnect-stream host fd 1 'string-char))) ; output - (if (or (null stream-in) (null stream-out)) - (error "Could not make i/o streams for fd ~d." fd)) - (make-two-way-stream stream-in stream-out)) - ))) diff --git a/src/clx/socket.c b/src/clx/socket.c deleted file mode 100644 index d121f7b14..000000000 --- a/src/clx/socket.c +++ /dev/null @@ -1,156 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* Copyright Massachusetts Institute of Technology 1988 */ -/* - * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived - * systems. VMS and System V should plan to have their own version. - * - * This code was cribbed from lib/X/XConnDis.c. - * Compile using - * % cc -c socket.c -DUNIXCONN - */ - -#include -#include -#include -#include -#include -#include -#include -#include -#ifndef hpux -#include -#endif - -extern int errno; /* Certain (broken) OS's don't have this */ - /* decl in errno.h */ - -#ifdef UNIXCONN -#include -#ifndef X_UNIX_PATH -#ifdef hpux -#define X_UNIX_PATH "/usr/spool/sockets/X11/" -#define OLD_UNIX_PATH "/tmp/.X11-unix/X" -#else /* hpux */ -#define X_UNIX_PATH "/tmp/.X11-unix/X" -#endif /* hpux */ -#endif /* X_UNIX_PATH */ -#endif /* UNIXCONN */ - -#ifndef hpux -void bcopy(); -#endif /* hpux */ - -/* - * Attempts to connect to server, given host and display. Returns file - * descriptor (network socket) or 0 if connection fails. - */ - -int connect_to_server (host, display) - char *host; - int display; -{ - struct sockaddr_in inaddr; /* INET socket address. */ - struct sockaddr *addr; /* address to connect to */ - struct hostent *host_ptr; - int addrlen; /* length of address */ -#ifdef UNIXCONN - struct sockaddr_un unaddr; /* UNIX socket address. */ -#endif - extern char *getenv(); - extern struct hostent *gethostbyname(); - int fd; /* Network socket */ - { -#ifdef UNIXCONN - if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { - /* Connect locally using Unix domain. */ - unaddr.sun_family = AF_UNIX; - (void) strcpy(unaddr.sun_path, X_UNIX_PATH); - (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); - addr = (struct sockaddr *) &unaddr; - addrlen = strlen(unaddr.sun_path) + 2; - /* - * Open the network connection. - */ - if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { -#ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ - if (errno == ENOENT) { /* No such file or directory */ - (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); - addrlen = strlen(unaddr.sun_path) + 2; - if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) - return(-1); /* errno set by most recent system call. */ - } else -#endif /* hpux */ - return(-1); /* errno set by system call. */ - } - } else -#endif /* UNIXCONN */ - { - /* Get the statistics on the specified host. */ - if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) - { - if ((host_ptr = gethostbyname(host)) == NULL) - { - /* No such host! */ - errno = EINVAL; - return(-1); - } - /* Check the address type for an internet host. */ - if (host_ptr->h_addrtype != AF_INET) - { - /* Not an Internet host! */ - errno = EPROTOTYPE; - return(-1); - } - /* Set up the socket data. */ - inaddr.sin_family = host_ptr->h_addrtype; -#ifdef hpux - (void) memcpy((char *)&inaddr.sin_addr, - (char *)host_ptr->h_addr, - sizeof(inaddr.sin_addr)); -#else /* hpux */ - (void) bcopy((char *)host_ptr->h_addr, - (char *)&inaddr.sin_addr, - sizeof(inaddr.sin_addr)); -#endif /* hpux */ - } - else - { - inaddr.sin_family = AF_INET; - } - addr = (struct sockaddr *) &inaddr; - addrlen = sizeof (struct sockaddr_in); - inaddr.sin_port = display + X_TCP_PORT; - inaddr.sin_port = htons(inaddr.sin_port); - /* - * Open the network connection. - */ - if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ - return(-1); /* errno set by system call. */} - /* make sure to turn off TCP coalescence */ -#ifdef TCP_NODELAY - { - int mi = 1; - setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); - } -#endif - } - - /* - * Changed 9/89 to retry connection if system call was interrupted. This - * is necessary for multiprocessing implementations that use timers, - * since the timer results in a SIGALRM. -- jdi - */ - while (connect(fd, addr, addrlen) == -1) { - if (errno != EINTR) { - (void) close (fd); - return(-1); /* errno set by system call. */ - } - } - } - /* - * Return the id if the connection succeeded. - */ - return(fd); -} diff --git a/src/clx/test/.cvsignore b/src/clx/test/.cvsignore deleted file mode 100644 index be303db03..000000000 --- a/src/clx/test/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.fasl diff --git a/src/clx/test/image.lisp b/src/clx/test/image.lisp deleted file mode 100644 index 367b983e9..000000000 --- a/src/clx/test/image.lisp +++ /dev/null @@ -1,160 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; Tests image code by randomly reading, copying and then writing images to -;;; the exact same place on the screen. If everything works, just the borders -;;; of the image windows appear. If one of these image windows is garbled, -;;; then somewhere something is broken. Entry point is the function -;;; IMAGE-TEST - -(in-package :xlib) - -(export '(image-test)) - -(defvar *image-test-host* "") - -(defvar *image-test-nimages* 25) - -(defvar *image-test-copy* t) - -(defvar *image-test-copy-random-subimage* t) - -(defvar *image-test-put-random-subimage* t) - -(defvar *image-test-get-image-result-type-choices* - '(image-x image-x image-xy image-z)) - -(defvar *image-test-get-image-image-x-format-choices* - '(:xy-pixmap :z-pixmap)) - -(defun image-test - (&key - (host *image-test-host*) - (nimages *image-test-nimages*) - (copy *image-test-copy*) - (copy-random-subimage *image-test-copy-random-subimage*) - (put-random-subimage *image-test-put-random-subimage*) - (get-image-result-type-choices - *image-test-get-image-result-type-choices*) - (get-image-image-x-format-choices - *image-test-get-image-image-x-format-choices*)) - (declare (ignore host)) - (let* ((display nil) - (abort t) - (images nil)) - (loop - (setq images nil) - (unwind-protect - (progn - (setq display (open-default-display)) - (let* ((screen (display-default-screen display)) - (window (screen-root screen)) - (gcontext (create-gcontext - :foreground (screen-white-pixel screen) - :background (screen-black-pixel screen) - :drawable window - :font (open-font display "fixed")))) - (dotimes (i nimages) - (let ((image (image-test-get-image - window - get-image-result-type-choices - get-image-image-x-format-choices))) - (format t "~&Image=~S~%" image) - (let ((copy (if copy - (image-test-copy-image - image - copy-random-subimage) - image))) - (format t "~&Copy=~S~%" copy) - (push (list image copy) images) - (image-test-put-image - screen gcontext copy - (concatenate - 'string (image-info image) (image-info copy)) - put-random-subimage)))) - (unless (y-or-n-p "More ") (return)) - (setq abort nil))) - (close-display (shiftf display nil) :abort abort)) - (sleep 10)) - (reverse images))) - -(defun image-test-choose (list) - (nth (random (length list)) list)) - -(defun image-test-get-image (window result-type-choices image-x-format-choices) - (let* ((x (random (floor (drawable-width window) 3))) - (y (random (floor (drawable-height window) 3))) - (hw (floor (- (drawable-width window) x) 3)) - (hh (floor (- (drawable-height window) y) 3)) - (width (+ hw hw (random hw))) - (height (+ hh hh (random hh))) - (result-type (image-test-choose result-type-choices)) - (format - (ecase result-type - (image-x (image-test-choose image-x-format-choices)) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (image (get-image window :x x :y y :width width :height height - :format format :result-type result-type))) - (setf (getf (image-plist image) :root-x) x) - (setf (getf (image-plist image) :root-y) y) - image)) - -(defun image-test-subimage-parameters (image random-subimage-p) - (if random-subimage-p - (let* ((x (random (floor (image-width image) 3))) - (y (random (floor (image-height image) 3))) - (hw (floor (- (image-width image) x) 3)) - (hh (floor (- (image-height image) y) 3)) - (width (+ hw hw (random hw))) - (height (+ hh hh (random hh)))) - (values x y width height)) - (values 0 0 (image-width image) (image-height image)))) - -(defun image-test-copy-image (image random-subimage-p) - (let ((result-type - (if (zerop (random 2)) - (type-of image) - (etypecase image - (image-x (ecase (image-x-format image) - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z))) - ((or image-xy image-z) 'image-x))))) - (multiple-value-bind (x y width height) - (image-test-subimage-parameters image random-subimage-p) - (incf (getf (image-plist image) :root-x) x) - (incf (getf (image-plist image) :root-y) y) - (copy-image image :x x :y y :width width :height height - :result-type result-type)))) - -(defun image-test-put-image (screen gcontext image info random-subimage-p) - (multiple-value-bind (src-x src-y width height) - (image-test-subimage-parameters image random-subimage-p) - (let* ((border-width 1) - (root-x (getf (image-plist image) :root-x)) - (root-y (getf (image-plist image) :root-y)) - (x (+ src-x root-x (- border-width))) - (y (+ src-y root-y (- border-width)))) - (unless (or (zerop width) (zerop height)) - (let ((window - (create-window - :parent (screen-root screen) :x x :y y - :width width :height height - :border-width border-width - :background (screen-white-pixel screen) - :override-redirect :on))) - (map-window window) - (display-finish-output (drawable-display window)) - (put-image window gcontext image - :x 0 :y 0 :src-x src-x :src-y src-y - :width width :height height) - (draw-image-glyphs window gcontext 0 (1- height) info) - (display-finish-output (drawable-display window)) - window))))) - -(defun image-info (image) - (etypecase image - (image-x (ecase (image-x-format image) - (:xy-pixmap "XXY") - (:z-pixmap "XZ "))) - (image-xy "XY ") - (image-z "Z "))) diff --git a/src/clx/test/trapezoid.lisp b/src/clx/test/trapezoid.lisp deleted file mode 100644 index 8952a2a94..000000000 --- a/src/clx/test/trapezoid.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX trapezoid Extension test 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 zoid-test () - ;; Display the part picture in /extensions/test/datafile - (let* ((display (open-default-display)) - (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)) - (gc (create-gcontext - :drawable win - :background black - :foreground white))) - (initialize-extensions display) - - (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) - ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES - (draw-filled-trapezoids window gc '(10 20 30 40 100 200)) - (setf (gcontext-trapezoid-alignment gc) :y) - (draw-filled-trapezoids window gc #(10 20 30 40 100 200)) - (with-gcontext (gc :trapezoid-alignment :x) - (draw-filled-trapezoids window gc '(40 50 60 70 140 240))) - (setf (gcontext-trapezoid-alignment gc) :x) - (draw-filled-trapezoids window gc #(40 50 60 70 80 90)) - (with-gcontext (gc :trapezoid-alignment :y) - (draw-filled-trapezoids window gc #(40 50 60 70 140 240))) - - (draw-glyphs window gc 10 10 "Press any key to exit") - ;; Returning non-nil causes event-case to exit - t)) - (key-press () (return-from zoid-test t)))) - (close-display display)))) diff --git a/src/clx/text.lisp b/src/clx/text.lisp deleted file mode 100644 index 167c0c418..000000000 --- a/src/clx/text.lisp +++ /dev/null @@ -1,1084 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; CLX text keyboard and pointer requests - -;;; -;;; 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) - -;; Strings are broken up into chunks of this size -(defparameter *max-string-size* 254) - -;; In the functions below, the transform is used to convert an element of the -;; sequence into a font index. The transform is applied to each element of the -;; (sub)sequence, until either the transform returns nil or the end of the -;; (sub)sequence is reached. If transform returns nil for an element, the -;; index of that element in the sequence is returned, otherwise nil is -;; returned. - -(deftype translation-function () - #+explorer t - #-explorer - '(function (sequence array-index array-index (or null font) vector array-index) - (values array-index (or null int16 font) (or null int32)))) - -;; In the functions below, if width is specified, it is assumed to be the pixel -;; width of whatever string of glyphs is actually drawn. Specifying width will -;; allow for appending the output of subsequent calls to the same protocol -;; request, provided gcontext has not been modified in the interim. If width -;; is not specified, appending of subsequent output might not occur. -;; Specifying width is simply a hint, for performance. Note that specifying -;; width may be difficult if transform can return nil. - -(defun translate-default (src src-start src-end font dst dst-start) - ;; dst is guaranteed to have room for (- src-end src-start) integer elements, - ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends - ;; on context. font is the current font, if known. The function should - ;; translate as many elements of src as possible into indexes in the current - ;; font, and store them into dst. - ;; - ;; The first return value should be the src index of the first untranslated - ;; element. If no further elements need to be translated, the second return - ;; value should be nil. If a horizontal motion is required before further - ;; translation, the second return value should be the delta in x coordinate. - ;; If a font change is required for further translation, the second return - ;; value should be the new font. If known, the pixel width of the translated - ;; text can be returned as the third value; this can allow for appending of - ;; subsequent output to the same protocol request, if no overall width has - ;; been specified at the higher level. - ;; (returns values: ending-index - ;; (OR null horizontal-motion font) - ;; (OR null translated-width)) - (declare (type sequence src) - (type array-index src-start src-end dst-start) - (type (or null font) font) - (type vector dst) - (inline graphic-char-p)) - (declare (clx-values integer (or null integer font) (or null integer))) - - (let ((min-char-index (and font (xlib:font-min-char font))) - (max-char-index (and font (xlib:font-max-char font)))) - (if (stringp src) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (char)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (setf char (char->card8 (char src i))) - (if (and font (or (< char min-char-index) (> char max-char-index))) - (return i) - (setf (aref dst j) char))) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (elt)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (setq elt (elt src i)) - (when (characterp elt) (setq elt (char->card8 elt))) - (if (or (not (integerp elt)) - (and font - (< elt min-char-index) - (> elt max-char-index))) - (return i) - (setf (aref dst j) elt)))))) - -;; There is a question below of whether translate should always be required, or -;; if not, what the default should be or where it should come from. For -;; example, the default could be something that expected a string as src and -;; translated the CL standard character set to ASCII indexes, and ignored fonts -;; and bits. Or the default could expect a string but otherwise be "system -;; dependent". Or the default could be something that expected a vector of -;; integers and did no translation. Or the default could come from the -;; gcontext (but what about text-extents and text-width?). - -(defun text-extents (font sequence &key (start 0) end translate) - ;; If multiple fonts are involved, font-ascent and font-descent will be the - ;; maximums. If multiple directions are involved, the direction will be nil. - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values width ascent descent left right - font-ascent font-descent direction - (or null array-index))) - (when (type? font 'gcontext) - (force-gcontext-changes font) - (setq font (gcontext-font font t))) - (check-type font font) - (let* ((left-bearing 0) - (right-bearing 0) - ;; Sum of widths - (width 0) - (ascent 0) - (descent 0) - (overall-ascent (font-ascent font)) - (overall-descent (font-descent font)) - (overall-direction (font-direction font)) - (next-start nil) - (display (font-display font))) - (declare (type int16 ascent descent overall-ascent overall-descent) - (type int32 left-bearing right-bearing width) - (type (or null array-index) next-start) - (type display display)) - (with-display (display) - (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start +buffer-text16-size+)) - (index-min src-end (index+ src-start +buffer-text16-size+))) - (buf-end 0) - (new-font) - (font-ascent 0) - (font-descent 0) - (font-direction) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type int16 font-ascent font-descent) - (type generalized-boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (let (w a d l r) - (if (or (font-char-infos-internal font) (font-local-only-p font)) - ;; Calculate text extents locally - (progn - (multiple-value-setq (w a d l r) - (text-extents-local font wbuf 0 buf-end nil)) - (setq font-ascent (the int16 (font-ascent font)) - font-descent (the int16 (font-descent font)) - font-direction (font-direction font))) - ;; Let the server calculate text extents - (multiple-value-setq - (w a d l r font-ascent font-descent font-direction) - (text-extents-server font wbuf 0 buf-end))) - (incf width (the int32 w)) - (cond ((index= src-start start) - (setq left-bearing (the int32 l)) - (setq right-bearing (the int32 r)) - (setq ascent (the int16 a)) - (setq descent (the int16 d))) - (t - (setq left-bearing (the int32 (min left-bearing (the int32 l)))) - (setq right-bearing (the int32 (max right-bearing (the int32 r)))) - (setq ascent (the int16 (max ascent (the int16 a)))) - (setq descent (the int16 (max descent (the int16 d))))))) - - (when (type? new-font 'font) - (setq font new-font)) - - (setq overall-ascent (the int16 (max overall-ascent font-ascent))) - (setq overall-descent (the int16 (max overall-descent font-descent))) - (case overall-direction - (:unknown (setq overall-direction font-direction)) - (:left-to-right (unless (eq font-direction :left-to-right) - (setq overall-direction nil))) - (:right-to-left (unless (eq font-direction :right-to-left) - (setq overall-direction nil)))))) - - (values width - ascent - descent - left-bearing - right-bearing - overall-ascent - overall-descent - overall-direction - next-start))) - -(defun text-width (font sequence &key (start 0) end translate) - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font) - (type array-index start) - (type (or null array-index) end)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values integer (or null integer))) - (when (type? font 'gcontext) - (force-gcontext-changes font) - (setq font (gcontext-font font t))) - (check-type font font) - (let* ((width 0) - (next-start nil) - (display (font-display font))) - (declare (type int32 width) - (type (or null array-index) next-start) - (type display display)) - (with-display (display) - (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start +buffer-text16-size+)) - (index-min src-end (index+ src-start +buffer-text16-size+))) - (buf-end 0) - (new-font) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type generalized-boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (incf width - (if (or (font-char-infos-internal font) (font-local-only-p font)) - (text-extents-local font wbuf 0 buf-end :width-only) - (text-width-server font wbuf 0 buf-end))) - (when (type? new-font 'font) - (setq font new-font)))) - (values width next-start))) - -(defun text-extents-server (font sequence start end) - (declare (type font font) - (type sequence sequence) - (type array-index start end)) - (declare (clx-values width ascent descent left right font-ascent font-descent direction)) - (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) - (declare (type display display) - (type array-index length) - (type resource-id font-id)) - (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32)) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - sequence)) - (values - (integer-get 16) - (int16-get 12) - (int16-get 14) - (integer-get 20) - (integer-get 24) - (int16-get 8) - (int16-get 10) - (member8-get 1 :left-to-right :right-to-left))))) - -(defun text-width-server (font sequence start end) - (declare (type (or font gcontext) font) - (type sequence sequence) - (type array-index start end)) - (declare (clx-values integer)) - (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) - (declare (type display display) - (type array-index length) - (type resource-id font-id)) - (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - sequence)) - (values (integer-get 16))))) - -(defun text-extents-local (font sequence start end width-only-p) - (declare (type font font) - (type sequence sequence) - (type integer start end) - (type generalized-boolean width-only-p)) - (declare (clx-values width ascent descent overall-left overall-right)) - (let* ((char-infos (font-char-infos font)) - (font-info (font-font-info font))) - (declare (type font-info font-info)) - (declare (type (simple-array int16 (*)) char-infos)) - (if (zerop (length char-infos)) - ;; Fixed width font - (let* ((font-width (max-char-width font)) - (font-ascent (max-char-ascent font)) - (font-descent (max-char-descent font)) - (width (* (index- end start) font-width))) - (declare (type int16 font-width font-ascent font-descent) - (type int32 width)) - (if width-only-p - width - (values width - font-ascent - font-descent - (max-char-left-bearing font) - (+ width (- font-width) (max-char-right-bearing font))))) - - ;; Variable-width font - (let* ((first-col (font-info-min-byte2 font-info)) - (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) - (first-row (font-info-min-byte1 font-info)) - (last-row (font-info-max-byte1 font-info)) - (num-rows (1+ (- last-row first-row)))) - (declare (type card8 first-col first-row last-row) - (type card16 num-cols num-rows)) - (if (or (plusp first-row) (plusp last-row)) - - ;; Matrix (16 bit) font - (macrolet ((char-info-elt (sequence elt) - `(let* ((char (the card16 (elt ,sequence ,elt))) - (row (- (ash char -8) first-row)) - (col (- (logand char #xff) first-col))) - (declare (type card16 char) - (type int16 row col)) - (if (and (< -1 row num-rows) (< -1 col num-cols)) - (index* 6 (index+ (index* row num-cols) col)) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))))))) - - ;; Non-matrix (8 bit) font - ;; The code here is identical to the above, except for the following macro: - (macrolet ((char-info-elt (sequence elt) - `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) - (declare (type int16 col)) - (if (< -1 col num-cols) - (index* 6 col) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))) - )))) - ))))) - -;;----------------------------------------------------------------------------- - -;; This controls the element size of the dst buffer given to translate. If -;; :default is specified, the size will be based on the current font, if known, -;; and otherwise 16 will be used. [An alternative would be to pass the buffer -;; size to translate, and allow it to return the desired size if it doesn't -;; like the current size. The problem is that the protocol doesn't allow -;; switching within a single request, so to allow switching would require -;; knowing the width of text, which isn't necessarily known. We could call -;; text-width to compute it, but perhaps that is doing too many favors?] [An -;; additional possibility is to allow an index-size of :two-byte, in which case -;; translate would be given a double-length 8-bit array, and translate would be -;; expected to store first-byte/second-byte instead of 16-bit integers.] - -(deftype index-size () '(member :default 8 16)) - -;; In the functions below, if width is specified, it is assumed to be the total -;; pixel width of whatever string of glyphs is actually drawn. Specifying -;; width will allow for appending the output of subsequent calls to the same -;; protocol request, provided gcontext has not been modified in the interim. -;; If width is not specified, appending of subsequent output might not occur -;; (unless translate returns the width). Specifying width is simply a hint, -;; for performance. - -(defun draw-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values generalized-boolean (or null int32))) - (let* ((display (gcontext-display gcontext)) - (result t) - (opcode +x-polytext8+)) - (declare (type display display)) - (let ((vector (allocate-gcontext-state))) - (declare (type gcontext-state vector)) - (setf (aref vector 0) elt) - (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext nil) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) - (when result - (when (eql size 16) - (setq opcode +x-polytext16+) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) - (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card8 1 0) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) - (values t width)))) - -(defun draw-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values (or null array-index) (or null int32))) - (unless end (setq end (length sequence))) - (ecase size - ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end - (or translate #'translate-default) width)) - (16 (draw-glyphs16 drawable gcontext x y sequence start end - (or translate #'translate-default) width)))) - -(defun draw-glyphs8 (drawable gcontext x y sequence start end translate width) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (clx-values (or null array-index) (or null int32))) - (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 2)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - (font (gcontext-font gcontext nil))) - (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display)) - (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (the array-index (lround boffset)))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (index-zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) - - (declare (type array-index src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type generalized-boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer-bbuf (index+ boffset 2)) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (incf boffset (index+ dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the server - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) - (values next-start width))) - -;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer -;; on 16bit boundaries and this function garbles the bytes. -(defun draw-glyphs16 (drawable gcontext x y sequence start end translate width) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (clx-values (or null array-index) (or null int32))) - (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 3)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - (font (gcontext-font gcontext nil)) - (buffer (display-tbuf16 display))) - (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display) - (type buffer-text16 buffer)) - (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (lround boffset))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) - - (declare (type array-index boffset src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type generalized-boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer 0) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (index-incf boffset (index+ dst-chunk dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the SERVER - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) - (values next-start width))) - -(defun draw-image-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is overall width, if known. An initial font change is - ;; allowed from translate. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values generalized-boolean (or null int32))) - (let* ((display (gcontext-display gcontext)) - (result t) - (opcode +x-imagetext8+)) - (declare (type display display)) - (let ((vector (allocate-gcontext-state))) - (declare (type gcontext-state vector)) - (setf (aref vector 0) elt) - (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext nil) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) - (when result - (when (eql size 16) - (setq opcode +x-imagetext16+) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) - (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (data 1) ;; 1 character - (int16 x y) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) - (values t width)))) - -(defun draw-image-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type (or null array-index) end) - (type sequence sequence) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values (or null array-index) (or null int32))) - (setf end (index-min (index+ start 255) (or end (length sequence)))) - (ecase size - ((:default 8) - (draw-image-glyphs8 drawable gcontext x y sequence start end translate width)) - (16 - (draw-image-glyphs16 drawable gcontext x y sequence start end translate width)))) - -(defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (declare (clx-values (or null array-index) (or null int32))) - (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - (font (gcontext-font gcontext nil)) - (font-change nil) - (new-start) (translated-width) (chunk)) - (nil) ;; forever - (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk)) - - (when font-change - (setf (gcontext-font gcontext) font)) - (block change-font - (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer-bbuf (index+ buffer-boffset 16))) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs8 new-start)) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 chunk)))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) - ;; Normal exit - (return-from draw-image-glyphs8 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) - -(defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (declare (clx-values (or null array-index) (or null int32))) - (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - (font (gcontext-font gcontext nil)) - (font-change nil) - (new-start) (translated-width) (chunk) - (buffer (buffer-tbuf16 display))) - (nil) ;; forever - - (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk) - (type buffer-text16 buffer)) - (when font-change - (setf (gcontext-font gcontext) font)) - - (block change-font - (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer 0)) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs16 new-start)) - (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 (index-ash chunk 1))))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) - ;; Normal exit - (return-from draw-image-glyphs16 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) - - -;;----------------------------------------------------------------------------- - -(defun display-keycode-range (display) - (declare (type display display)) - (declare (clx-values min max)) - (values (display-min-keycode display) - (display-max-keycode display))) - -;; Should this signal device-busy like the pointer-mapping setf, and return a -;; generalized-boolean instead (true for success)? Alternatively, should the -;; pointer-mapping setf be changed to set-pointer-mapping with a (member -;; :success :busy) result? - -(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) - ;; Setf ought to allow multiple values. - (declare (type display display) - (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) - (declare (clx-values (member :success :busy :failed))) - (let* ((keycodes-per-modifier (index-max (length shift) - (length lock) - (length control) - (length mod1) - (length mod2) - (length mod3) - (length mod4) - (length mod5))) - (data (make-array (index* 8 keycodes-per-modifier) - :element-type 'card8 - :initial-element 0))) - (replace data shift) - (replace data lock :start1 keycodes-per-modifier) - (replace data control :start1 (index* 2 keycodes-per-modifier)) - (replace data mod1 :start1 (index* 3 keycodes-per-modifier)) - (replace data mod2 :start1 (index* 4 keycodes-per-modifier)) - (replace data mod3 :start1 (index* 5 keycodes-per-modifier)) - (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) - (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) - (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8) - ((data keycodes-per-modifier) - ((sequence :format card8) data)) - (values (member8-get 1 :success :busy :failed))))) - -(defun modifier-mapping (display) - ;; each value is a list of integers - (declare (type display display)) - (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)) - (let ((lists nil)) - (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8) - () - (do* ((keycodes-per-modifier (card8-get 1)) - (advance-by +replysize+ keycodes-per-modifier) - (keys nil nil) - (i 0 (index+ i 1))) - ((index= i 8)) - (advance-buffer-offset advance-by) - (dotimes (j keycodes-per-modifier) - (let ((key (read-card8 j))) - (unless (zerop key) - (push key keys)))) - (push (nreverse keys) lists))) - (values-list (nreverse lists)))) - -;; Either we will want lots of defconstants for well-known values, or perhaps -;; an integer-to-keyword translation function for well-known values. - -(defun change-keyboard-mapping - (display keysyms &key (start 0) end (first-keycode start)) - ;; start/end give subrange of keysyms - ;; first-keycode is the first-keycode to store at - (declare (type display display) - (type array-index start) - (type card8 first-keycode) - (type (or null array-index) end) - (type (array * (* *)) keysyms)) - (let* ((keycode-end (or end (array-dimension keysyms 0))) - (keysyms-per-keycode (array-dimension keysyms 1)) - (length (index- keycode-end start)) - (size (index* length keysyms-per-keycode)) - (request-length (index+ size 2))) - (declare (type array-index keycode-end keysyms-per-keycode length request-length)) - (with-buffer-request (display +x-setkeyboardmapping+ - :length (index-ash request-length 2) - :sizes (32)) - (data length) - (length request-length) - (card8 first-keycode keysyms-per-keycode) - (progn - (do ((limit (index-ash (buffer-size display) -2)) - (w (index+ 2 (index-ash buffer-boffset -2))) - (i start (index+ i 1))) - ((index>= i keycode-end) - (setf (buffer-boffset display) (index-ash w 2))) - (declare (type array-index limit w i)) - (when (index> w limit) - (buffer-flush display) - (setq w (index-ash (buffer-boffset display) -2))) - (do ((j 0 (index+ j 1))) - ((index>= j keysyms-per-keycode)) - (declare (type array-index j)) - (card29-put (index* w 4) (aref keysyms i j)) - (index-incf w))))))) - -(defun keyboard-mapping (display &key first-keycode start end data) - ;; First-keycode specifies which keycode to start at (defaults to min-keycode). - ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode) - ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)). - ;; If DATA is specified, the results are put there. - (declare (type display display) - (type (or null card8) first-keycode) - (type (or null array-index) start end) - (type (or null (array * (* *))) data)) - (declare (clx-values (array * (* *)))) - (unless first-keycode (setq first-keycode (display-min-keycode display))) - (unless start (setq start first-keycode)) - (unless end (setq end (1+ (display-max-keycode display)))) - (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32)) - ((card8 first-keycode (index- end start))) - (do* ((keysyms-per-keycode (card8-get 1)) - (bytes-per-keycode (* keysyms-per-keycode 4)) - (advance-by +replysize+ bytes-per-keycode) - (keycode-count (floor (card32-get 4) keysyms-per-keycode) - (index- keycode-count 1)) - (result (if (and (arrayp data) - (= (array-rank data) 2) - (>= (array-dimension data 0) (index+ start keycode-count)) - (>= (array-dimension data 1) keysyms-per-keycode)) - data - (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) - :element-type 'keysym :initial-element 0))) - (i start (1+ i))) - ((zerop keycode-count) (setq data result)) - (advance-buffer-offset advance-by) - (dotimes (j keysyms-per-keycode) - (setf (aref result i j) (card29-get (* j 4)))))) - data) diff --git a/src/clx/translate.lisp b/src/clx/translate.lisp deleted file mode 100644 index aca0c3a20..000000000 --- a/src/clx/translate.lisp +++ /dev/null @@ -1,562 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; 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) - -(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym) - -(defun define-keysym-set (set first-keysym last-keysym) - ;; Define all keysyms from first-keysym up to and including - ;; last-keysym to be in SET (returned from the keysym-set function). - ;; Signals an error if the keysym range overlaps an existing set. - (declare (type keyword set) - (type keysym first-keysym last-keysym)) - (when (> first-keysym last-keysym) - (rotatef first-keysym last-keysym)) - (setq *keysym-sets* (delete set *keysym-sets* :key #'car)) - (dolist (set *keysym-sets*) - (let ((first (second set)) - (last (third set))) - (when (or (<= first first-keysym last) - (<= first last-keysym last)) - (error "Keysym range overlaps existing set ~s" set)))) - (push (list set first-keysym last-keysym) *keysym-sets*) - set) - -(defun keysym-set (keysym) - ;; Return the character code set name of keysym - (declare (type keysym keysym) - (clx-values keyword)) - (dolist (set *keysym-sets*) - (let ((first (second set)) - (last (third set))) - (when (<= first keysym last) - (return (first set)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro keysym (keysym &rest bytes) - ;; Build a keysym. - ;; - ;; If KEYSYM is an integer, it is used as the most significant - ;; bits of the keysym, and BYTES are used to specify low order - ;; bytes. The last parameter is always byte4 of the keysym. If - ;; KEYSYM is not an integer, the keysym associated with KEYSYM is - ;; returned. - ;; - ;; This is a macro and not a function macro to promote - ;; compile-time lookup. All arguments are evaluated. - ;; - ;; FIXME: The above means that this shouldn't really be a macro at - ;; all, but a compiler macro. Probably, anyway. - (declare (type t keysym) - (type list bytes) - (clx-values keysym)) - (typecase keysym - ((integer 0 *) - (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) - (otherwise - (or (car (character->keysyms keysym)) - (error "~s Isn't the name of a keysym" keysym)))))) - -(defvar *keysym->character-map* - (make-hash-table :test (keysym->character-map-test) :size 400)) - -;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask) -;; With the following accessor macros. Everything after OBJECT is optional. - -(defmacro keysym-mapping-object (keysym-mapping) - ;; Parameter to translate - `(first ,keysym-mapping)) - -(defmacro keysym-mapping-translate (keysym-mapping) - ;; Function to be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - `(second ,keysym-mapping)) - -(defmacro keysym-mapping-lowercase (keysym-mapping) - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. - `(third ,keysym-mapping)) - -(defmacro keysym-mapping-modifiers (keysym-mapping) - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. - `(fourth ,keysym-mapping)) - -(defmacro keysym-mapping-mask (keysym-mapping) - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares) - `(fifth ,keysym-mapping)) - -(defvar *default-keysym-translate-mask* - (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - (logand #xff (lognot (make-state-mask :lock)))) - "Default keysym state mask to use during keysym-translation.") - -(defun define-keysym (object keysym &key lowercase translate modifiers mask display) - ;; Define the translation from keysym/modifiers to a (usually - ;; character) object. ANy previous keysym definition with - ;; KEYSYM and MODIFIERS is deleted before adding the new definition. - ;; - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. The default is NIL. - ;; - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares). - ;; If mask is :MODIFIERS then the mask is the same as the modifiers - ;; (i.e. modifiers not specified by modifiers are don't cares) - ;; The default mask is *default-keysym-translate-mask* - ;; - ;; If DISPLAY is specified, the translation will be local to DISPLAY, - ;; otherwise it will be the default translation for all displays. - ;; - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. This information is used - ;; by the keysym-both-case-p predicate (for caps-lock computations) - ;; and by the keysym-downcase function. - ;; - ;; TRANSLATE will be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) - ;; (or modifiers 0))) - ;; when mask and modifiers aren't lists of keysyms] - ;; The default is #'default-keysym-translate - ;; - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - mask) - (type (or null display) display) - (type (or null keysym) lowercase) - (type (or null (function (display card16 t) t)) translate)) - (flet ((merge-keysym-mappings (new old) - ;; Merge new keysym-mapping with list of old mappings. - ;; Ensure that the mapping with no modifiers or mask comes first. - (let* ((key (keysym-mapping-modifiers new)) - (merge (delete key old :key #'cadddr :test #'equal))) - (if key - (nconc merge (list new)) - (cons new merge)))) - (mask-check (mask) - (unless (or (numberp mask) - (dolist (element mask t) - (unless (or (find element +state-mask-vector+) - (gethash element *keysym->character-map*)) - (return nil)))) - (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym))))))) - (let ((entry - ;; Create with a single LIST call, to ensure cdr-coding - (cond - (mask - (unless (eq mask :modifiers) - (mask-check mask)) - (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers))) - (error "Mask with no modifiers")) - (list object translate lowercase modifiers mask)) - (modifiers (mask-check modifiers) - (list object translate lowercase modifiers)) - (lowercase (list object translate lowercase)) - (translate (list object translate)) - (t (list object))))) - (if display - (let ((previous (assoc keysym (display-keysym-translation display)))) - (if previous - (setf (cdr previous) (merge-keysym-mappings entry (cdr previous))) - (push (list keysym entry) (display-keysym-translation display)))) - (setf (gethash keysym *keysym->character-map*) - (merge-keysym-mappings entry (gethash keysym *keysym->character-map*))))) - object)) - -(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) - ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. - ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null display) display)) - (flet ((match (key entry) - (let ((object (car key)) - (modifiers (cdr key))) - (or (eql object (keysym-mapping-object entry)) - (equal modifiers (keysym-mapping-modifiers entry)))))) - (let* (entry - (previous (if display - (cdr (setq entry (assoc keysym (display-keysym-translation display)))) - (gethash keysym *keysym->character-map*))) - (key (cons object modifiers))) - (when (and previous (find key previous :test #'match)) - (setq previous (delete key previous :test #'match)) - (if display - (setf (cdr entry) previous) - (setf (gethash keysym *keysym->character-map*) previous)))))) - -(defun keysym-downcase (keysym) - ;; If keysym has a lower-case equivalent, return it, otherwise return keysym. - (declare (type keysym keysym)) - (declare (clx-values keysym)) - (let ((translations (gethash keysym *keysym->character-map*))) - (or (and translations (keysym-mapping-lowercase (first translations))) keysym))) - -(defun keysym-uppercase-alphabetic-p (keysym) - ;; Returns T if keysym is uppercase-alphabetic. - ;; I.E. If it has a lowercase equivalent. - (declare (type keysym keysym)) - (declare (clx-values (or null keysym))) - (let ((translations (gethash keysym *keysym->character-map*))) - (and translations - (keysym-mapping-lowercase (first translations))))) - -(defun character->keysyms (character &optional display) - ;; Given a character, return a list of all matching keysyms. - ;; If DISPLAY is given, translations specific to DISPLAY are used, - ;; otherwise only global translations are used. - ;; Implementation dependent function. - ;; May be slow [i.e. do a linear search over all known keysyms] - (declare (type t character) - (type (or null display) display) - (clx-values (clx-list keysym))) - (let ((result nil)) - (when display - (dolist (mapping (display-keysym-translation display)) - (when (eql character (second mapping)) - (push (first mapping) result)))) - (maphash #'(lambda (keysym mappings) - (dolist (mapping mappings) - (when (eql (keysym-mapping-object mapping) character) - (pushnew keysym result)))) - *keysym->character-map*) - result)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant character-set-switch-keysym (keysym 255 126)) - (defconstant left-shift-keysym (keysym 255 225)) - (defconstant right-shift-keysym (keysym 255 226)) - (defconstant left-control-keysym (keysym 255 227)) - (defconstant right-control-keysym (keysym 255 228)) - (defconstant caps-lock-keysym (keysym 255 229)) - (defconstant shift-lock-keysym (keysym 255 230)) - (defconstant left-meta-keysym (keysym 255 231)) - (defconstant right-meta-keysym (keysym 255 232)) - (defconstant left-alt-keysym (keysym 255 233)) - (defconstant right-alt-keysym (keysym 255 234)) - (defconstant left-super-keysym (keysym 255 235)) - (defconstant right-super-keysym (keysym 255 236)) - (defconstant left-hyper-keysym (keysym 255 237)) - (defconstant right-hyper-keysym (keysym 255 238))) - - -;;----------------------------------------------------------------------------- -;; Keysym mapping functions - -(defun display-keyboard-mapping (display) - (declare (type display display)) - (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode)))) - (or (display-keysym-mapping display) - (setf (display-keysym-mapping display) (keyboard-mapping display)))) - -(defun keycode->keysym (display keycode keysym-index) - (declare (type display display) - (type card8 keycode) - (type card8 keysym-index) - (clx-values keysym)) - (let* ((mapping (display-keyboard-mapping display)) - (keysym (aref mapping keycode keysym-index))) - (declare (type (simple-array keysym (* *)) mapping) - (type keysym keysym)) - ;; The keysym-mapping is brain dammaged. - ;; Mappings for both-case alphabetic characters have the - ;; entry for keysym-index zero set to the uppercase keysym - ;; (this is normally where the lowercase keysym goes), and the - ;; entry for keysym-index one is zero. - (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms - (keysym-downcase keysym)) - ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym - (aref mapping keycode 0)) - (t keysym)))) - -(defun keysym->character (display keysym &optional (state 0)) - ;; Find the character associated with a keysym. - ;; STATE can be used to set character attributes. - ;; Implementation dependent function. - (declare (type display display) - (type keysym keysym) - (type card16 state)) - (declare (clx-values (or null character))) - (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display)))) - (mapping (or ;; Find the matching display mapping - (dolist (mapping display-mappings) - (when (mapping-matches-p display state mapping) - (return mapping))) - ;; Find the matching static mapping - (dolist (mapping (gethash keysym *keysym->character-map*)) - (when (mapping-matches-p display state mapping) - (return mapping)))))) - (when mapping - (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate) - display state (keysym-mapping-object mapping))))) - -(defun mapping-matches-p (display state mapping) - ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY - (declare (type display display) - (type mask16 state) - (type list mapping)) - (declare (clx-values generalized-boolean)) - (flet - ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0)) - ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask. - ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified, - ;; otherwise ignore unknown modifiers. - (declare (type list display-mapping) ; Alist of (keysym . mask) - (type (or mask16 list) modifiers) - (type mask16 mask)) - (declare (clx-values (or null mask16))) - (if (numberp modifiers) - modifiers - (dolist (modifier modifiers mask) - (declare (type symbol modifier)) - (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq))) - (setq mask - (logior mask - (if bit - (ash 1 bit) - (or (cdr (assoc modifier display-mapping)) - ;; bad modifier - (if errorp - (return-from modifiers->mask nil) - 0)))))))))) - - (let* ((display-mapping (get-display-modifier-mapping display)) - (mapping-modifiers (keysym-mapping-modifiers mapping)) - (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t) - (return-from mapping-matches-p nil))) - (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default. - (if mapping-modifiers ; If no modifiers, match anything. - *default-keysym-translate-mask* - 0))) - (mask (if (eq mapping-mask :modifiers) - modifiers - (modifiers->mask display-mapping mapping-mask nil)))) - (declare (type mask16 modifiers mask)) - (= (logand state mask) modifiers)))) - -(defun default-keysym-index (display keycode state) - ;; Returns a keysym-index for use with keycode->character - (declare (clx-values card8)) - (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword +state-mask-vector+) ,state))) - (let* ((mapping (display-keyboard-mapping display)) - (keysyms-per-keycode (array-dimension mapping 1)) - (symbolp (and (> keysyms-per-keycode 2) - (state-keysymp display state character-set-switch-keysym))) - (result (if symbolp 2 0))) - (declare (type (simple-array keysym (* *)) mapping) - (type generalized-boolean symbolp) - (type card8 keysyms-per-keycode result)) - (when (and (< result keysyms-per-keycode) - (keysym-shift-p display state (keysym-uppercase-alphabetic-p - (aref mapping keycode 0)))) - (incf result)) - result))) - -(defun keysym-shift-p (display state uppercase-alphabetic-p &key - shift-lock-xors - (control-modifiers - '#.(list left-meta-keysym left-super-keysym left-hyper-keysym))) - (declare (type display display) - (type card16 state) - (type generalized-boolean uppercase-alphabetic-p) - (type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same - ;;; as neither if the character is alphabetic. - (declare (clx-values generalized-boolean)) - (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword +state-mask-vector+) ,state))) - (let* ((controlp (or (keystate-p state :control) - (dolist (modifier control-modifiers) - (when (state-keysymp display state modifier) - (return t))))) - (shiftp (keystate-p state :shift)) - (lockp (keystate-p state :lock)) - (alphap (or uppercase-alphabetic-p - (not (state-keysymp display #.(make-state-mask :lock) - caps-lock-keysym))))) - (declare (type generalized-boolean controlp shiftp lockp alphap)) - ;; Control keys aren't affected by lock - (unless controlp - ;; Not a control character - check state of lock modifier - (when (and lockp - alphap - (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors - (setq shiftp (not shiftp)))) - shiftp))) - -;;; default-keysym-index implements the following tables: -;;; -;;; control shift caps-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\8 -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\* -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-8 -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-* -;;; -;;; control shift shift-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\* -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\8 -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-* -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-8 - -(defun keycode->character (display keycode state &key keysym-index - (keysym-index-function #'default-keysym-index)) - ;; keysym-index defaults to the result of keysym-index-function which - ;; is called with the following parameters: - ;; (char0 state caps-lock-p keysyms-per-keycode) - ;; where char0 is the "character" object associated with keysym-index 0 and - ;; caps-lock-p is non-nil when the keysym associated with the lock - ;; modifier is for caps-lock. - ;; STATE can also used for setting character attributes. - ;; Implementation dependent function. - (declare (type display display) - (type card8 keycode) - (type card16 state) - (type (or null card8) keysym-index) - (type (or null (function (base-char card16 generalized-boolean card8) card8)) - keysym-index-function)) - (declare (clx-values (or null character))) - (let* ((index (or keysym-index - (funcall keysym-index-function display keycode state))) - (keysym (if index (keycode->keysym display keycode index) 0))) - (declare (type (or null card8) index) - (type keysym keysym)) - (when (plusp keysym) - (keysym->character display keysym state)))) - -(defun get-display-modifier-mapping (display) - (labels ((keysym-replace (display modifiers mask &aux result) - (dolist (modifier modifiers result) - (push (cons (keycode->keysym display modifier 0) mask) result)))) - (or (display-modifier-mapping display) - (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) - (modifier-mapping display) - (setf (display-modifier-mapping display) - (nconc (keysym-replace display shift #.(make-state-mask :shift)) - (keysym-replace display lock #.(make-state-mask :lock)) - (keysym-replace display control #.(make-state-mask :control)) - (keysym-replace display mod1 #.(make-state-mask :mod-1)) - (keysym-replace display mod2 #.(make-state-mask :mod-2)) - (keysym-replace display mod3 #.(make-state-mask :mod-3)) - (keysym-replace display mod4 #.(make-state-mask :mod-4)) - (keysym-replace display mod5 #.(make-state-mask :mod-5)))))))) - -(defun state-keysymp (display state keysym) - ;; Returns T when a modifier key associated with KEYSYM is on in STATE - (declare (type display display) - (type card16 state) - (type keysym keysym)) - (declare (clx-values generalized-boolean)) - (let* ((mapping (get-display-modifier-mapping display)) - (mask (assoc keysym mapping))) - (and mask (plusp (logand state (cdr mask)))))) - -(defun mapping-notify (display request start count) - ;; Called on a mapping-notify event to update - ;; the keyboard-mapping cache in DISPLAY - (declare (type display display) - (type (member :modifier :keyboard :pointer) request) - (type card8 start count) - (ignore count start)) - ;; Invalidate the keyboard mapping to force the next key translation to get it - (case request - (:modifier - (setf (display-modifier-mapping display) nil)) - (:keyboard - (setf (display-keysym-mapping display) nil)))) - -(defun keysym-in-map-p (display keysym keymap) - ;; Returns T if keysym is found in keymap - (declare (type display display) - (type keysym keysym) - (type (bit-vector 256) keymap)) - (declare (clx-values generalized-boolean)) - ;; The keysym may appear in the keymap more than once, - ;; So we have to search the entire keysym map. - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i))) - ((> i max)) - (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) - (when (and (plusp (aref keymap i)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) (return t)))) - (return t)))) - -(defun character-in-map-p (display character keymap) - ;; Implementation dependent function. - ;; Returns T if character is found in keymap - (declare (type display display) - (type character character) - (type (bit-vector 256) keymap)) - (declare (clx-values generalized-boolean)) - ;; Check all one bits in keymap - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (jmax (array-dimension (display-keyboard-mapping display) 1)) - (i min (1+ i))) - ((> i max)) - (declare (type card8 min max jmax)) - (when (and (plusp (aref keymap i)) - ;; Match when character is in mapping for this keycode - (dotimes (j jmax) - (when (eql character (keycode->character display i 0 :keysym-index j)) - (return t)))) - (return t)))) - -(defun keysym->keycodes (display keysym) - ;; Return keycodes for keysym, as multiple values - (declare (type display display) - (type keysym keysym)) - (declare (clx-values (or null keycode) (or null keycode) (or null keycode))) - ;; The keysym may appear in the keymap more than once, - ;; So we have to search the entire keysym map. - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i)) - (result nil)) - ((> i max) (values-list result)) - (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) - (push i result))))) diff --git a/src/clx/xinerama.lisp b/src/clx/xinerama.lisp deleted file mode 100644 index 8aeca38e0..000000000 --- a/src/clx/xinerama.lisp +++ /dev/null @@ -1,93 +0,0 @@ -;;; -*- Mode: Lisp -*- -;;; -;;; Copyright (C) 2008, Julian Stecklina -;;; -;;; (( -;;; )) This file is COFFEEWARE. As long as you retain this notice -;;; | |o) you can do whatever you want with this code. If you think, -;;; |___|jgs it's worth it, you may buy the author a coffee in return. -;;; -;;; Description: -;;; -;;; This is an implementation of the XINERAMA extension. It does not -;;; include the obsolete PanoramiX calls. - -(defpackage "XLIB.XINERAMA" - (:use "COMMON-LISP" "XLIB") - (:nicknames "XINERAMA") - (:import-from "XLIB" - "WITH-BUFFER-REQUEST" - "WITH-BUFFER-REQUEST-AND-REPLY" - "DATA" - "BOOLEAN" "BOOLEAN-GET" - "CARD8" "CARD8-GET" - "CARD16" "CARD16-GET" - "CARD32" "CARD32-GET" - "INT16" "INT16-GET") - (:export "SCREEN-INFO" - "SCREEN-INFO-NUMBER" - "SCREEN-INFO-X" - "SCREEN-INFO-Y" - "SCREEN-INFO-WIDTH" - "SCREEN-INFO-HEIGHT" - "XINERAMA-QUERY-VERSION" - "XINERAMA-IS-ACTIVE" - "XINERAMA-QUERY-SCREENS")) -(in-package "XINERAMA") - -(define-extension "XINERAMA") - -(defun xinerama-opcode (display) - (extension-opcode display "XINERAMA")) - -(defconstant +major-version+ 1) -(defconstant +minor-version+ 1) - -(defconstant +get-version+ 0) -(defconstant +get-state+ 1) -(defconstant +get-screen-count+ 2) -(defconstant +get-screen-size+ 3) -(defconstant +is-active+ 4) -(defconstant +query-screens+ 5) - -(defstruct screen-info - (number 0 :type (unsigned-byte 32)) - (x 0 :type (signed-byte 16)) - (y 0 :type (signed-byte 16)) - (width 0 :type (unsigned-byte 16)) - (height 0 :type (unsigned-byte 16))) - -(defun xinerama-query-version (display) - (with-buffer-request-and-reply (display (xinerama-opcode display) nil) - ((data +get-version+) - (card8 +major-version+) - (card8 +minor-version+)) - (values - (card16-get 8) ; server major version - (card16-get 10)))) ; server minor version - -(defun xinerama-is-active (display) - "Returns T, iff Xinerama is supported and active." - (with-buffer-request-and-reply (display (xinerama-opcode display) nil) - ((data +is-active+)) - (values - ;; XCB says this is actually a CARD32, but why?! - (boolean-get 8)))) - -(defun xinerama-query-screens (display) - "Returns a list of screen-info structures." - (with-buffer-request-and-reply (display (xinerama-opcode display) nil) - ((data +query-screens+)) - (values - (loop - with index = 32 - for number from 0 below (card32-get 8) - collect (prog1 - (make-screen-info :number number - :x (int16-get index) - :y (int16-get (+ index 2)) - :width (card16-get (+ index 4)) - :height (card16-get (+ index 6))) - (incf index 8)))))) - -;;; EOF diff --git a/src/clx/xrender.lisp b/src/clx/xrender.lisp deleted file mode 100644 index 56f412533..000000000 --- a/src/clx/xrender.lisp +++ /dev/null @@ -1,1154 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: The X Render Extension -;;; Created: 2002-08-03 -;;; Author: Gilbert Baumann -;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $ -;;; --------------------------------------------------------------------------- -;;; -;;; (c) copyright 2002, 2003 by Gilbert Baumann -;;; (c) copyright 2002 by Christian Sunesson -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -;;; - -;;; NOTE: we need to watch maximum request sizes and somehow work -;;; around them. Sometimes e.g. in AddGlyphs this is not possible, -;;; which is a design failure. - -;;; TODO - -;; - some request are still to be implemented at all. -;; + Can they not wait? Xrender seems to be in flux as the specification -;; isn't even conforming to the acctual protocol. However backwards -;; wierd that sound. --noss - -;; - we need to invent something for the color values of e.g. -;; fill-rectangles; I would prefer some generic functions, so that -;; we later can map CLIM design directly to colors. - -;; - we want some conviencene function to turn graphics contexts into -;; render pictures. --GB 2002-08-21 - -;; - also: uniform-alpha-picture display alpha-value -;; uniform-color-picture display red green blue -;; --GB 2002-08-21 - -;; - maybe we should aim for a higher level interface to -;; color-trapzoids and color-triangles and offer a low level [raw] -;; interface also for high performance apps? - -;; - Write tests. - -;;;; API issues - -;; - On one hand we want convenience functions like RENDER-TRIANGLE or -;; WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to -;; write a full rasterization library you obviously want high -;; performance entry points as RENDER-TRIANGLES-1. - -;; - We want to extend XLIB:COLOR into something with alpha channel. -;; How to name it? - -;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body -;; -;; Example: -;; (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0) -;; (RENDER-TRIANGLE dest color ...)) - -;; - Pose the filter and the transform slots of a picture. - -;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT? - -;; - COPY-PICTURE? - -;; - WITH-PICTURE-OPTIONS ? -;; -;; (WITH-PICTURE-OPTIONS (pic :repeat :on) ...) - -;; - WITH-PICTURE ? -;; -;; (WITH-PICTURE (picture drawable ...) ...) - -;; - -(in-package :xlib) - -;; Beginning to collect the external interface for documentation. -(export '(render-create-picture - render-free-picture - - render-create-glyph-set - render-reference-glyph-set - render-free-glyph-set - - render-add-glyph - render-add-glyph-from-picture - render-free-glyph - render-fill-rectangle - - picture-format-display - picture-format-id - picture-format-type - picture-format-depth - picture-format-red-byte - picture-format-green-byte - picture-format-blue-byte - picture-format-alpha-byte - picture-format-colormap - - ;; picture object - picture-repeat - picture-alpha-map - picture-alpha-x-origin - picture-alpha-y-origin - picture-clip-x-origin - picture-clip-y-origin - picture-clip-mask - picture-graphics-exposures - picture-subwindow-mode - picture-poly-edge - picture-poly-mode - picture-dither - picture-component-alpha - picture-drawable - - find-matching-picture-formats - find-window-picture-format - render-free-picture - render-free-glyph-set - render-query-version - ;; render-query-picture-formats - render-fill-rectangle - render-composite - render-create-glyph-set - render-reference-glyph-set - render-composite-glyphs - render-add-glyph - render-add-glyph-from-picture - render-free-glyphs)) - -(pushnew :clx-ext-render *features*) - -(define-extension "RENDER") - -;;;; Request constants - -;; Note: Although version numbers are given render.h where the request -;; numbers are defined, render-query-version returns 0.0 all displays -;; i tested. --GB 2004-07-21 - -(defconstant +X-RenderQueryVersion+ 0) ;done -(defconstant +X-RenderQueryPictFormats+ 1) -(defconstant +X-RenderQueryPictIndexValues+ 2) ;0.7 -(defconstant +X-RenderQueryDithers+ 3) -(defconstant +X-RenderCreatePicture+ 4) ;done -(defconstant +X-RenderChangePicture+ 5) ;done -(defconstant +X-RenderSetPictureClipRectangles+ 6) ;done -(defconstant +X-RenderFreePicture+ 7) ;done -(defconstant +X-RenderComposite+ 8) ;we need better arglist -(defconstant +X-RenderScale+ 9) -(defconstant +X-RenderTrapezoids+ 10) ;low-level done -(defconstant +X-RenderTriangles+ 11) ;low-level done -(defconstant +X-RenderTriStrip+ 12) -(defconstant +X-RenderTriFan+ 13) -(defconstant +X-RenderColorTrapezoids+ 14) ;nyi in X server, not mentioned in renderproto.h -(defconstant +X-RenderColorTriangles+ 15) ;nyi in X server, not mentioned in renderproto.h -(defconstant +X-RenderTransform+ 16) ;commented out in render.h -(defconstant +X-RenderCreateGlyphSet+ 17) ;done -(defconstant +X-RenderReferenceGlyphSet+ 18) ;done -(defconstant +X-RenderFreeGlyphSet+ 19) ;done -(defconstant +X-RenderAddGlyphs+ 20) ;done, untested -(defconstant +X-RenderAddGlyphsFromPicture+ 21) ;done, untested -(defconstant +X-RenderFreeGlyphs+ 22) ;done, untested -(defconstant +X-RenderCompositeGlyphs8+ 23) ;done -(defconstant +X-RenderCompositeGlyphs16+ 24) ;done -(defconstant +X-RenderCompositeGlyphs32+ 25) ;done - -;; >= 0.1 - -(defconstant +X-RenderFillRectangles+ 26) ;single rectangle version done - -;; >= 0.5 - -(defconstant +X-RenderCreateCursor+ 27) - -;; >= 0.6 - -(defconstant +X-RenderSetPictureTransform+ 28) ;I don't understand what this one should do. -(defconstant +X-RenderQueryFilters+ 29) ;seems to be there on server side - ; some guts of its implementation there. -(defconstant +X-RenderSetPictureFilter+ 30) -(defconstant +X-RenderCreateAnimCursor+ 31) ;What has render to do with cursors? - -;;;; - -;; Sanity measures: - -;; We do away with the distinction between pict-format and -;; picture-format-info. That is we cache picture-format-infos. - -(defstruct render-info - major-version - minor-version - picture-formats) - -(defun display-render-info (display) - (getf (xlib:display-plist display) 'render-info)) - -(defun (setf display-render-info) (new-value display) - (setf (getf (xlib:display-plist display) 'render-info) - new-value)) - -(defun ensure-render-initialized (display) - "Ensures that the RENDER extension is initialized. Should be called -by every function, which attempts to generate RENDER requests." - ;; xxx locking? - (unless (display-render-info display) - (let ((q (make-render-info))) - (multiple-value-bind (maj min) (render-query-version display) - (setf (render-info-major-version q) maj - (render-info-minor-version q) min) - (setf (render-info-picture-formats q) - (make-hash-table :test #'eql)) - (dolist (pf (render-query-picture-formats display)) - (setf (gethash (picture-format-id pf) (render-info-picture-formats q)) - pf)) - (setf (display-render-info display) q))))) - -(defun find-matching-picture-formats - (display - &key depth-min depth-max depth - red-min red-max red - green-min green-max green - blue-min blue-max blue - alpha-min alpha-max alpha - type - colormap) - ;; - (ensure-render-initialized display) - (let ((res nil)) - (maphash (lambda (k f) - (declare (ignore k)) - (when (and - (or (null type) (eql (picture-format-type f) type)) - (or (null colormap) (eql (picture-format-colormap f) colormap)) - ;; min - (or (null depth-min) (>= (picture-format-depth f) depth-min)) - (or (null red-min) (>= (byte-size (picture-format-red-byte f)) red-min)) - (or (null green-min) (>= (byte-size (picture-format-green-byte f)) green-min)) - (or (null blue-min) (>= (byte-size (picture-format-blue-byte f)) blue-min)) - (or (null alpha-min) (>= (byte-size (picture-format-alpha-byte f)) alpha-min)) - ;; max - (or (null depth-max) (<= (picture-format-depth f) depth-max)) - (or (null red-max) (<= (byte-size (picture-format-red-byte f)) red-max)) - (or (null green-max) (<= (byte-size (picture-format-green-byte f)) green-max)) - (or (null blue-max) (<= (byte-size (picture-format-blue-byte f)) blue-max)) - (or (null alpha-max) (<= (byte-size (picture-format-alpha-byte f)) alpha-max)) - ;; match - (or (null depth) (= (picture-format-depth f) depth)) - (or (null red) (= (byte-size (picture-format-red-byte f)) red)) - (or (null green) (= (byte-size (picture-format-green-byte f)) green)) - (or (null blue) (= (byte-size (picture-format-blue-byte f)) blue)) - (or (null alpha) (= (byte-size (picture-format-alpha-byte f)) alpha))) - (pushnew f res))) - (render-info-picture-formats - (display-render-info display))) - res)) - -(defun find-window-picture-format (window) - "Find the picture format which matches the given window." - (let* ((vi (window-visual-info window)) - (display (window-display window))) - (ensure-render-initialized display) - (case (visual-info-class vi) - ((:true-color) - (maphash (lambda (k f) - (declare (ignore k)) - (when (and (eql (picture-format-type f) :direct) - (eql (picture-format-depth f) (drawable-depth window)) - (eql (dpb -1 (picture-format-red-byte f) 0) - (visual-info-red-mask vi)) - (eql (dpb -1 (picture-format-green-byte f) 0) - (visual-info-green-mask vi)) - (eql (dpb -1 (picture-format-blue-byte f) 0) - (visual-info-blue-mask vi)) - (eql (byte-size (picture-format-alpha-byte f)) 0)) - (return-from find-window-picture-format f))) - (render-info-picture-formats - (display-render-info display)))) - (t - )))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (define-accessor picture (32) - ((index) index :blip) - ((index thing) `(resource-id-put ,index (picture-id ,thing)))) - (define-accessor glyph-set (32) - ((index) index :blip) - ((index thing) `(resource-id-put ,index (glyph-set-id ,thing))))) - -;;; picture format - -(defstruct picture-format - display - (id 0 :type (unsigned-byte 29)) - type - depth - red-byte - green-byte - blue-byte - alpha-byte - colormap) - -(defmethod print-object ((object picture-format) stream) - (let ((abbrev - (with-output-to-string (bag) - ;; build an abbreviated representation of the format - (let ((bytes (sort (list (cons "r" (picture-format-red-byte object)) - (cons "g" (picture-format-green-byte object)) - (cons "b" (picture-format-blue-byte object)) - (cons "a" (picture-format-alpha-byte object))) - #'> - :key #'(lambda (x) (byte-position (cdr x)))))) - (dolist (k bytes) - (unless (zerop (byte-size (cdr k))) - (format bag " ~A~D" (car k) (byte-size (cdr k))))))))) - (print-unreadable-object (object stream :type t :identity nil) - (format stream "~D ~S ~S ~S~A" - (picture-format-id object) - (picture-format-colormap object) - (picture-format-depth object) - (picture-format-type object) abbrev)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (define-accessor picture-format (32) - ((index) `(gethash (read-card32 ,index) - (render-info-picture-formats (display-render-info .display.)))) - ((index thing) `(write-card32 ,index (picture-format-id ,thing)))) - (define-accessor render-op (8) - ((index) `(member8-get ,index - :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate - '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh - :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over - :disjoint-over-reverse :disjoint-in :disjoint-in-reverse - :disjoint-out :disjoint-out-reverse :disjoint-atop - :disjoint-atop-reverse :disjoint-xor - '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh - '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh - :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over - :conjoint-over-reverse :conjoint-in :conjoint-in-reverse - :conjoint-out :conjoint-out-reverse :conjoint-atop - :conjoint-atop-reverse :conjoint-xor)) - ((index thing) `(member8-put ,index ,thing - :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate - '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh - :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over - :disjoint-over-reverse :disjoint-in :disjoint-in-reverse - :disjoint-out :disjoint-out-reverse :disjoint-atop - :disjoint-atop-reverse :disjoint-xor - '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh - '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh - :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over - :conjoint-over-reverse :conjoint-in :conjoint-in-reverse - :conjoint-out :conjoint-out-reverse :conjoint-atop - :conjoint-atop-reverse :conjoint-xor))) - (deftype render-op () - '(member :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate - :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over - :disjoint-over-reverse :disjoint-in :disjoint-in-reverse - :disjoint-out :disjoint-out-reverse :disjoint-atop - :disjoint-atop-reverse :disjoint-xor - :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over - :conjoint-over-reverse :conjoint-in :conjoint-in-reverse - :conjoint-out :conjoint-out-reverse :conjoint-atop - :conjoint-atop-reverse :conjoint-xor))) - -;; Now these pictures objects are like graphics contexts. I was about -;; to introduce a synchronous mode, realizing that the RENDER protocol -;; provides no provision to actually query a picture object's values. -;; *sigh* - -(def-clx-class (picture (:copier nil)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - (format) - (%changed-p) - (%server-values) - (%values) - (%drawable)) - -(defun picture-drawable (picture) - (picture-%drawable picture)) - -;; xx make id, display, format readonly - -(defun %render-change-picture-clip-rectangles (picture rectangles) - "Dont call me, use (SETF PICTURE-CLIP-MASK) instead." - (declare (optimize (speed 0))) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderSetPictureClipRectangles+) - (picture picture) - (int16 (picture-clip-x-origin picture)) - (int16 (picture-clip-y-origin picture)) - ((sequence :format int16) rectangles)))) - -(macrolet ((foo (&rest specs) - `(progn - ,@(loop for (type slot default) in specs - for index from 0 - collect - `(progn - (defun ,(xintern 'picture- slot) (picture) - (aref (picture-%values picture) ,index)) - (defun (setf ,(xintern 'picture- slot)) (new-value picture) - (setf (picture-%changed-p picture) t) - (setf (aref (picture-%values picture) ,index) new-value)))) - - (defun synchronise-picture-state (picture) - (when (picture-%changed-p picture) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderChangePicture+) - (picture picture) - (mask - ,@(loop for (type slot default) in specs - for index from 0 - collect - `(,type (and - ,(cond ((eql slot 'clip-mask) - `(not (typep (aref (picture-%values picture) ,index) - 'sequence))) - (t - 't)) - (not (eq (aref (picture-%values picture) ,index) - (aref (picture-%server-values picture) ,index))) - (setf (aref (picture-%server-values picture) ,index) - (aref (picture-%values picture) ,index)))))))) - ,(let ((index (position 'clip-mask specs :key #'second))) - `(unless (eql (aref (picture-%values picture) ,index) - (aref (picture-%server-values picture) - ,index)) - (%render-change-picture-clip-rectangles - picture (aref (picture-%values picture) ,index)) - (setf (aref (picture-%server-values picture) ,index) - (aref (picture-%values picture) ,index)))) - - (setf (picture-%changed-p picture) nil))) - - (defun render-create-picture - (drawable - &key format - (picture (make-picture :display (drawable-display drawable))) - ,@(loop for (type slot default-value) in specs - collect (cond ((eql slot 'clip-mask) - `(clip-mask :none)) - (t - slot))) - ) - ;; xxx also offer to give a colormap instead of a picture-format - ;; values! - (let ((display (drawable-display drawable))) - (ensure-render-initialized display) - (unless format - ;; xxx check for drawable being a window - (setf format (find-window-picture-format drawable))) - (let ((pid (allocate-resource-id display picture 'picture))) - (setf (picture-id picture) pid) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderCreatePicture+) - (resource-id pid) - (drawable drawable) - (picture-format format) - (mask - ,@(loop for (type slot default) in specs - collect - (cond ((eql slot 'clip-mask) - (list type `(and - (not (typep clip-mask 'sequence)) - clip-mask))) - (t - (list type slot))))))) - (when (typep clip-mask 'sequence) - (%render-change-picture-clip-rectangles picture clip-mask)) - (setf (picture-format picture) format) - (setf (picture-%server-values picture) - (vector ,@(loop for (type slot default) in specs - collect - `(or ,slot ,default)))) - (setf (picture-%values picture) (copy-seq (picture-%server-values picture))) - (setf (picture-%drawable picture) drawable) - picture)) - - (defconstant +picture-state-length+ - ,(length specs)) ))) - - (foo ((member :off :on) repeat :off) - ((or (member :none) picture) alpha-map :none) - (int16 alpha-x-origin 0) - (int16 alpha-y-origin 0) - (int16 clip-x-origin 0) - (int16 clip-y-origin 0) - ;; ### Now that is not correct is it?: - ((or (member :none) pixmap) clip-mask :none) - ((member :off :on) graphics-exposures :on) - ((member :clip-by-children :include-inferiors) subwindow-mode :clip-by-children) - ((member :sharp :smooth) poly-edge :smooth) - ((member :precise :imprecise) poly-mode :precise) - ((or (member :none) #||xatom||#) dither :none) - ((member :off :on) component-alpha :off))) - -(defun render-free-picture (picture) - (let ((display (picture-display picture))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderFreePicture+) - (picture picture)))) - -(defun render-free-glyph-set (glyph-set) - (let ((display (glyph-set-display glyph-set))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderFreeGlyphSet+) - (glyph-set glyph-set)))) - -(defun render-query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) - ((data +X-RenderQueryVersion+) - (card32 0) - (card32 1)) - (values - (card32-get 8) - (card32-get 12) ))) - -(defun render-query-picture-formats (display) - (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) - ((data +X-RenderQueryPictFormats+)) - (let ((n-picture-formats (card32-get 8)) - (n-screens (card32-get 12)) - (n-depths (card32-get 16)) - (n-visuals (card32-get 20)) - (n-subpixel (card32-get 24))) - (declare (ignore n-screens n-depths n-visuals n-subpixel)) - (loop for i below n-picture-formats - collect - (let ((off (+ (* 8 4) - (* i 28)))) ;size of picture-format-info - (make-picture-format - :display display - :id (card32-get (+ off 0)) - :type (member8-get (+ off 4) :indexed :direct) - :depth (card8-get (+ off 5)) - :red-byte (byte (integer-length (card16-get (+ off 10))) - (card16-get (+ off 8))) - :green-byte (byte (integer-length (card16-get (+ off 14))) - (card16-get (+ off 12))) - :blue-byte (byte (integer-length (card16-get (+ off 18))) - (card16-get (+ off 16))) - :alpha-byte (byte (integer-length (card16-get (+ off 22))) - (card16-get (+ off 20))) - :colormap (let ((cmid (card32-get (+ off 24)))) - (unless (zerop cmid) - (lookup-colormap display cmid))))))))) - -(defun render-fill-rectangle (picture op color x1 y1 w h) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (synchronise-picture-state picture) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderFillRectangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id picture)) - (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) - (int16 x1) (int16 y1) (card16 w) (card16 h)))) - -;; fill rectangles, colors. - -(defun render-triangles-1 (picture op source src-x src-y format coord-sequence) - ;; For performance reasons we do a special typecase on (simple-array - ;; (unsigned-byte 32) (*)), so that it'll be possible to have high - ;; performance rasters. - (macrolet ((guts () - '(let ((display (picture-display picture))) - (synchronise-picture-state picture) - (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTriangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - (picture-format format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) )))) - (typecase coord-sequence - ((simple-array (unsigned-byte 32) (*)) - (locally - (declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence)) - (guts))) - (t - (guts))))) - -#|| -(defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1)) - ...) -||# - -(defun render-set-picture-transform (picture a b c d e f p q r) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (synchronise-picture-state picture) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderSetPictureTransform+) - #| - (card8 0) ;; render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - |# - (resource-id (picture-id picture)) - - (card32 a) - (card32 b) - (card32 c) - - (card32 d) - (card32 e) - (card32 f) - - (card32 p) - (card32 q) - (card32 r)))) - -(defun render-query-filters (drawable) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) - ((data +X-RenderQueryFilters+) - (drawable drawable)) - (let* ((len (card32-get 4)) - (n-aliases (card32-get 8)) - (n-filters (card32-get 12)) - (off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4))))) - (print (list :aliases - (loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2)))))) - (print (list :foo len n-aliases n-filters - (loop for i below len - collect (card8-get (+ off 0 (* 4 i))) - collect (card8-get (+ off 1 (* 4 i))) - collect (card8-get (+ off 2 (* 4 i))) - collect (card8-get (+ off 3 (* 4 i)))))) - (print - (labels ((grab-string (j) - (let ((n (card8-get j))) - (incf j) - (values - (map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j))) - j)))) - (loop repeat n-filters collect - (multiple-value-bind (s j) (grab-string off) - (setf off j) - (intern (string-upcase s) :keyword))))) - #+NIL - (loop for i below n-picture-formats - collect - (let ((off (+ (* 8 4) - (* i 28)))) ;size of picture-format-info - (make-picture-format - :display display - :id (card32-get (+ off 0)) - :type (member8-get (+ off 4) :indexed :direct) - :depth (card8-get (+ off 5)) - :red-byte (byte (integer-length (card16-get (+ off 10))) - (card16-get (+ off 8))) - :green-byte (byte (integer-length (card16-get (+ off 14))) - (card16-get (+ off 12))) - :blue-byte (byte (integer-length (card16-get (+ off 18))) - (card16-get (+ off 16))) - :alpha-byte (byte (integer-length (card16-get (+ off 22))) - (card16-get (+ off 20))) - :colormap (let ((cmid (card32-get (+ off 24)))) - (unless (zerop cmid) - (lookup-colormap display cmid)))))))))) - -(defun render-set-filter (picture filter) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (synchronise-picture-state picture) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderSetPictureFilter+) - (resource-id (picture-id picture)) - (card16 (length filter)) - (card16 0) ;pad - ((sequence :format card8) (map 'vector #'char-code filter))))) - - - -#|| -(defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over)) - (render-triangles-1 destination op source ...) - ) -||# - -(defun render-trapezoids-1 (picture op source src-x src-y mask-format coord-sequence) - ;; coord-sequence is top bottom - ;; line-1-x1 line-1-y1 line-1-x2 line-1-y2 - ;; line-2-x1 line-2-y1 line-2-x2 line-2-y2 ... - ;; - (let ((display (picture-display picture))) - (synchronise-picture-state picture) - (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTrapezoids+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - ((or (member :none) picture-format) mask-format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) ))) - -(defun render-composite (op - source mask dest - src-x src-y mask-x mask-y dst-x dst-y - width height) - (let ((display (picture-display source))) - (synchronise-picture-state source) - (when mask (synchronise-picture-state mask)) - (synchronise-picture-state dest) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderComposite+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (if mask (picture-id mask) 0)) - (resource-id (picture-id dest)) - (int16 src-x) - (int16 src-y) - (int16 mask-x) - (int16 mask-y) - (int16 dst-x) - (int16 dst-y) - (card16 width) - (card16 height)))) - -(def-clx-class (glyph-set (:copier nil) - ) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - (format)) - -(defun render-create-glyph-set (format &key glyph-set) - (let ((display (picture-format-display format))) - (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) - (gsid (setf (glyph-set-id glyph-set) - (allocate-resource-id display glyph-set 'glyph-set)))) - (declare (ignore gsid)) - (setf (glyph-set-format glyph-set) format) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderCreateGlyphSet+) - (glyph-set glyph-set) - (picture-format format)) - glyph-set))) - -(defun render-reference-glyph-set (existing-glyph-set &key glyph-set) - (let ((display (glyph-set-display existing-glyph-set))) - (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) - (gsid (setf (glyph-set-id glyph-set) - (allocate-resource-id display glyph-set 'glyph-set)))) - (declare (ignore gsid)) - (setf (glyph-set-format glyph-set) - (glyph-set-format existing-glyph-set)) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderReferenceGlyphSet+) - (glyph-set glyph-set) - (glyph-set existing-glyph-set)) - glyph-set))) - -(defun render-composite-glyphs-8 (dest glyph-set source dest-x dest-y sequence - &key (op :over) - (alu op) ;for the fun of it - (src-x 0) - (src-y 0) - (mask-format :none) - (start 0) - (end (length sequence))) - (let ((display (picture-display dest))) - (ensure-render-initialized display) - (synchronise-picture-state dest) - (synchronise-picture-state source) - (when (stringp sequence) - ;; lazy me, but then you should not confuse glyphs with - ;; characters anyway. - (setf sequence (map 'vector #'char-code sequence))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderCompositeGlyphs8+) - (render-op alu) - (card8 0) (card16 0) ;padding - (picture source) - (picture dest) - ((or (member :none) picture-format) mask-format) - (glyph-set glyph-set) - (int16 src-x) (int16 src-y) - (card8 (- end start)) ;length of glyph elt - (card8 0) (card16 0) ;padding - (int16 dest-x) (int16 dest-y) ;dx, dy - ((sequence :format card8) sequence)))) - -(defmacro %render-composite-glyphs - (opcode type transform display dest glyph-set source dest-x dest-y sequence - alu src-x src-y mask-format start end) - (let ((size (ecase type (card8 1) (card16 2) (card32 4))) - ;; FIXME: the last chunk for CARD8 can be 254. - (chunksize (ecase type (card8 252) (card16 254) (card32 254)))) - `(multiple-value-bind (nchunks leftover) - (floor (- end start) ,chunksize) - (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size))) - (if (> leftover 0) - (+ 8 (* 4 (ceiling (* leftover ,size) 4))) - 0))) - (request-length (+ 7 (/ payloadsize 4)))) - (declare (integer request-length)) - (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length)) - (data ,opcode) - (length request-length) - (render-op ,alu) - (card8 0) (card16 0) ;padding - (picture ,source) - (picture ,dest) - ((or (member :none) picture-format) ,mask-format) - (glyph-set ,glyph-set) - (int16 ,src-x) (int16 ,src-y) - (progn - (let ((boffset (+ buffer-boffset 28)) - (start ,start) - (end ,end) - (dest-x ,dest-x) - (dest-y ,dest-y)) - (dotimes (i nchunks) - (set-buffer-offset boffset) - (put-items (0) - (card8 ,chunksize) - (card8 0) - (card16 0) - (int16 dest-x) - (int16 dest-y) - ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence)) - (setq dest-x 0 dest-y 0) - (incf boffset (+ 8 (* ,chunksize ,size))) - (incf start ,chunksize)) - (when (> leftover 0) - (set-buffer-offset boffset) - (put-items (0) - (card8 leftover) - (card8 0) - (card16 0) - (int16 dest-x) - (int16 dest-y) - ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence)) - ;; padding? - (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4))))) - (setf (buffer-boffset ,display) boffset)))))))) - -(defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence - &key (op :over) - (alu op) ;for the fun of it - (src-x 0) - (src-y 0) - (mask-format :none) - (start 0) - (end (length sequence))) - ;; xxx do we want to go with some translate function as draw-glyphs? - (declare (type array-index start end)) - (let ((display (picture-display dest))) - (ensure-render-initialized display) - (synchronise-picture-state dest) - (synchronise-picture-state source) - ;; hmm find out the element size - (typecase sequence - ((array (unsigned-byte 8) (*)) - (%render-composite-glyphs +X-RenderCompositeGlyphs8+ card8 nil - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end)) - ((array (unsigned-byte 16) (*)) - (%render-composite-glyphs +X-RenderCompositeGlyphs16+ card16 nil - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end)) - ((array (unsigned-byte 32) (*)) - (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 nil - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end)) - (string - (%render-composite-glyphs #.(cond ((<= char-code-limit (expt 2 8)) '+X-RenderCompositeGlyphs8+) - ((<= char-code-limit (expt 2 16)) '+X-RenderCompositeGlyphs16+) - ((<= char-code-limit (expt 2 32)) '+X-RenderCompositeGlyphs32+) - (t - (error "Wow!"))) - #.(cond ((<= char-code-limit (expt 2 8)) 'card8) - ((<= char-code-limit (expt 2 16)) 'card16) - ((<= char-code-limit (expt 2 32)) 'card32) - (t - (error "Wow!"))) - #'char-code - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end)) - (t - ;; should we bother testing the array element type? - (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 - #'(lambda (elt) - (if (characterp elt) - (char-code elt) - elt)) - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end))) )) - -;; --- idea: Allow data to be an image to avoid unecessary consing? - noss -(defun render-add-glyph (glyph-set id &key x-origin y-origin x-advance y-advance data) - (let ((display (glyph-set-display glyph-set))) - (ensure-render-initialized display) - (let* ((w (array-dimension data 1)) - (h (array-dimension data 0)) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (let* ((byte-per-line (* 4 (ceiling - (* w (picture-format-depth (glyph-set-format glyph-set))) - 32))) - (request-length (+ 28 - (* h byte-per-line)))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderAddGlyphs+) - (length (ceiling request-length 4)) - (glyph-set glyph-set) - (card32 1) ;number glyphs - (card32 id) ;id - (card16 w) - (card16 h) - (int16 x-origin) - (int16 y-origin) - (int16 x-advance) - (int16 y-advance) - (progn - (setf (buffer-boffset display) (advance-buffer-offset 28)) - (let ((im (create-image :width w :height h :depth 8 :data data))) - (write-image-z display im 0 0 w h - byte-per-line ;padded bytes per line - unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) - -(defun render-add-glyph-from-picture (glyph-set picture - &key x-origin y-origin x-advance y-advance - x y width height) - ;; untested, the duplication of x-origin seems bogus. - ;; Still untested, but these modifications seem to be more likely, (x,y) would be the offset into the picture. - ;; and orgin advance would be properties of the defined glyph. - (let ((display (glyph-set-display glyph-set))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderAddGlyphsFromPicture+) - (glyph-set glyph-set) - (picture picture) - (card16 width) - (card16 height) - (card16 x-origin) - (card16 y-origin) - (card16 x-advance) - (card16 y-advance) - (card16 x) - (card16 y)))) - -;; untested -(defun render-free-glyphs (glyph-set glyphs) - "This request removes glyphs from glyph-set. Each glyph must exist in glyph-set (else a Match error results)." - (let ((display (glyph-set-display glyph-set))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderFreeGlyphs+) - (glyph-set glyph-set) - ((sequence :format card32) glyphs)))) - - -#|| -;;; -------------------------------------------------------------------------------- - -;; testing code: - -(defun x (op) - (let ((dpy (open-display ""))) - (render-query-version dpy) - (unwind-protect - (let* ((win (screen-root (first (display-roots dpy)))) - (display dpy) - (pf (find-window-picture-format win)) - (pm (xlib:create-pixmap - :depth (xlib:drawable-depth win) - :drawable win :width 1 :height 1)) - (pm.p (render-create-picture pm - :format pf - :repeat :on)) - (win.p (render-create-picture win :format pf)) - (gs (render-create-glyph-set (first - (find-matching-picture-formats - dpy - :alpha 8 - :red-max 0 - :green-max 0 - :blue-max 0))))) - (xlib:clear-area win) - (render-fill-rectangle pm.p :src (list #xFFFF 0 0 0) 0 0 100 100) - (render-add-glyph gs 18 - :data (make-array (list 3 3) - :initial-contents '((255 000 000) - (000 255 000) - (000 000 255)) - :element-type '(unsigned-byte 8)) - :x-advance 4 - :y-advance 0 - :x-origin 0 - :y-origin 0) - (let ((w 50) - (h 50)) - (let ((data (make-array (list h w) :element-type '(unsigned-byte 8) :initial-element 0))) - (dotimes (i w) - (dotimes (j h) - (setf (aref data i j) (* 3 i)))) - (render-add-glyph gs 17 - :data data - :x-advance (+ w 2) - :y-advance 0 - :x-origin 0 - :y-origin 0))) - - (render-composite-glyphs-8 win.p gs pm.p - 200 330 - (vector 17 18 18 17 17 17 17 17 17 17) - :alu op - ) - ;; - (display-finish-output dpy) - (close-display dpy))))) - -(defun z (op) - (let ((dpy (open-display ""))) - (unwind-protect - (let* ((win (screen-root (first (display-roots dpy)))) - (pic (render-create-picture win)) - (fmt (first (find-matching-picture-formats - dpy - :red-min 8 - :green-min 8 - :blue-min 8 - :alpha-min 8))) - (px (xlib:create-pixmap :width 256 :height 256 :depth (picture-format-depth fmt) - :drawable win)) - (px.pic (render-create-picture px :format fmt)) - (px.gc (xlib:create-gcontext :drawable px))) - (xlib:clear-area win) - ;; - (render-fill-rectangle px.pic :src - (list #x8000 #x0000 #x8000 #xFFFF) - 0 0 256 256) - - (render-composite :src pic pic px.pic - 350 350 350 350 0 0 256 256) - ;; - (render-fill-rectangle px.pic :over - (list #x8000 #x8000 #x8000 #x8000) - 0 0 100 100) - (render-composite :src - px.pic px.pic pic - 0 0 0 0 350 350 - 256 256) - (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800) - (display-finish-output dpy)) - (close-display dpy)))) - -;;; ---------------------------------------------------------------------------------------------------- - -(defun y (op) - (let ((dpy (open-display ""))) - (render-query-version dpy) - (unwind-protect - (let* ((win (screen-root (first (display-roots dpy)))) - (pic - (render-create-picture win)) - (px (xlib:create-pixmap :drawable win - :width 256 - :height 256 - :depth 32)) - (px.gc (xlib:create-gcontext :drawable px))) - (dotimes (x 256) - (dotimes (y 256) - (setf (xlib:gcontext-foreground px.gc) - (dpb x (byte 8 24) - (dpb y (byte 8 16) - (dpb y (byte 8 8) - y)))) - (xlib:draw-point px px.gc x y) - )) - (xlib:clear-area win) - (let ((q (render-create-picture px - :format - (first (find-matching-picture-formats - dpy - :depth 32 - :alpha 8 :red 8 :green 8 :blue 8)) - :component-alpha :on - :repeat :off))) - (render-composite op - q - q - pic - 0 0 - 0 0 - 100 100 - 400 400)) - (let () - ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200) - (display-finish-output dpy))) - (close-display dpy)))) - -(defun zz () - (let* ((dpy (xlib:open-display "")) - (win (screen-root (first (display-roots dpy)))) - (pic (render-create-picture win))) - (xlib:clear-area win) - (setf (picture-clip-mask pic) (list 100 100 200 2000)) - (render-fill-rectangle pic :over (list #xFFFF 0 0 #x400) 0 0 2000 2000) - (display-finish-output dpy) - (close-display dpy))) -||# - - -;;;; Cursors - -(defun render-create-cursor (picture &optional (x 0) (y 0)) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (synchronise-picture-state picture) - (let* ((cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor))) - (setf (cursor-id cursor) cid) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderCreateCursor+) - (resource-id cid) - (resource-id (picture-id picture)) - (card16 x) - (card16 y)) - cursor))) diff --git a/src/clx/xtest.lisp b/src/clx/xtest.lisp deleted file mode 100644 index 587a845b8..000000000 --- a/src/clx/xtest.lisp +++ /dev/null @@ -1,154 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- -;;; -;;; Implementation of the XTest extension as described by -;;; http://www.x.org/docs/Xext/xtest.pdf -;;; -;;; Written by Lionel Flandrin in july -;;; 2008 and placed in the public domain. -;;; -;;; TODO: -;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard -;;; * Add the missing (declare (type ... - -(defpackage :xtest - (:use :common-lisp :xlib) - (:import-from :xlib - #:data - #:card8 - #:card8-get - #:card16 - #:card16-get - #:card32 - #:card32-get - #:extension-opcode - #:define-extension - #:gcontext - #:resource-id - #:window-id - #:cursor - #:make-cursor - #:with-buffer-request-and-reply - #:with-buffer-request - #:display) - (:export - ;; Constants - #:+major-version+ - #:+minor-version+ - - ;; Functions - #:set-gc-context-of-gc - #:get-version - #:compare-cursor - #:fake-motion-event - #:fake-button-event - #:fake-key-event - #:grab-control)) - -(in-package :xtest) - -(define-extension "XTEST") - -(defmacro opcode (display) - `(extension-opcode ,display "XTEST")) - -;;; The version we implement -(defconstant +major-version+ 2) -(defconstant +minor-version+ 2) - -(defconstant +none+ 0) -(defconstant +current-cursor+ 1) - -;;; XTest opcodes -(defconstant +get-version+ 0) -(defconstant +compare-cursor+ 1) -(defconstant +fake-input+ 2) -(defconstant +grab-control+ 3) - -;;; Fake events -(defconstant +fake-key-press+ 2) -(defconstant +fake-key-release+ 3) -(defconstant +fake-button-press+ 4) -(defconstant +fake-button-release+ 5) -(defconstant +fake-motion-notify+ 6) - -;;; Client operations -(defun set-gc-context-of-gc (gcontext gcontext-id) - (declare (type gcontext gcontext) - (type resource-id gcontext-id)) - (setf (gcontext-id gcontext) gcontext-id)) - -;;; Server requests -(defun get-version (display &optional (major +major-version+) (minor +minor-version+)) - "Returns the major and minor version of the server's XTest implementation" - (declare (type display display)) - (with-buffer-request-and-reply (display (opcode display) nil) - ((data +get-version+) - (card8 major) - (card16 minor)) - (values (card8-get 1) - (card16-get 8)))) - -(defun compare-cursor (display window &optional (cursor-id +current-cursor+)) - (declare (type display display) - (type resource-id cursor-id) - (type window window)) - (with-buffer-request-and-reply (display (opcode display) nil) - ((data +compare-cursor+) - (resource-id (window-id window)) - (resource-id cursor-id)) - (values (card8-get 1)))) - -(defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0)) - "Move the mouse pointer at coordinates (x, y). If :relative is t, -the movement is relative to the pointer's current position" - (declare (type display display)) - (with-buffer-request (display (opcode display)) - (data +fake-input+) - (card8 +fake-motion-notify+) - (card8 (if relative 1 0)) - (pad16 0) - (card32 delay) - (card32 root-window-id) - (pad32 0 0) - (card16 x) - (card16 y) - (pad32 0 0))) - -(defun fake-button-event (display button pressed &key (delay 0)) - "Send a fake button event (button pressed or released) to the -server. Most of the time, button 1 is the left one, 2 the middle and 3 -the right one but it's not always the case." - (declare (type display display)) - (with-buffer-request (display (opcode display)) - (data +fake-input+) - (card8 (if pressed +fake-button-press+ +fake-button-release+)) - (card8 button) - (pad16 0) - (card32 delay) - (pad32 0 0 0 0 0 0))) - -(defun fake-key-event (display keycode pressed &key (delay 0)) - "Send a fake key event (key pressed or released) to the server based -on its keycode." - (declare (type display display)) - (with-buffer-request (display (opcode display)) - (data +fake-input+) - (card8 (if pressed +fake-key-press+ +fake-key-release+)) - (card8 keycode) - (pad16 0) - (card32 delay) - (pad32 0 0 0 0 0 0))) - -(defun grab-control (display grab?) - "Make the client grab the server, that is allow it to make requests -even when another client grabs the server." - (declare (type display display)) - (with-buffer-request (display (opcode display)) - (data +grab-control+) - (card8 (if grab? 1 0)) - (pad8 0) - (pad16 0))) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; End: diff --git a/src/clx/xvidmode.lisp b/src/clx/xvidmode.lisp deleted file mode 100644 index 8fd940947..000000000 --- a/src/clx/xvidmode.lisp +++ /dev/null @@ -1,730 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: XFree86 video mode extension -;;; Created: 2003 03 28 15:28 -;;; Author: Iban Hatchondo -;;; --------------------------------------------------------------------------- -;;; (c) copyright 2003 by Iban Hatchondo - -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -;;; - -;;; THIS IS NOT AN X CONSORTIUM STANDARD OR AN X PROJECT TEAM SPECIFICATION - -;;; DESCRIPTION -;;; -;;; These functions provide an interface to the server extension -;;; XFree86-VidModeExtension which allows the video modes to be -;;; queried, adjusted dynamically and the mode switching to be -;;; controlled. - -;;; [ personal notes ] -;;; -;;; The documentation on this extension is very poor, probably, -;;; because it is not an X standard nor an X project team spec. -;;; Because of that, it need to be tested on some XFree 3.3.6, -;;; and XFree 4.3.x to ensure that all request are correctly -;;; constructed as well as to indentify any obsolete/wrong -;;; functions I made. - -(in-package :xlib) - -(export '(mode-info - mode-info-dotclock - mode-info-hdisplay - mode-info-hsyncstart - mode-info-hsyncend - mode-info-htotal - mode-info-hskew - mode-info-vdisplay - mode-info-vsyncstart - mode-info-vsyncend - mode-info-vtotal - mode-info-flags - mode-info-privsize - mode-info-private - make-mode-info - - xfree86-vidmode-query-version - xfree86-vidmode-set-client-version - xfree86-vidmode-get-permissions - xfree86-vidmode-mod-mode-line - xfree86-vidmode-get-mode-line - xfree86-vidmode-get-all-mode-lines - xfree86-vidmode-add-mode-line - xfree86-vidmode-delete-mode-line - xfree86-vidmode-validate-mode-line - xfree86-vidmode-get-gamma - xfree86-vidmode-set-gamma - xfree86-vidmode-get-gamma-ramp - xfree86-vidmode-set-gamma-ramp - xfree86-vidmode-get-gamma-ramp-size - xfree86-vidmode-lock-mode-switch - xfree86-vidmode-switch-to-mode - xfree86-vidmode-switch-mode - xfree86-vidmode-select-next-mode - xfree86-vidmode-select-prev-mode - xfree86-vidmode-get-monitor - xfree86-vidmode-get-viewport - xfree86-vidmode-set-viewport - xfree86-vidmode-get-dotclocks) - :xlib) - -;; current version numbers -;; -;; major 0 == uses parameter-to-wire functions in XFree86 libXxf86vm. -;; major 1 == uses parameter-to-wire functions hard-coded in xvidtune client. -;; major 2 == uses new protocol version in XFree86 4.0. -(defconstant +xf86vidmode-major-version+ 2) -(defconstant +xf86vidmode-minor-version+ 2) - -;; requests number. -(defconstant +query-version+ 0) -(defconstant +get-mode-line+ 1) -(defconstant +mod-mode-line+ 2) -(defconstant +switch-mode+ 3) -(defconstant +get-monitor+ 4) -(defconstant +lock-mode-switch+ 5) -(defconstant +get-all-mode-lines+ 6) -(defconstant +add-mode-line+ 7) -(defconstant +delete-mode-line+ 8) -(defconstant +validate-mode-line+ 9) -(defconstant +switch-to-mode+ 10) -(defconstant +get-viewport+ 11) -(defconstant +set-viewport+ 12) - -;; new for version 2.x of this extension. -(defconstant +get-dot-clocks+ 13) -(defconstant +set-client-version+ 14) -(defconstant +set-gamma+ 15) -(defconstant +get-gamma+ 16) -(defconstant +get-gamma-ramp+ 17) -(defconstant +set-gamma-ramp+ 18) -(defconstant +get-gamma-ramp-size+ 19) -(defconstant +get-permisions+ 20) - -(define-extension "XFree86-VidModeExtension" - :events (:xfree86-vidmode-notify) - :errors (xf86-vidmode-bad-clock - xf86-vidmode-bad-htimings - xf86-vidmode-bad-vtimings - xf86-vidmode-mode-unsuitable - xf86-vidmode-extension-disabled - xf86-vidmode-client-not-local - xf86-vidmode-zoom-locked)) - -(define-condition xf86-vidmode-bad-clock (request-error) ()) -(define-condition xf86-vidmode-bad-htimings (request-error) ()) -(define-condition xf86-vidmode-bad-vtimings (request-error) ()) -(define-condition xf86-vidmode-mode-unsuitable (request-error) ()) -(define-condition xf86-vidmode-extension-disabled (request-error) ()) -(define-condition xf86-vidmode-client-not-local (request-error) ()) -(define-condition xf86-vidmode-zoom-locked (request-error) ()) - -(define-error xf86-vidmode-bad-clock decode-core-error) -(define-error xf86-vidmode-bad-htimings decode-core-error) -(define-error xf86-vidmode-bad-vtimings decode-core-error) -(define-error xf86-vidmode-mode-unsuitable decode-core-error) -(define-error xf86-vidmode-extension-disabled decode-core-error) -(define-error xf86-vidmode-client-not-local decode-core-error) -(define-error xf86-vidmode-zoom-locked decode-core-error) - -(declare-event :XFree86-VidMode-notify - (card16 sequence) - (window (window event-window)) ; the root window of event screen - (int16 state) ; what happend - (int16 kind) ; what happend - (boolean forced-p) ; extents of a new region - ((or null card32) time)) ; event timestamp - -(defstruct mode-info - (dotclock 0 :type card32) - (hdisplay 0 :type card16) - (hsyncstart 0 :type card16) - (hsyncend 0 :type card16) - (htotal 0 :type card16) - (hskew 0 :type card32) - (vdisplay 0 :type card16) - (vsyncstart 0 :type card16) - (vsyncend 0 :type card16) - (vtotal 0 :type card16) - (flags 0 :type card32) - (privsize 0 :type card32) - (private nil :type sequence)) - -(defmacro vidmode-opcode (display) - `(extension-opcode ,display "XFree86-VidModeExtension")) - -(declaim (inline screen-position)) -(defun screen-position (screen display) - (declare (type display display) - (type screen screen)) - (declare (clx-values position)) - (let ((position (position screen (xlib:display-roots display)))) - (if (not (numberp position)) - (error "screen ~A not found in display ~A" screen display) - position))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; ;;;; -;;;; public XFree86-VidMode Extension routines ;;;; -;;;; ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun xfree86-vidmode-query-version (display) - "Determine the version of the extension built into the server. -return two values major-version and minor-version in that order." - (declare (type display display)) - (with-buffer-request-and-reply - (display (vidmode-opcode display) nil :sizes 16) - ((data +query-version+)) - (let ((major (card16-get 8)) - (minor (card16-get 10))) - (declare (type card16 major minor)) - (when (>= major 2) - (XFree86-VidMode-set-client-version display)) - (values major minor)))) - -(defun xfree86-vidmode-set-client-version (display) - (declare (type display display)) - (with-buffer-request (display (vidmode-opcode display)) - (data +set-client-version+) - (card16 +xf86vidmode-major-version+) - (card16 +xf86vidmode-minor-version+))) - -(defun xfree86-vidmode-get-permissions (dpy screen) - (declare (type display dpy) - (type screen screen)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-permisions+) - (card16 (screen-position screen dpy)) - (card16 0)) - (values - (card32-get 8)))) - -(defun xfree86-vidmode-mod-mode-line (display screen mode-line) - "Change the settings of the current video mode provided the -requested settings are valid (e.g. they don't exceed the -capabilities of the monitor)." - (declare (type display display) - (type screen screen)) - (let* ((major (xfree86-vidmode-query-version display)) - (v (mode-info->v-card16 mode-line major))) - (declare (type card16 major) - (type simple-vector v)) - (with-buffer-request (display (vidmode-opcode display)) - (data +mod-mode-line+) - (card32 (screen-position screen display)) - ((sequence :format card16 :start 2) v)))) - -(defun xfree86-vidmode-get-mode-line (display screen) - "Query the settings for the currently selected video mode. -return a mode-info structure fields with the server answer. -If there are any server private values (currently only -applicable to the S3 server) the function will store it -into the returned structure." - (declare (clx-values mode-info) - (type display display) - (type screen screen)) - (let ((major (xfree86-vidmode-query-version display)) - (offset 8)) - (declare (type fixnum offset) - (type card16 major)) - (with-buffer-request-and-reply - (display (vidmode-opcode display) nil :sizes (8 16 32)) - ((data +get-mode-line+) - (card16 (screen-position screen display)) - (card16 0)) - (let ((mode-info - (make-mode-info - :dotclock (card32-get offset) - :hdisplay (card16-get (incf offset 4)) - :hsyncstart (card16-get (incf offset 2)) - :hsyncend (card16-get (incf offset 2)) - :htotal (card16-get (incf offset 2)) - :hskew (if (< major 2) 0 (card16-get (incf offset 2))) - :vdisplay (card16-get (incf offset 2)) - :vsyncstart (card16-get (incf offset 2)) - :vsyncend (card16-get (incf offset 2)) - :vtotal (card16-get (incf offset 2)) - :flags (card32-get (incf offset (if (< major 2) 2 4))))) - (size (card32-get (incf offset (if (< major 2) 4 16))))) - (declare (type card32 size)) - (incf offset 4) - (setf (mode-info-privsize mode-info) size - (mode-info-private mode-info) - (sequence-get :format card32 :index offset - :length size :result-type 'list)) - mode-info)))) - -(defun xfree86-vidmode-get-all-mode-lines (dpy screen) - "Returns a list containing all video modes (as mode-info structure). -The first element of the list corresponds to the current video mode." - (declare (type display dpy) - (type screen screen)) - (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) - (declare (type card16 major minor)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-all-mode-lines+) - (card16 (screen-position screen dpy))) - (values - ;; Note: There was a bug in the protocol implementation in versions - ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). - ;; Check the server's version, and accept the old format if appropriate. - (loop with bug-p = (and (= major 0) (< minor 8)) - with offset of-type fixnum = 32 - for i of-type card32 from 0 below (or (card32-get 8) 0) - collect - (let ((mode-info - (make-mode-info - :dotclock (card32-get offset) - :hdisplay (card16-get (incf offset 4)) - :hsyncstart (card16-get (incf offset 2)) - :hsyncend (card16-get (incf offset 2)) - :htotal (card16-get (incf offset 2)) - :hskew (if (< major 2) 0 (card32-get (incf offset 2))) - :vdisplay (card16-get (incf offset 4)) - :vsyncstart (card16-get (incf offset 2)) - :vsyncend (card16-get (incf offset 2)) - :vtotal (card16-get (incf offset 2)) - :flags (card32-get (incf offset (if (< major 2) 2 6))))) - (size (card32-get (incf offset (if (< major 2) 4 16))))) - (declare (type card32 size)) - (incf offset 4) - (when bug-p - (setf size 0)) - (setf (mode-info-privsize mode-info) size - (mode-info-private mode-info) - (sequence-get :format card32 :index offset - :length size :result-type 'list)) - (incf offset (* 4 size)) - mode-info)))))) - -(defun xfree86-vidmode-add-mode-line (dpy scr new &key (after (make-mode-info))) - (declare (type display dpy) - (type screen scr)) - (let* ((private (mode-info-private new)) - (privsize (mode-info-privsize new)) - (major (xfree86-vidmode-query-version dpy)) - (i (if (< major 2) 14 22)) - (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0))) - (declare (type card32 privsize) - (type fixnum i) - (type card16 major) - (type simple-vector v)) - (mode-info->v-card16 new major :encode-private nil :data v) - (mode-info->v-card16 after major :encode-private nil :data v :index i) - (setf i (- (* 2 i) 2)) - ;; strore private info (sequence card32) according clx bytes order. - (loop for card of-type card32 in private - do (multiple-value-bind (w1 w2) (__card32->card16__ card) - (setf (svref v (incf i)) w1 - (svref v (incf i)) w2))) - - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +add-mode-line+) - (card32 (screen-position scr dpy)) - ((sequence :format card16) v)))) - -(defun xfree86-vidmode-delete-mode-line (dpy scr mode-info) - "Delete mode argument. The specified mode must match an existing mode. -To be considered a match, all of the fields of the given mode-info -structure must match, except the privsize and private fields. -If the mode to be deleted is the current mode, a mode switch to the next -mode will occur first. The last remaining mode can not be deleted." - (declare (type display dpy) - (type screen scr)) - (let* ((major (xfree86-vidmode-query-version dpy)) - (v (mode-info->v-card16 mode-info major))) - (declare (type card16 major) - (type simple-vector v)) - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +delete-mode-line+) - (card32 (screen-position scr dpy)) - ((sequence :format card16) v)))) - -(defconstant +mode-status+ - '#(:MODE_BAD ; unspecified reason - :MODE_ERROR ; error condition - :MODE_OK ; Mode OK - :MODE_HSYNC ; hsync out of range - :MODE_VSYNC ; vsync out of range - :MODE_H_ILLEGAL ; mode has illegal horizontal timings - :MODE_V_ILLEGAL ; mode has illegal horizontal timings - :MODE_BAD_WIDTH ; requires an unsupported linepitch - :MODE_NO_MODE ; no mode with a maching name - :MODE_NO_INTERLACE ; interlaced mode not supported - :MODE_NO_DBLESCAN ; doublescan mode not supported - :MODE_NO_VSCAN ; multiscan mode not supported - :MODE_MEM ; insufficient video memory - :MODE_VIRTUAL_X ; mode width too large for specified virtual size - :MODE_VIRTUAL_Y ; mode height too large for specified virtual size - :MODE_MEM_VIRT ; insufficient video memory given virtual size - :MODE_NOCLOCK ; no fixed clock available - :MODE_CLOCK_HIGH ; clock required is too high - :MODE_CLOCK_LOW ; clock required is too low - :MODE_CLOCK_RANGE ; clock/mode isn't in a ClockRange - :MODE_BAD_HVALUE ; horizontal timing was out of range - :MODE_BAD_VVALUE ; vertical timing was out of range - :MODE_BAD_VSCAN ; VScan value out of range - :MODE_HSYNC_NARROW ; horizontal sync too narrow - :MODE_HSYNC_WIDE ; horizontal sync too wide - :MODE_HBLANK_NARROW ; horizontal blanking too narrow - :MODE_HBLANK_WIDE ; horizontal blanking too wide - :MODE_VSYNC_NARROW ; vertical sync too narrow - :MODE_VSYNC_WIDE ; vertical sync too wide - :MODE_VBLANK_NARROW ; vertical blanking too narrow - :MODE_VBLANK_WIDE ; vertical blanking too wide - :MODE_PANEL ; exceeds panel dimensions - :MODE_INTERLACE_WIDTH ; width too large for interlaced mode - :MODE_ONE_WIDTH ; only one width is supported - :MODE_ONE_HEIGHT ; only one height is supported - :MODE_ONE_SIZE ; only one resolution is supported - )) - -(defun decode-status-mode (status) - (declare (type int32 status)) - (svref +mode-status+ (+ status 2))) - -(defun xfree86-vidmode-validate-mode-line (dpy scr mode-info) - "Checked the validity of a mode-info argument. If the specified mode can be -used by the server (i.e. meets all the constraints placed upon a mode by the -combination of the server, card, and monitor) the function returns :mode_ok -otherwise it returns a keyword indicating the reason why the mode is -invalid." - (declare (type display dpy) - (type screen scr)) - (let* ((major (xfree86-vidmode-query-version dpy)) - (v (mode-info->v-card16 mode-info major))) - (declare (type card16 major) - (type simple-vector v)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +validate-mode-line+) - (card32 (screen-position scr dpy)) - ((sequence :format card16) v)) - (let ((status (integer-get 8))) - (declare (type int32 status)) - (when status (decode-status-mode status)))))) - -(defun xfree86-vidmode-get-gamma (display screen) - (declare (type display display) - (type screen screen)) - (with-buffer-request-and-reply - (display (vidmode-opcode display) nil :sizes (8 16 32)) - ((data +get-gamma+) - (card16 (screen-position screen display)) - (card16 0) - (card32 0) (card32 0) - (card32 0) (card32 0) - (card32 0) (card32 0)) - (values - (/ (the card32 (or (card32-get 8) 0)) 10000.0) - (/ (the card32 (or (card32-get 12) 0)) 10000.0) - (/ (the card32 (or (card32-get 16) 0)) 10000.0)))) - -(defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0)) - (declare (type display dpy) - (type screen scr) - (type (single-float 0.100f0 10.000f0) red green blue)) - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +set-gamma+) - (card16 (screen-position scr dpy)) - (card16 0) - (card32 (truncate (* red 10000))) - (card32 (truncate (* green 10000))) - (card32 (truncate (* blue 10000))) - (card32 0) - (card32 0) - (card32 0))) - -(defun xfree86-vidmode-get-gamma-ramp (dpy scr size) - (declare (type display dpy) - (type screen scr) - (type card16 size)) - (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-gamma-ramp+) - (card16 (screen-position scr dpy)) - (card16 size)) - (let ((rep-size (* (the card16 (or (card16-get 8) 0)) 2))) - (declare (type fixnum rep-size)) - (unless (zerop rep-size) - (let* ((off1 (+ 32 rep-size (* 2 (mod rep-size 2)))) - (off2 (+ off1 rep-size (* 2 (mod rep-size 2))))) - (declare (type fixnum off1 off2)) - (values - (sequence-get :format card16 :length (card16-get 8) - :index 32 :result-type 'list) - (sequence-get :format card16 :length (card16-get 8) - :index off1 :result-type 'list) - (sequence-get :format card16 :length (card16-get 8) - :index off2 :result-type 'list))))))) - -(defun xfree86-vidmode-set-gamma-ramp (dpy scr size &key red green blue) - (declare (type (or null simple-vector) red green blue) - (type card16 size) - (type display dpy) - (type screen scr)) - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +set-gamma-ramp+) - (card16 (screen-position scr dpy)) - (card16 size) - ((sequence :format card16) - (if (zerop (mod size 2)) - (concatenate 'vector red green blue) - (concatenate 'vector red '#(0) green '#(0) blue '#(0)))))) - -(defun xfree86-vidmode-get-gamma-ramp-size (dpy screen) - (declare (type display dpy) - (type screen screen)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-gamma-ramp-size+) - (card16 (screen-position screen dpy)) - (card16 0)) - (card16-get 8))) - -(defun xfree86-vidmode-lock-mode-switch (display screen lock-p) - "Allow or disallow mode switching whether the request to switch -modes comes from a call to the mode switching functions or from one -of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)." - (declare (type display display) - (type screen screen) - (type boolean lock-p)) - (with-buffer-request (display (vidmode-opcode display)) - (data +lock-mode-switch+) - (card16 (screen-position screen display)) - (card16 (if lock-p 1 0)))) - -(defun xfree86-vidmode-switch-to-mode (display screen mode-info) - "Switch directly to the specified mode. The specified mode must match -an existing mode. Matching is as specified in the description of the -xf86-vidmode-delete-mode-line function." - (declare (type display display) - (type screen screen)) - (multiple-value-bind (major minor) (xfree86-vidmode-query-version display) - (declare (type card16 major minor)) - ;; Note: There was a bug in the protocol implementation in versions - ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). - ;; Check the server's version, and accept the old format if appropriate. - (let ((bug-p (and (= major 0) (< minor 8))) - (privsize (mode-info-privsize mode-info))) - (declare (type boolean bug-p)) - (and bug-p (setf (mode-info-privsize mode-info) 0)) - (let ((v (mode-info->v-card16 mode-info major :encode-private bug-p))) - (declare (type simple-vector v)) - (and bug-p (setf (mode-info-privsize mode-info) privsize)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-to-mode+) - (card32 (screen-position screen display)) - ((sequence :format card16) v)))))) - -(defun xfree86-vidmode-switch-mode (display screen zoom) - "Change the video mode to next (or previous) video mode, depending -of zoom sign. If positive, switch to next mode, else switch to prev mode." - (declare (type display display) - (type screen screen) - (type card16 zoom)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-mode+) - (card16 (screen-position screen display)) - (card16 zoom))) - -(defun xfree86-vidmode-select-next-mode (display screen) - "Change the video mode to next video mode" - (declare (type display display) - (type screen screen)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-mode+) - (card16 (screen-position screen display)) - (card16 1))) - -(defun xfree86-vidmode-select-prev-mode (display screen) - "Change the video mode to previous video mode" - (declare (type display display) - (type screen screen)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-mode+) - (card16 (screen-position screen display)) - (card16 #xFFFF))) - -(defun xfree86-vidmode-get-monitor (dpy screen) - "Information known to the server about the monitor is returned. -Multiple value return: - hsync (list of hi, low, ...) - vsync (list of hi, low, ...) - vendor name - model name - -The hi and low values will be equal if a discreate value was given -in the XF86Config file." - (declare (type display dpy) - (type screen screen)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-monitor+) - (card16 (screen-position screen dpy)) - (card16 0)) - (let* ((vendor-name-length (card8-get 8)) - (model-name-length (card8-get 9)) - (pad (- 4 (mod vendor-name-length 4))) - (nhsync (card8-get 10)) - (nvsync (card8-get 11)) - (vindex (+ 32 (* 4 (+ nhsync nvsync)))) - (mindex (+ vindex vendor-name-length pad)) - (hsync (sequence-get :length nhsync :index 32 :result-type 'list)) - (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4)) - :result-type 'list))) - (declare (type card8 nhsync nvsync vendor-name-length model-name-length) - (type fixnum pad vindex mindex)) - (values - (loop for i of-type card32 in hsync - collect (/ (ldb (byte 16 0) i) 100.) - collect (/ (ldb (byte 32 16) i) 100.)) - (loop for i of-type card32 in vsync - collect (/ (ldb (byte 16 0) i) 100.) - collect (/ (ldb (byte 32 16) i) 100.)) - (string-get vendor-name-length vindex) - (string-get model-name-length mindex))))) - -(defun xfree86-vidmode-get-viewport (dpy screen) - "Query the location of the upper left corner of the viewport into -the virtual screen. The upper left coordinates will be returned as -a multiple value." - (declare (type display dpy) - (type screen screen)) - (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) - (declare (type card16 major minor)) - ;; Note: There was a bug in the protocol implementation in versions - ;; 0.x with x < 8 (no reply was sent, so the client would hang) - ;; Check the server's version, and don't wait for a reply with older - ;; versions. - (when (and (= major 0) (< minor 8)) - (format cl:*error-output* - "running an old version ~a ~a~%" - major minor) - (return-from xfree86-vidmode-get-viewport nil)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-viewport+) - (card16 (screen-position screen dpy)) - (card16 0)) - (values - (card32-get 8) - (card32-get 12))))) - -(defun xfree86-vidmode-set-viewport (dpy screen &key (x 0) (y 0)) - "Set upper left corner of the viewport into the virtual screen to the -x and y keyword parameters value (zero will be theire default value)." - (declare (type display dpy) - (type screen screen) - (type card32 x y)) - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +set-viewport+) - (card16 (screen-position screen dpy)) - (card16 0) - (card32 x) - (card32 y))) - -(defun xfree86-vidmode-get-dotclocks (dpy screen) - "Returns as a multiple value return the server dotclock informations: - flags - maxclocks - clock list" - (declare (type display dpy) - (type screen screen)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-dot-clocks+) - (card16 (screen-position screen dpy)) - (card16 0)) - (values - (card32-get 8) ; flags - (card32-get 16) ; max clocks - (sequence-get :length (card32-get 12) :format card32 - :index 32 :result-type 'list)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; ;;;; -;;;; private utility routines ;;;; -;;;; ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun mode-info->v-card16 - (mode-info major &key (encode-private t) (index 0) data) - (declare (type integer index) - (type card16 major) - (type boolean encode-private) - (type (or null simple-vector) data)) - (let ((dotclock (mode-info-dotclock mode-info)) - (hdisplay (mode-info-hdisplay mode-info)) - (hsyncstart (mode-info-hsyncstart mode-info)) - (hsyncend (mode-info-hsyncend mode-info)) - (htotal (mode-info-htotal mode-info)) - (hskew (mode-info-hskew mode-info)) - (vdisplay (mode-info-vdisplay mode-info)) - (vsyncstart (mode-info-vsyncstart mode-info)) - (vsyncend (mode-info-vsyncend mode-info)) - (vtotal (mode-info-vtotal mode-info)) - (flags (mode-info-flags mode-info)) - (privsize (mode-info-privsize mode-info)) - (private (mode-info-private mode-info))) - (declare (type card16 hdisplay hsyncstart hsyncend htotal hskew) - (type card16 vdisplay vsyncstart vsyncend vtotal) - (type card32 dotclock flags privsize) - (type (or null sequence) private)) - (let* ((size (+ (if (< major 2) 14 22) (* privsize 2))) - (v (or data (make-array size :initial-element 0)))) - (declare (type fixnum size) - (type simple-vector v)) - ;; store dotclock (card32) according clx bytes order. - (multiple-value-bind (w1 w2) (__card32->card16__ dotclock) - (setf (svref v index) w1 - (svref v (incf index)) w2)) - (setf (svref v (incf index)) hdisplay - (svref v (incf index)) hsyncstart - (svref v (incf index)) hsyncend - (svref v (incf index)) htotal) - (unless (< major 2) - (setf (svref v (incf index)) hskew)) - (setf (svref v (incf index)) vdisplay - (svref v (incf index)) vsyncstart - (svref v (incf index)) vsyncend - (svref v (incf index)) vtotal) - (unless (< major 2) - (incf index)) - ;; strore flags (card32) according clx bytes order. - (multiple-value-bind (w1 w2) (__card32->card16__ flags) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)) - ;; strore privsize (card32) according clx bytes order. - (multiple-value-bind (w1 w2) (__card32->card16__ privsize) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)) - ;; reserverd byte32 1 2 3 - (unless (< major 2) (incf index 6)) - ;; strore private info (sequence card32) according clx bytes order. - (when encode-private - (loop for i of-type int32 in private - do (multiple-value-bind (w1 w2) (__card32->card16__ i) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)))) - v))) - -(declaim (inline __card32->card16__)) -(defun __card32->card16__ (i) - (declare (type card32 i)) - #+clx-little-endian - (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) - #-clx-little-endian - (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index e907abdc5..48d409218 100755 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -316,58 +316,6 @@ #+UNICODE (load "ext:encodings;generate.lisp") -;;; -;;; * Compile the portable CLX library. -;;; - -#+WANTS-CLX -(let* ((*features* (cons :clx-ansi-common-lisp *features*)) - (+clx-src-files+ '("src:clx;package.lisp" - "src:clx;depdefs.lisp" - "src:clx;clx.lisp" - "src:clx;dependent.lisp" - "src:clx;macros.lisp" - "src:clx;bufmac.lisp" - "src:clx;buffer.lisp" - "src:clx;display.lisp" - "src:clx;gcontext.lisp" - "src:clx;input.lisp" - "src:clx;requests.lisp" - "src:clx;fonts.lisp" - "src:clx;graphics.lisp" - "src:clx;text.lisp" - "src:clx;attributes.lisp" - "src:clx;translate.lisp" - "src:clx;keysyms.lisp" - "src:clx;manager.lisp" - "src:clx;image.lisp" - "src:clx;resource.lisp" - "src:clx;shape.lisp" - "src:clx;big-requests.lisp" - "src:clx;xvidmode.lisp" - "src:clx;xrender.lisp" - "src:clx;glx.lisp" - "src:clx;gl.lisp" - "src:clx;dpms.lisp" - "src:clx;xtest.lisp" - "src:clx;screensaver.lisp" - "src:clx;xinerama.lisp" - "build:clx;module.lisp")) - #+:msvc - (c::*cc-flags* (concatenate 'string c::*cc-flags* " -Zm150"))) - (let ((filename "build:clx;module.lisp")) - (ensure-directories-exist filename) - (with-open-file (s filename :direction :output :if-exists :overwrite - :if-does-not-exist :create) - (print '(provide :clx) s))) - (unless (find-package "SB-BSD-SOCKETS") - (load "ext:sockets;package.lisp")) - (mapcar #'load +clx-src-files+) - (build-module "clx" +clx-src-files+ :dir "build:clx;" :prefix "CLX" - :builtin - #+(OR (NOT :WANTS-DLOPEN) :BUILTIN-CLX) t - #-(OR (NOT :WANTS-DLOPEN) :BUILTIN-CLX) nil)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; THE FINAL EXECUTABLE diff --git a/src/configure b/src/configure index f487d00bf..b2d9ce102 100755 --- a/src/configure +++ b/src/configure @@ -626,7 +626,6 @@ ECL_INIT_FORM ECL_EXTRA_LISP_FILES CHAR_CODE_LIMIT ECL_CHARACTER -CLX_INFO CC_IS_CXX ECL_CC POW_LIB @@ -780,7 +779,6 @@ enable_opcode8 with_cxx with_tcp with_serve_event -with_clx with_clos_streams with_cmuformat with_asdf @@ -1492,7 +1490,6 @@ Optional Packages: default=YES) --with-serve-event include serve-event module (yes|builtin|no, default=YES) - --with-clx include CLX library (yes|builtin|no, default=NO) --with-clos-streams user defined stream objects (yes|builtin|no, default=YES) --with-cmuformat use CMUCL's FORMAT routine (default=YES) @@ -2750,15 +2747,6 @@ fi -# Check whether --with-clx was given. -if test "${with_clx+set}" = set; then : - withval=$with_clx; -else - with_clx=no -fi - - - # Check whether --with-clos-streams was given. if test "${with_clos_streams+set}" = set; then : withval=$with_clos_streams; @@ -9518,32 +9506,6 @@ LSP_FEATURES="(cons :wants-cmp ${LSP_FEATURES})" fi - -if test "${with_clx}" = "builtin"; then - - -LSP_FEATURES="(cons :builtin-clx ${LSP_FEATURES})" - - - - -LSP_FEATURES="(cons :builtin-sockets ${LSP_FEATURES})" - - - with_clx=yes -fi -if test ${with_clx} = "yes"; then - tcp="yes" - - -LSP_FEATURES="(cons :wants-clx ${LSP_FEATURES})" - - - CLX_INFO="clx.${INFOEXT}" -else - CLX_INFO="" -fi - if test "${with_tcp}" = "builtin"; then diff --git a/src/configure.ac b/src/configure.ac index 1e141c702..73501dac5 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -131,11 +131,6 @@ AC_ARG_WITH(serve_event, [include serve-event module (yes|builtin|no, default=YES)]), [], [with_serve_event=${enable_shared}]) -AC_ARG_WITH(clx, - AS_HELP_STRING( [--with-clx], - [include CLX library (yes|builtin|no, default=NO)]), - [], [with_clx=no]) - AC_ARG_WITH(clos-streams, AS_HELP_STRING( [--with-clos-streams], [user defined stream objects (yes|builtin|no, default=YES)]), @@ -789,20 +784,6 @@ if test "${with_cmp}" = "yes"; then ECL_ADD_LISP_MODULE([cmp]) fi -AC_SUBST(CLX_INFO) -if test "${with_clx}" = "builtin"; then - ECL_ADD_BUILTIN_MODULE([clx]) - ECL_ADD_BUILTIN_MODULE([sockets]) - with_clx=yes -fi -if test ${with_clx} = "yes"; then - tcp="yes" - ECL_ADD_LISP_MODULE([clx]) - CLX_INFO="clx.${INFOEXT}" -else - CLX_INFO="" -fi - if test "${with_tcp}" = "builtin"; then ECL_ADD_BUILTIN_MODULE([sockets]) with_tcp=yes diff --git a/src/doc/Makefile.in b/src/doc/Makefile.in index 788512e60..ce9287d48 100644 --- a/src/doc/Makefile.in +++ b/src/doc/Makefile.in @@ -16,7 +16,7 @@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_INFO = @INSTALL_INFO@ mkinstalldirs = $(top_srcdir)/bdwgc/install-sh -d -INFO_FILES = ecl.$(INFOEXT) ecldev.$(INFOEXT) @CLX_INFO@ +INFO_FILES = ecl.$(INFOEXT) ecldev.$(INFOEXT) HTML_FILES = index.html license.html lgpl.html news.html benchmark.html \ install.html download.html cvs.html @@ -34,15 +34,11 @@ 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 $(mkinstalldirs) $(DESTDIR)$(infodir) @@ -100,16 +96,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 head cat head $(srcdir)/download.in.html $(srcdir)/end | $(FILTER) > $@ diff --git a/src/doc/help.lsp b/src/doc/help.lsp index 15dd0c609..c1f2f0753 100644 --- a/src/doc/help.lsp +++ b/src/doc/help.lsp @@ -629,7 +629,7 @@ libraries or custom C code. However, if the argument is a symbol, it is interpreted as the name of a lisp library of FASL code. You should use symbols to call in optional parts of the -interpreter, such as the compiler 'CMP or the 'CLX library (not yet available) +interpreter, such as the compiler 'CMP (not yet available) For example: (compile-file \"my-code.lsp\" :system-p) diff --git a/src/doc/new-doc/introduction/copyrights.txi b/src/doc/new-doc/introduction/copyrights.txi index a8096c745..979b5ca86 100644 --- a/src/doc/new-doc/introduction/copyrights.txi +++ b/src/doc/new-doc/introduction/copyrights.txi @@ -39,7 +39,6 @@ src/lsp/format.lsp ; CMUCL's format 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. diff --git a/src/h/config.h.in b/src/h/config.h.in index 5d127354b..c4219a64f 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -267,9 +267,6 @@ typedef unsigned char ecl_base_char; * FEATURES LINKED IN: */ -/* CLX */ -#undef CLX - /* Define this if you want a runtime version only without compiler */ #undef RUNTIME /* Profile tool */ diff --git a/src/util/ecl.spec b/src/util/ecl.spec index 89a663752..716d73c06 100644 --- a/src/util/ecl.spec +++ b/src/util/ecl.spec @@ -65,7 +65,6 @@ fi --with-clos-stream \ --with-tcp \ --with-cmuformat \ - --with-clx # --enable-local-boehm \ # broken # --enable-threads # non-supported still. %{__make} @@ -139,7 +138,7 @@ gen_filelist $RPM_BUILD_ROOT %{_filelist} # add info files to info dir in %post %post -for _n in ecl ecldev clx; do +for _n in ecl ecldev; do _d=%{_infodir} _f=$_d/$_n.info.gz if [ -f $_f ]; then @@ -150,7 +149,7 @@ done # remove info files from info dir in %postun %postun -for _n in ecl ecldev clx; do +for _n in ecl ecldev; do _d=%{_infodir} _f=$_d/$_n.info.gz if [ -f $_f ]; then diff --git a/src/util/search b/src/util/search index 3e1d8d7bb..91855d343 100644 --- a/src/util/search +++ b/src/util/search @@ -1,5 +1,5 @@ -function se () { (cd $HOME/src/ecl/src/; grep "$*" c/*.c c/*.d h/* {lsp,clos,cmp,clx}/*); } -function sl () { (cd $HOME/src/ecl/src/; grep -l "$*" c/*.c c/*.d h/* {lsp,clos,cmp,clx}/*); } -function sie () { (cd $HOME/src/ecl/src/; grep -i "$*" c/*.c c/*.d h/* {lsp,clos,cmp,clx}/*); } -function sil () { (cd $HOME/src/ecl/src/; grep -il "$*" c/*.c c/*.d h/* {lsp,clos,cmp,clx}/*); } +function se () { (cd $HOME/src/ecl/src/; grep "$*" c/*.c c/*.d h/* {lsp,clos,cmp}/*); } +function sl () { (cd $HOME/src/ecl/src/; grep -l "$*" c/*.c c/*.d h/* {lsp,clos,cmp}/*); } +function sie () { (cd $HOME/src/ecl/src/; grep -i "$*" c/*.c c/*.d h/* {lsp,clos,cmp}/*); } +function sil () { (cd $HOME/src/ecl/src/; grep -il "$*" c/*.c c/*.d h/* {lsp,clos,cmp}/*); } function cvstat () { cvs status `find src -type f -and -not \( -name Root -or -name Repository -or -name Entries \) ` 2>/dev/null | grep "Status: $*"; } From 08cc2350b9bec544453c3f15b4841122afc84b9f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Sep 2016 14:52:06 +0200 Subject: [PATCH 87/92] changelog: update --- CHANGELOG | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG b/CHANGELOG index f8f21fd27..4cda962b0 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -44,6 +44,10 @@ arity dependent on platform) is also possible. whenever termination should be forced or not. ** Enhancements +- 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. From 7a8f1b4a7a28b68e1232edbb7483d6d93d67aa82 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Sep 2016 16:17:35 +0200 Subject: [PATCH 88/92] contribs: update asdf to version 3.1.7 Fixes #243. --- CHANGELOG | 2 + contrib/asdf/README.md | 237 +++++-- contrib/asdf/asdf.lisp | 890 ++++++++++++------------ contrib/asdf/asdf.texinfo | 1390 ++++++++++++++++++++++++------------- 4 files changed, 1486 insertions(+), 1033 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 4cda962b0..de07e4747 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -44,6 +44,8 @@ arity dependent on platform) is also possible. 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). diff --git a/contrib/asdf/README.md b/contrib/asdf/README.md index a2fe26930..ba4665125 100644 --- a/contrib/asdf/README.md +++ b/contrib/asdf/README.md @@ -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: + + +The one and only official source control repository is at: + + +The one and only official bug tracker is at: + + + +How to use ASDF? +---------------- To use ASDF, read our manual: + - 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 + * [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. diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 2ba1bc5c5..687e6ec55 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ -;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- -;;; This is ASDF 3.1.5.4: Another System Definition Facility. +;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- +;;; This is ASDF 3.1.7: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -46,43 +46,6 @@ ;;; we can't use defsystem to compile it. Hence, all in one file. #+xcvb (module ()) - -(in-package :cl-user) - -#+cmu -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf ext:*gc-verbose* nil)) - -;;; pre 1.3.0 ABCL versions do not support the bundle-op on Mac OS X -#+abcl -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (and (member :darwin *features*) - (second (third (sys::arglist 'directory)))) - (push :abcl-bundle-op-supported *features*))) - -;; Punt on hard package upgrade: from ASDF1 always, and even from ASDF2 on most implementations. -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (member :asdf3 *features*) - (let* ((existing-version - (when (find-package :asdf) - (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) - (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf)))) - (etypecase ver - (string ver) - (cons (format nil "~{~D~^.~}" ver)) - (null "1.0")))))) - (first-dot (when existing-version (position #\. existing-version))) - (second-dot (when first-dot (position #\. existing-version :start (1+ first-dot)))) - (existing-major-minor (subseq existing-version 0 second-dot)) - (existing-version-number (and existing-version (read-from-string existing-major-minor))) - (away (format nil "~A-~A" :asdf existing-version))) - (when (and existing-version - (< existing-version-number - #+(or allegro clisp lispworks sbcl) 2.0 - #-(or allegro clisp lispworks sbcl) 2.27)) - (rename-package :asdf away) - (when *load-verbose* - (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. ;; @@ -822,19 +785,6 @@ UNINTERN -- Remove symbols here from PACKAGE." #+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) (eval-when (:compile-toplevel :load-toplevel :execute) ,ensure-form)))) - -;;;; Final tricks to keep various implementations happy. -;; We want most such tricks in common-lisp.lisp, -;; but these need to be done before the define-package form there, -;; that we nevertheless want to be the very first form. -(eval-when (:load-toplevel :compile-toplevel :execute) - #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF. - (setf excl::*autoload-package-name-alist* - (remove "asdf" excl::*autoload-package-name-alist* - :test 'equalp :key 'car))) - -;; Compatibility with whoever calls asdf/package -(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package)) ;;;; ------------------------------------------------------------------------- ;;;; Handle compatibility with multiple implementations. ;;; This file is for papering over the deficiencies and peculiarities @@ -844,10 +794,9 @@ UNINTERN -- Remove symbols here from PACKAGE." ;;; from this package only common-lisp symbols are exported. (uiop/package:define-package :uiop/common-lisp - (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl) + (:nicknames :uoip/cl) (:use :uiop/package) (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) - (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:shadow #:user-homedir-pathname) #+cormanlisp @@ -856,10 +805,10 @@ UNINTERN -- Remove symbols here from PACKAGE." #:make-broadcast-stream #:file-namestring) #+genera (:shadowing-import-from :scl #:boolean) #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) - #+mcl (:shadow #:user-homedir-pathname)) + #+(or mcl cmucl) (:shadow #:user-homedir-pathname)) (in-package :uiop/common-lisp) -#-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) +#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. @@ -867,17 +816,23 @@ UNINTERN -- Remove symbols here from PACKAGE." ;;;; Early meta-level tweaks -#+(or abcl allegro clasp clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl) +#+(or allegro clasp clisp cmucl ecl mkcl mkcl sbcl) (eval-when (:load-toplevel :compile-toplevel :execute) - ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode - ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (when (and #+allegro (member :ics *features*) - #+(or clasp clisp cmu ecl mkcl) (member :unicode *features*) + #+(or clasp clisp cmucl ecl mkcl) (member :unicode *features*) #+sbcl (member :sb-unicode *features*)) + ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode + ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (pushnew :asdf-unicode *features*))) #+allegro (eval-when (:load-toplevel :compile-toplevel :execute) + ;; We need to disable autoloading BEFORE any mention of package ASDF. + ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file + ;; or any previous file. + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) (defparameter *acl-warn-save* (when (boundp 'excl:*warn-on-nested-reader-conditionals*) excl:*warn-on-nested-reader-conditionals*)) @@ -901,7 +856,13 @@ UNINTERN -- Remove symbols here from PACKAGE." (wait-on-semaphore (external-process-completed proc)))) (values (external-process-%exit-code proc) (external-process-%status proc)))))) -#+clozure (in-package :uiop/common-lisp) +#+clozure (in-package :uiop/common-lisp) ;; back in this package. + +#+cmucl +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf ext:*gc-verbose* nil) + (defun user-homedir-pathname () + (first (ext:search-list (cl:user-homedir-pathname))))) #+cormanlisp (eval-when (:load-toplevel :compile-toplevel :execute) @@ -1035,8 +996,6 @@ Return a string made of the parts not omitted or emitted by FROB." ;;;; General Purpose Utilities for ASDF (uiop/package:define-package :uiop/utility - (:nicknames :asdf/utility) - (:recycle :uiop/utility :asdf/utility :asdf) (:use :uiop/common-lisp :uiop/package) ;; import and reexport a few things defined in :uiop/common-lisp (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings @@ -1618,11 +1577,11 @@ with later being determined by a lexicographical comparison of minor numbers." #+allegro 'excl::format-control #+clisp 'system::$format-control #+clozure 'ccl::format-control - #+(or cmu scl) 'conditions::format-control + #+(or cmucl scl) 'conditions::format-control #+(or clasp ecl mkcl) 'si::format-control #+(or gcl lispworks) 'conditions::format-string #+sbcl 'sb-kernel:format-control - #-(or abcl allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil "Name of the slot for FORMAT-CONTROL in simple-condition") (defun match-condition-p (x condition) @@ -1637,7 +1596,7 @@ or a string describing the format-control of a simple-condition." (function (funcall x condition)) (string (and (typep condition 'simple-condition) ;; On SBCL, it's always set and the check triggers a warning - #+(or allegro clozure cmu lispworks scl) + #+(or allegro clozure cmucl lispworks scl) (slot-boundp condition +simple-condition-format-control-slot+) (ignore-errors (equal (simple-condition-format-control condition) x)))))) @@ -1659,8 +1618,6 @@ or a string describing the format-control of a simple-condition." ;;;; Access to the Operating System (uiop/package:define-package :uiop/os - (:nicknames :asdf/os) - (:recycle :uiop/os :asdf/os :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility) (:export #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features @@ -1744,7 +1701,7 @@ use getenvp to return NIL in such a case." #+(or abcl clasp clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) - #+cmu (unix:unix-getenv x) + #+cmucl (unix:unix-getenv x) #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) #+cormanlisp (let* ((buffer (ct:malloc 1)) @@ -1765,7 +1722,7 @@ use getenvp to return NIL in such a case." (ccl:%get-cstring value)))) #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) (defsetf getenv (x) (val) @@ -1774,12 +1731,12 @@ use getenvp to return NIL in such a case." #+allegro `(setf (sys:getenv ,x) ,val) #+clisp `(system::setenv ,x ,val) #+clozure `(ccl:setenv ,x ,val) - #+cmu `(unix:unix-setenv ,x ,val 1) + #+cmucl `(unix:unix-setenv ,x ,val 1) #+ecl `(ext:setenv ,x ,val) #+lispworks `(hcl:setenv ,x ,val) #+mkcl `(mkcl:setenv ,x ,val) #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) - #-(or allegro clisp clozure cmu ecl lispworks mkcl sbcl) + #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl) '(error "~S ~S is not supported on your implementation" 'setf 'getenv)) (defun getenvp (x) @@ -1871,7 +1828,7 @@ then returning the non-empty string value of the variable" ccl::*openmcl-major-version* ccl::*openmcl-minor-version* (logand (ccl-fasl-version) #xFF)) - #+cmu (substitute #\- #\/ s) + #+cmucl (substitute #\- #\/ s) #+scl (format nil "~A~A" s ;; ANSI upper case vs lower case. (ecase ext:*case-mode* (:upper "") (:lower "l"))) @@ -1905,7 +1862,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie (defun hostname () "return the hostname of the current host" ;; Note: untested on RMCL - #+(or abcl clasp clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? #+allegro (symbol-call :excl.osi :gethostname) #+clisp (first (split-string (machine-instance) :separator " ")) @@ -1915,7 +1872,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie ;;; Current directory (with-upgradability () - #+cmu + #+cmucl (defun parse-unix-namestring* (unix-namestring) "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" (multiple-value-bind (host device directory name type version) @@ -1929,7 +1886,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+allegro (excl::current-directory) #+clisp (ext:default-directory) #+clozure (ccl:current-directory) - #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring + #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring (strcat (nth-value 1 (unix:unix-current-directory)) "/")) #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+(or clasp ecl) (ext:getcwd) @@ -1947,7 +1904,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+allegro (excl:chdir x) #+clisp (ext:cd x) #+clozure (setf (ccl:current-directory) x) - #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) + #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) (error "Could not set current directory to ~A" x)) #+(or clasp ecl) (ext:chdir x) @@ -1955,7 +1912,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) (error "chdir not supported on your implementation")))) @@ -2048,8 +2005,7 @@ the number having BYTES octets (defaulting to 4)." ;; which all is necessary prior to any access the filesystem or environment. (uiop/package:define-package :uiop/pathname - (:nicknames :asdf/pathname) - (:recycle :uiop/pathname :asdf/pathname :asdf) + (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) (:export ;; Making and merging pathnames, portably @@ -2092,7 +2048,7 @@ the number having BYTES octets (defaulting to 4)." implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format that is a list and not a string." (cond - #-(or cmu sbcl scl) ;; these implementations already normalize directory components. + #-(or cmucl sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory)) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) @@ -2135,22 +2091,17 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ;; See CLHS make-pathname and 19.2.2.2.3. ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* - #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific + #+(or abcl allegro clozure cmucl genera lispworks sbcl scl) :unspecific #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") - (defun make-pathname* (&rest keys &key (directory nil) - host (device () #+allegro devicep) name type version defaults + (defun make-pathname* (&rest keys &key directory host device name type version defaults #+scl &allow-other-keys) "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and tries hard to make a pathname that will actually behave as documented, - despite the peculiarities of each implementation" - ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults. - (declare (ignorable host device directory name type version defaults)) - (apply 'make-pathname - (append - #+allegro (when (and devicep (null device)) `(:device :unspecific)) - keys))) + despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME." + (declare (ignore host device directory name type version defaults)) + (apply 'make-pathname keys)) (defun make-pathname-component-logical (x) "Make a pathname component suitable for use in a logical-pathname" @@ -2163,7 +2114,7 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" (defun make-pathname-logical (pathname host) "Take a PATHNAME's directory, name, type and version components, and make a new pathname with corresponding components and specified logical HOST" - (make-pathname* + (make-pathname :host host :directory (make-pathname-component-logical (pathname-directory pathname)) :name (make-pathname-component-logical (pathname-name pathname)) @@ -2206,10 +2157,10 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." (pathname-device defaults) (merge-pathname-directory-components directory (pathname-directory defaults)) (unspecific-handler defaults)))) - (make-pathname* :host host :device device :directory directory - :name (funcall unspecific-handler name) - :type (funcall unspecific-handler type) - :version (funcall unspecific-handler version)))))) + (make-pathname :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) (defun logical-pathname-p (x) "is X a logical-pathname?" @@ -2234,13 +2185,13 @@ when merging, making or parsing pathnames" ;; But CMUCL decides to die on NIL. ;; MCL has issues with make-pathname, nil and defaulting (declare (ignorable defaults)) - #.`(make-pathname* :directory nil :name nil :type nil :version nil - :device (or #+(and mkcl unix) :unspecific) - :host (or #+cmu lisp::*unix-host* #+(and mkcl unix) "localhost") - #+scl ,@'(:scheme nil :scheme-specific-part nil - :username nil :password nil :parameters nil :query nil :fragment nil) - ;; the default shouldn't matter, but we really want something physical - #-mcl ,@'(:defaults defaults))) + #.`(make-pathname :directory nil :name nil :type nil :version nil + :device (or #+(and mkcl unix) :unspecific) + :host (or #+cmucl lisp::*unix-host* #+(and mkcl unix) "localhost") + #+scl ,@'(:scheme nil :scheme-specific-part nil + :username nil :password nil :parameters nil :query nil :fragment nil) + ;; the default shouldn't matter, but we really want something physical + #-mcl ,@'(:defaults defaults))) (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) "A pathname that is as neutral as possible for use as defaults @@ -2318,9 +2269,9 @@ actually-existing file. Returns the (parsed) PATHNAME when true" (when pathname - (let* ((pathname (pathname pathname)) - (name (pathname-name pathname))) - (when (not (member name '(nil :unspecific "") :test 'equal)) + (let ((pathname (pathname pathname))) + (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal) + (member (pathname-type pathname) '(nil :unspecific "") :test 'equal)) pathname))))) @@ -2337,10 +2288,10 @@ and NIL NAME, TYPE and VERSION components" i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is Unix pathname /foo/bar/baz/file.type then return /foo/bar/" (when pathname - (make-pathname* :name nil :type nil :version nil - :directory (merge-pathname-directory-components - '(:relative :back) (pathname-directory pathname)) - :defaults pathname))) + (make-pathname :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) (defun directory-pathname-p (pathname) "Does PATHNAME represent a directory? @@ -2375,11 +2326,11 @@ actually-existing directory." ((directory-pathname-p pathspec) pathspec) (t - (make-pathname* :directory (append (or (normalize-pathname-directory-component - (pathname-directory pathspec)) - (list :relative)) - (list (file-namestring pathspec))) - :name nil :type nil :version nil :defaults pathspec))))) + (make-pathname :directory (append (or (normalize-pathname-directory-component + (pathname-directory pathspec)) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil :defaults pathspec))))) ;;; Parsing filenames @@ -2512,7 +2463,7 @@ to throw an error if the pathname is absolute" (t (split-name-type filename))) (apply 'ensure-pathname - (make-pathname* + (make-pathname :directory (unless file-only (cons relative path)) :name name :type type :defaults (or #-mcl defaults *nil-pathname*)) @@ -2581,19 +2532,19 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (defun pathname-root (pathname) "return the root directory for the host and device of given PATHNAME" - (make-pathname* :directory '(:absolute) - :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + (make-pathname :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun pathname-host-pathname (pathname) "return a pathname with the same host as given PATHNAME, and all other fields NIL" - (make-pathname* :directory nil - :name nil :type nil :version nil :device nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + (make-pathname :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) "Given a pathname designator PATH, return an absolute pathname as specified by PATH @@ -2660,12 +2611,12 @@ given DEFAULTS-PATHNAME as a base pathname." :version (or #-(or allegro abcl xcl) *wild*)) "A pathname object with wildcards for matching any file in a given directory") (defparameter *wild-directory* - (make-pathname* :directory `(:relative ,*wild-directory-component*) - :name nil :type nil :version nil) + (make-pathname :directory `(:relative ,*wild-directory-component*) + :name nil :type nil :version nil) "A pathname object with wildcards for matching any subdirectory") (defparameter *wild-inferiors* - (make-pathname* :directory `(:relative ,*wild-inferiors-component*) - :name nil :type nil :version nil) + (make-pathname :directory `(:relative ,*wild-inferiors-component*) + :name nil :type nil :version nil) "A pathname object with wildcards for matching any recursive subdirectory") (defparameter *wild-path* (merge-pathnames* *wild-file* *wild-inferiors*) @@ -2692,13 +2643,13 @@ given DEFAULTS-PATHNAME as a base pathname." (defun relativize-pathname-directory (pathspec) "Given a PATHNAME, return a relative pathname with otherwise the same components" (let ((p (pathname pathspec))) - (make-pathname* + (make-pathname :directory (relativize-directory-component (pathname-directory p)) :defaults p))) (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) "Given a PATHNAME, return the character used to delimit directory names on this host and device." - (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) + (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) #-scl @@ -2722,8 +2673,7 @@ added to its DIRECTORY component. This is useful for output translations." (multiple-value-bind (relative path filename) (split-unix-namestring-directory-components root-string :ensure-directory t) (declare (ignore relative filename)) - (let ((new-base - (make-pathname* :defaults root :directory `(:absolute ,@path)))) + (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) #+scl @@ -2745,8 +2695,8 @@ added to its DIRECTORY component. This is useful for output translations." (when (specificp scheme) (setf prefix (strcat scheme prefix))) (assert (and directory (eq (first directory) :absolute))) - (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) pathname))) (defun* (translate-pathname*) (path absolute-source destination &optional root source) @@ -2785,8 +2735,6 @@ you need to still be able to use compile-op on that lisp file.")) ;;;; Portability layer around Common Lisp filesystem access (uiop/package:define-package :uiop/filesystem - (:nicknames :asdf/filesystem) - (:recycle :uiop/filesystem :asdf/pathname :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) (:export ;; Native namestrings @@ -2817,9 +2765,9 @@ you need to still be able to use compile-op on that lisp file.")) (when x (let ((p (pathname x))) #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 - #+(or cmu scl) (ext:unix-namestring p nil) + #+(or cmucl scl) (ext:unix-namestring p nil) #+sbcl (sb-ext:native-namestring p) - #-(or clozure cmu sbcl scl) + #-(or clozure cmucl sbcl scl) (os-cond ((os-unix-p) (unix-namestring p)) (t (namestring p)))))) @@ -2832,8 +2780,10 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" (when string (with-pathname-defaults () #+clozure (ccl:native-to-pathname string) + #+cmucl (uiop/os::parse-unix-namestring* string) #+sbcl (sb-ext:parse-native-namestring string) - #-(or clozure sbcl) + #+scl (lisp::parse-unix-namestring string) + #-(or clozure cmucl sbcl scl) (os-cond ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory)) (t (parse-namestring string)))))) @@ -2918,10 +2868,10 @@ or the original (parsed) pathname if it is false (the default)." (if truename (probe-file p) (and - #+(or cmu scl) (unix:unix-stat (ext:unix-namestring p)) + #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p)) #+(and lispworks unix) (system:get-file-stat p) #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p)) - #-(or cmu (and lispworks unix) sbcl scl) (file-write-date p) + #-(or cmucl (and lispworks unix) sbcl scl) (file-write-date p) p)))))) (defun directory-exists-p (x) @@ -2948,7 +2898,7 @@ Try to override the defaults to not resolving symlinks, if implementation allows (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) - #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+(or cmucl scl) '(:follow-links nil :truenamep nil) #+lispworks '(:link-transparency nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) '(:resolve-symlinks nil)))))) @@ -3014,9 +2964,9 @@ The behavior in presence of symlinks is not portable. Use IOlib to handle such s (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks sbcl scl xcl) + #-(or abcl allegro cmucl lispworks sbcl scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*" directory)) (dirs #-(or abcl cormanlisp genera xcl) @@ -3025,17 +2975,17 @@ The behavior in presence of symlinks is not portable. Use IOlib to handle such s #+mcl '(:directories t)))) #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) - #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil))) + #+(or abcl allegro cmucl genera lispworks sbcl scl xcl) (dirs (loop :for x :in dirs :for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) - #+(or cmu sbcl scl) (directory-pathname-p x) + #+(or cmucl sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) :when d :collect #+(or abcl allegro xcl) d #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks sbcl scl) x))) + #+(or cmucl lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) @@ -3080,13 +3030,13 @@ The behavior in presence of symlinks is not portable. Use IOlib to handle such s (loop :while up-components :do (if-let (parent (ignore-errors - (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components)) - :name nil :type nil :version nil :defaults p)))) + (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components)) + :name nil :type nil :version nil :defaults p)))) (if-let (simplified (ignore-errors (merge-pathnames* - (make-pathname* :directory `(:relative ,@down-components) - :defaults p) + (make-pathname :directory `(:relative ,@down-components) + :defaults p) (ensure-directory-pathname parent)))) (return simplified))) (push (pop up-components) down-components) @@ -3327,15 +3277,19 @@ NILs." (defun lisp-implementation-directory (&key truename) "Where are the system files of the current installation of the CL implementation?" (declare (ignorable truename)) - #+(or clasp clozure ecl gcl mkcl sbcl) (let ((dir - (ignore-errors - #+clozure #p"ccl:" - #+(or clasp ecl mkcl) #p"SYS:" - #+gcl system::*system-directory* - #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) - (funcall it) - (getenv-pathname "SBCL_HOME" :ensure-directory t))))) + #+abcl extensions:*lisp-home* + #+(or allegro clasp ecl mkcl) #p"SYS:" + ;;#+clisp custom:*lib-directory* ; causes failure in asdf-pathname-test(!) + #+clozure #p"ccl:" + #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:"))) + #+gcl system::*system-directory* + #+lispworks lispworks:*lispworks-directory* + #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) + (funcall it) + (getenv-pathname "SBCL_HOME" :ensure-directory t)) + #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/"))) + #+xcl ext:*xcl-home*)) (if (and dir truename) (truename* dir) dir))) @@ -3382,10 +3336,10 @@ in an atomic way if the implementation allows." #+allegro (excl:delete-directory directory-pathname) #+clisp (ext:delete-directory directory-pathname) #+clozure (ccl::delete-empty-directory directory-pathname) - #+(or cmu scl) (multiple-value-bind (ok errno) + #+(or cmucl scl) (multiple-value-bind (ok errno) (unix:unix-rmdir (native-namestring directory-pathname)) (unless ok - #+cmu (error "Error number ~A when trying to delete directory ~A" + #+cmucl (error "Error number ~A when trying to delete directory ~A" errno directory-pathname) #+scl (error "~@" directory-pathname (unix:get-unix-error-msg errno)))) @@ -3398,7 +3352,7 @@ in an atomic way if the implementation allows." `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) @@ -3432,7 +3386,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (error "~S was asked to delete ~S but the directory does not exist" 'delete-directory-tree directory-pathname)) (:ignore nil))) - #-(or allegro cmu clozure genera sbcl scl) + #-(or allegro cmucl clozure genera sbcl scl) ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, ;; except on implementations where we can prevent DIRECTORY from following symlinks; ;; instead spawn a standard external program to do the dirty work. @@ -3459,8 +3413,6 @@ If you're suicidal or extremely confident, just use :VALIDATE T." ;;;; Utilities related to streams (uiop/package:define-package :uiop/stream - (:nicknames :asdf/stream) - (:recycle :uiop/stream :asdf/stream :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) (:export #:*default-stream-element-type* @@ -3491,7 +3443,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (with-upgradability () (defvar *default-stream-element-type* - (or #+(or abcl cmu cormanlisp scl xcl) 'character + (or #+(or abcl cmucl cormanlisp scl xcl) 'character #+lispworks 'lw:simple-char :default) "default element-type for open (depends on the current CL implementation)") @@ -3502,7 +3454,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (defun setup-stdin () (setf *stdin* #.(or #+clozure 'ccl::*stdin* - #+(or cmu scl) 'system:*stdin* + #+(or cmucl scl) 'system:*stdin* #+(or clasp ecl) 'ext::+process-standard-input+ #+sbcl 'sb-sys:*stdin* '*standard-input*))) @@ -3513,7 +3465,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (defun setup-stdout () (setf *stdout* #.(or #+clozure 'ccl::*stdout* - #+(or cmu scl) 'system:*stdout* + #+(or cmucl scl) 'system:*stdout* #+(or clasp ecl) 'ext::+process-standard-output+ #+sbcl 'sb-sys:*stdout* '*standard-output*))) @@ -3525,7 +3477,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (setf *stderr* #.(or #+allegro 'excl::*stderr* #+clozure 'ccl::*stderr* - #+(or cmu scl) 'system:*stderr* + #+(or cmucl scl) 'system:*stderr* #+(or clasp ecl) 'ext::+process-error-output+ #+sbcl 'sb-sys:*stderr* '*error-output*))) @@ -3810,7 +3762,7 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." (when eof (return))) (loop :with buffer-size = (or buffer-size 8192) - :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) + :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) :for end = (read-sequence buffer input) :until (zerop end) :do (write-sequence buffer output :end end) @@ -4023,7 +3975,7 @@ ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*). If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), -and stream with be closed after the THUNK exits (either normally or abnormally). +and stream will be closed after the THUNK exits (either normally or abnormally). If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument. Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. @@ -4033,16 +3985,17 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e (check-type direction (member :output :io)) (assert (or want-stream-p want-pathname-p)) (loop - :with prefix = (native-namestring - (ensure-absolute-pathname - (or prefix "tmp") - (or (ensure-pathname directory :namestring :native :ensure-directory t) - #'temporary-directory))) - :with results = () + :with prefix-pn = (ensure-absolute-pathname + (or prefix "tmp") + (or (ensure-pathname directory :namestring :native :ensure-directory t) + #'temporary-directory)) + :with prefix-nns = (native-namestring prefix-pn) + :with results = (progn (ensure-directories-exist prefix-pn) + ()) :for counter :from (random (expt 36 #-gcl 8 #+gcl 5)) :for pathname = (parse-native-namestring (format nil "~A~36R~@[~A~]~@[.~A~]" - prefix counter suffix (unless (eq type :unspecific) type))) + prefix-nns counter suffix (unless (eq type :unspecific) type))) :for okp = nil :do ;; TODO: on Unix, do something about umask ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL @@ -4051,6 +4004,7 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e ;; Can we at least design some hook? (unwind-protect (progn + (ensure-directories-exist pathname) (with-open-file (stream pathname :direction direction :element-type element-type @@ -4134,9 +4088,9 @@ Further KEYS can be passed to MAKE-PATHNAME." A new empty file with said temporary pathname is created, to ensure there is no clash with any concurrent process attempting the same thing." (let* ((px (ensure-pathname x)) - (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))) - (get-temporary-file - :directory (pathname-directory-pathname px) :prefix prefix :type (pathname-type px)))) + (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp")) + (directory (translate-logical-pathname (pathname-directory-pathname px)))) + (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)))) (defun call-with-staging-pathname (pathname fun) "Calls FUN with a staging pathname, and atomically @@ -4158,8 +4112,6 @@ For the latter case, we ought pick a random suffix and atomically open it." ;;;; Starting, Stopping, Dumping a Lisp image (uiop/package:define-package :uiop/image - (:nicknames :asdf/image) - (:recycle :uiop/image :asdf/image :xcvb-driver) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) (:export #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* @@ -4225,7 +4177,7 @@ This is designed to abstract away the implementation specific quit forms." #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) - #+(or cmu scl) (unix:unix-exit code) + #+(or cmucl scl) (unix:unix-exit code) #+gcl (system:quit code) #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) @@ -4236,7 +4188,7 @@ This is designed to abstract away the implementation specific quit forms." (cond (exit `(,exit :code code :abort (not finish-output))) (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) - #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (defun die (code format &rest arguments) @@ -4279,7 +4231,7 @@ This is designed to abstract away the implementation specific quit forms." #+clozure (ccl:print-call-history :count count :start-frame-number 1) #+mcl (ccl:print-call-history :detailed-p nil) (finish-output stream)) - #+(or cmu scl) + #+(or cmucl scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace (or count most-positive-fixnum) stream)) @@ -4298,9 +4250,7 @@ This is designed to abstract away the implementation specific quit forms." (dbg:*debug-print-length* *print-length*)) (dbg:bug-backtrace nil)) #+sbcl - (sb-debug:backtrace - #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum)) - stream) + (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum)) #+xcl (loop :for i :from 0 :below (or count most-positive-fixnum) :for frame :in (extensions:backtrace-as-list) :do @@ -4385,14 +4335,14 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die" #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+clisp (coerce (ext:argv) 'list) #+clozure ccl:*command-line-argument-list* - #+(or cmu scl) extensions:*command-line-strings* + #+(or cmucl scl) extensions:*command-line-strings* #+gcl si:*command-args* #+(or genera mcl) nil #+lispworks sys:*line-arguments-list* #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* - #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "raw-command-line-arguments not implemented yet")) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) @@ -4421,7 +4371,7 @@ Otherwise, return NIL." (cond ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! ;; NB: not currently available on ABCL, Corman, Genera, MCL - (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl) + (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl) (first (raw-command-line-arguments)) #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) (t ;; argv[0] is the name of the interpreter. @@ -4511,7 +4461,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (setf *image-dump-hook* dump-hook) (call-image-dump-hook) (setf *image-restored-p* nil) - #-(or clisp clozure cmu lispworks sbcl scl) + #-(or clisp clozure cmucl lispworks sbcl scl) (when executable (error "Dumping an executable is not supported on this implementation! Aborting.")) #+allegro @@ -4539,13 +4489,13 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) (dump path)) (dump t))) - #+(or cmu scl) + #+(or cmucl scl) (progn (ext:gc :full t) (setf ext:*batch-mode* nil) (setf ext::*gc-run-time* 0) (apply 'ext:save-lisp filename - #+cmu :executable #+cmu t + #+cmucl :executable #+cmucl t (when executable '(:init-function restore-image :process-command-line nil)))) #+gcl (progn @@ -4568,7 +4518,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. ;; the default is :console - only works with SBCL 1.1.15 or later. (when application-type (list :application-type application-type))))) - #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) + #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" 'dump-image filename (nth-value 1 (implementation-type)))) @@ -4632,8 +4582,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ;;;; run-program initially from xcvb-driver. (uiop/package:define-package :uiop/run-program - (:nicknames :asdf/run-program) - (:recycle :uiop/run-program :asdf/run-program :xcvb-driver) + (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv. (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) (:export @@ -5053,73 +5002,62 @@ INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer, to be normalized by %NORMALIZE-IO-SPECIFIER. It returns a process-info plist with possible keys: PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM." - ;; NB: these implementations have unix vs windows set at compile-time. + ;; NB: these implementations have Unix vs Windows set at compile-time. (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists)) (assert (not (and wait (member :stream (list input output error-output))))) #-(or allegro clasp clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl) (progn command keys directory (error "run-program not available")) - #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl) + #+(or allegro clasp clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl) (let* ((%command (%normalize-command command)) (%input (%normalize-io-specifier input :input)) (%output (%normalize-io-specifier output :output)) (%error-output (%normalize-io-specifier error-output :error-output)) - #+(and allegro os-windows) (interactive (%interactivep input output error-output)) + #+(and allegro os-windows) + (interactive (%interactivep input output error-output)) (process* - #+allegro - (multiple-value-list + (nest + #+clisp (progn + ;; clisp cannot redirect stderr, so check we don't. + ;; Also, since we now always return a code, we cannot use this code path + ;; if any of the input, output or error-output is :stream. + (assert (eq %error-output :terminal))) + #-(or allegro mkcl sbcl) (with-current-directory (directory)) + #+(or allegro clasp clisp ecl lispworks mkcl) (multiple-value-list) (apply - 'excl:run-shell-command - #+os-unix (coerce (cons (first %command) %command) 'vector) - #+os-windows %command - :input %input - :output %output - :error-output %error-output - :directory directory :wait wait - #+os-windows :show-window #+os-windows (if interactive nil :hide) - :allow-other-keys t keys)) - #-allegro - (with-current-directory (#-(or sbcl mkcl) directory) + #+allegro 'excl:run-shell-command + #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector) + #+(and allegro os-windows) %command #+clisp - (flet ((run (f x &rest args) - (multiple-value-list - (apply f x :input %input :output %output - :allow-other-keys t `(,@args ,@keys))))) - (assert (eq %error-output :terminal)) - ;;; since we now always return a code, we can't use this code path, anyway! - (etypecase %command - #+os-windows (string (run 'ext:run-shell-command %command)) - (list (run 'ext:run-program (car %command) - :arguments (cdr %command))))) - #+(or clasp clozure cmu ecl mkcl sbcl scl) - (#-(or clasp ecl mkcl) progn #+(or clasp ecl mkcl) multiple-value-list - (apply - '#+(or cmu ecl scl) ext:run-program - #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program - (car %command) (cdr %command) - :input %input - :output %output - :error %error-output - :wait wait - :allow-other-keys t - (append - #+(or clozure cmu mkcl sbcl scl) - `(:if-input-does-not-exist ,if-input-does-not-exist - :if-output-exists ,if-output-exists - :if-error-exists ,if-error-output-exists) - #+sbcl `(:search t - :if-output-does-not-exist :create - :if-error-does-not-exist :create) - #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys))))) - #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case - (multiple-value-list - (apply - 'system:run-shell-command - (cons "/usr/bin/env" %command) ; lispworks wants a full path. - :input %input :if-input-does-not-exist if-input-does-not-exist - :output %output :if-output-exists if-output-exists - :error-output %error-output :if-error-output-exists if-error-output-exists - :wait wait :save-exit-status t :allow-other-keys t keys)))) + (etypecase %command + #+os-windows + (string (lambda (&rest keys) (apply 'ext:run-shell-command %command keys))) + (list (lambda (&rest keys) + (apply 'ext:run-program (car %command) :arguments (cdr %command) keys)))) + #+clozure 'ccl:run-program + #+(or cmu ecl scl) 'ext:run-program + #+lispworks 'system:run-shell-command + #+lispworks (cons "/usr/bin/env" %command) ; LW wants a full path + #+mkcl 'mk-ext:run-program + #+sbcl 'sb-ext:run-program + (append + #+(or clozure cmu ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command)) + `(:input ,%input :output ,%output :wait ,wait :allow-other-keys t) + #-clisp `(#+(or allegro lispworks) :error-output #-(or allegro lispworks) :error + ,%error-output) + #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide)) + #+(or clozure cmu ecl lispworks mkcl sbcl scl) + `(:if-input-does-not-exist ,if-input-does-not-exist + :if-output-exists ,if-output-exists + #-lispworks :if-error-exists #+lispworks :if-error-output-exists + ,if-error-output-exists) + #+lispworks `(:save-exit-status t) + #+sbcl `(:search t + :if-output-does-not-exist :create + :if-error-does-not-exist :create) + #+mkcl `(:directory ,(native-namestring directory)) + #-sbcl keys + #+sbcl (if directory keys (remove-plist-key :directory keys)))))) (process-info-r ())) (flet ((prop (key value) (push key process-info-r) (push value process-info-r))) #+allegro @@ -5150,8 +5088,8 @@ It returns a process-info plist with possible keys: (1 (prop :input-stream (first process*))) (2 (prop :output-stream (first process*))) (3 (prop :bidir-stream (pop process*)) - (prop :input-stream (pop process*)) - (prop :output-stream (pop process*)))))) + (prop :input-stream (pop process*)) + (prop :output-stream (pop process*)))))) #+(or clozure cmu sbcl scl) (progn (prop :process process*) @@ -5479,7 +5417,9 @@ It returns a process-info plist with possible keys: &allow-other-keys) "Run program specified by COMMAND, either a list of strings specifying a program and list of arguments, -or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows). +or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows); +_synchronously_ process its output as specified and return the processing results +when the program and its output processing are complete. Always call a shell (rather than directly execute the command when possible) if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is @@ -5535,14 +5475,15 @@ or an indication of failure via the EXIT-CODE of the process" ;; don't override user's specified preference. [2015/06/29:rpg] (when (stringp command) (unless force-shell-suppliedp + #-(and sbcl os-windows) ;; force-shell t isn't working properly on windows as of sbcl 1.2.16 (setf force-shell t))) (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive)))) (apply (if (or force-shell #+(or clasp clisp) (or (not ignore-error-status) t) #+clisp (member error-output '(:interactive :output)) - ;; old versions of ecl <= 15.3.7 don't support non-trivial :error - #+ecl (and (nth-value 1 (ignore-errors (slot-value (ext:make-external-process) 'ext::error-stream))) - (not (member error-output '(:interactive :output nil)))) + ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program + #+ecl #.(if-let (ver (parse-version (lisp-implementation-version))) + (lexicographic<= '< ver '(16 0 1))) #+(and lispworks os-unix) (%interactivep input output error-output) #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t) '%use-system '%use-run-program) @@ -5558,8 +5499,7 @@ or an indication of failure via the EXIT-CODE of the process" ;;;; Support to build (compile and load) Lisp files (uiop/package:define-package :uiop/lisp-build - (:nicknames :asdf/lisp-build) - (:recycle :uiop/lisp-build :asdf/lisp-build :asdf) + (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) (:export @@ -5622,7 +5562,7 @@ This can help you produce more deterministic output for FASLs.")) #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents) #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*) - #+(or cmu scl) '(c::*default-cookie*) + #+(or cmucl scl) '(c::*default-cookie*) #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) #+clasp '() #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) @@ -5631,11 +5571,11 @@ This can help you produce more deterministic output for FASLs.")) #+sbcl '(sb-c::*policy*))) (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" - #-(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) - #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) - (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) + #+(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) + (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity))) #.`(loop #+(or allegro clozure) ,@'(:with info = #+allegro (sys:declaration-information 'optimize) #+clozure (ccl:declaration-information 'optimize nil)) @@ -5644,7 +5584,7 @@ This can help you produce more deterministic output for FASLs.")) :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order #+clisp (gethash x system::*optimize* 1) #+(or abcl clasp ecl mkcl xcl) (symbol-value v) - #+(or cmu scl) (slot-value c::*default-cookie* + #+(or cmucl scl) (slot-value c::*default-cookie* (case x (compilation-speed 'c::cspeed) (otherwise x))) #+lispworks (slot-value compiler::*optimization-level* x) @@ -5686,7 +5626,7 @@ This can help you produce more deterministic output for FASLs.")) (defvar *usual-uninteresting-conditions* (append ;;#+clozure '(ccl:compiler-warning) - #+cmu '("Deleting unreachable code.") + #+cmucl '("Deleting unreachable code.") #+lispworks '("~S being redefined in ~A (previously in ~A)." "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when. #+sbcl @@ -5871,7 +5811,7 @@ Simple means made of symbols, numbers, characters, simple-strings, pathnames, co :warning-type warning-type :args (destructuring-bind (fun . more) args (cons (symbolify-function-name fun) more)))))) - #+(or cmu scl) + #+(or cmucl scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" @@ -5923,7 +5863,7 @@ WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings sup (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) (ccl::deferred-warnings.warnings mdw)))) - #+(or cmu scl) + #+(or cmucl scl) (when lisp::*in-compilation-unit* ;; Try to send nothing through the pipe if nothing needs to be accumulated `(,@(when c::*undefined-warnings* @@ -5969,7 +5909,7 @@ One of three functions required for deferred-warnings support in ASDF." (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) (appendf (ccl::deferred-warnings.warnings dw) (mapcar 'unreify-deferred-warning reified-deferred-warnings))) - #+(or cmu scl) + #+(or cmucl scl) (dolist (item reified-deferred-warnings) ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. ;; For *undefined-warnings*, the adjustment is a list of initargs. @@ -6032,7 +5972,7 @@ One of three functions required for deferred-warnings support in ASDF." (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) (setf (ccl::deferred-warnings.warnings mdw) nil))) - #+(or cmu scl) + #+(or cmucl scl) (when lisp::*in-compilation-unit* (setf c::*undefined-warnings* nil c::*compiler-error-count* 0 @@ -6198,25 +6138,26 @@ possibly in a different process. Otherwise just call THUNK." "This function provides a portable wrapper around COMPILE-FILE. It ensures that the OUTPUT-FILE value is only returned and the file only actually created if the compilation was successful, -even though your implementation may not do that, and including -an optional call to an user-provided consistency check function COMPILE-CHECK; +even though your implementation may not do that. It also checks an optional +user-provided consistency function COMPILE-CHECK to determine success; it will call this function if not NIL at the end of the compilation with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE where TMP-FILE is the name of a temporary output-file. It also checks two flags (with legacy british spelling from ASDF1), *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR* with appropriate implementation-dependent defaults, -and if a failure (respectively warnings) are reported by COMPILE-FILE -with consider it an error unless the respective behaviour flag +and if a failure (respectively warnings) are reported by COMPILE-FILE, +it will consider that an error unless the respective behaviour flag is one of :SUCCESS :WARN :IGNORE. If WARNINGS-FILE is defined, deferred warnings are saved to that file. On ECL or MKCL, it creates both the linkable object and loadable fasl files. On implementations that erroneously do not recognize standard keyword arguments, it will filter them appropriately." - #+(or clasp ecl) (when (and object-file (equal (compile-file-type) (pathname object-file))) - (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" - 'compile-file* output-file object-file) - (rotatef output-file object-file)) + #+(or clasp ecl) + (when (and object-file (equal (compile-file-type) (pathname object-file))) + (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" + 'compile-file* output-file object-file) + (rotatef output-file object-file)) (let* ((keywords (remove-plist-keys `(:output-file :compile-check :warnings-file #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys)) @@ -6227,7 +6168,7 @@ it will filter them appropriately." (object-file (unless (use-ecl-byte-compiler-p) (or object-file - #+ecl(compile-file-pathname output-file :type :object) + #+ecl (compile-file-pathname output-file :type :object) #+clasp (compile-file-pathname output-file :output-type :object)))) #+mkcl (object-file @@ -6341,15 +6282,14 @@ it will filter them appropriately." :members ,(loop :for f :in (reverse fasls) :collect `(,(namestring f) :load-only t)))) - (scm:concatenate-system output :fasls-to-concatenate)) + (scm:concatenate-system output :fasls-to-concatenate :force t)) (loop :for f :in fasls :do (ignore-errors (delete-file f))) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) ;;;; --------------------------------------------------------------------------- ;;;; Generic support for configuration files (uiop/package:define-package :uiop/configuration - (:nicknames :asdf/configuration) - (:recycle :uiop/configuration :asdf/configuration :asdf) + (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27. (:use :uiop/common-lisp :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) (:export @@ -6545,7 +6485,7 @@ directive.") ;; but what it means to the output-translations is ;; "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location - (let ((p (make-pathname* :directory '(:relative)))) + (let ((p (make-pathname :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir-pathname)) ((eql :here) (resolve-absolute-location @@ -6691,7 +6631,7 @@ also \"Configuration DSL\"\) in the ASDF manual." (resolve-absolute-location `(,(or (getenv-absolute-directory "XDG_CACHE_HOME") (os-cond - ((os-windows-p) (xdg-data-home "cache")) + ((os-windows-p) (xdg-data-home "cache/")) (t (subpathname* (user-homedir-pathname) ".cache/")))) ,more))) @@ -6762,14 +6702,11 @@ objects. Side-effects for cached file location computation." ;;; Hacks for backward-compatibility of the driver (uiop/package:define-package :uiop/backward-driver - (:nicknames :asdf/backward-driver) - (:recycle :uiop/backward-driver :asdf/backward-driver :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration) (:export - #:coerce-pathname #:component-name-to-pathname-components - #+(or clasp ecl mkcl) #:compile-file-keeping-object + #:coerce-pathname #:user-configuration-directories #:system-configuration-directories #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory )) @@ -6780,27 +6717,11 @@ objects. Side-effects for cached file location computation." (with-upgradability () (defun coerce-pathname (name &key type defaults) ;; For backward-compatibility only, for people using internals - ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb - ;; Will be removed after 2014-01-16. + ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) + ;; Will be removed after 2015-12. ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") (parse-unix-namestring name :type type :defaults defaults)) - (defun component-name-to-pathname-components (unix-style-namestring - &key force-directory force-relative) - ;; Will be removed after 2014-01-16. - ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS") - (multiple-value-bind (relabs path filename file-only) - (split-unix-namestring-directory-components - unix-style-namestring :ensure-directory force-directory) - (declare (ignore file-only)) - (when (and force-relative (not (eq relabs :relative))) - (error (compatfmt "~@") - unix-style-namestring)) - (values relabs path filename))) - - #+(or clasp ecl mkcl) - (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)) - ;; Backward compatibility for ASDF 2.27 to 3.1.4 (defun user-configuration-directories () "Return the current user's list of user configuration directories @@ -6833,7 +6754,8 @@ for common-lisp. DEPRECATED." ;;;; Re-export all the functionality in UIOP (uiop/package:define-package :uiop/driver - (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils) + (:nicknames :uiop :asdf/driver) ;; asdf/driver is obsolete (uiop isn't); + ;; but asdf/driver is still used by swap-bytes, static-vectors. (:use :uiop/common-lisp) ;; NB: not reexporting uiop/common-lisp ;; which include all of CL with compatibility modifications on select platforms, @@ -6841,9 +6763,8 @@ for common-lisp. DEPRECATED." ;; or :use (closer-common-lisp uiop), etc. (:use-reexport :uiop/package :uiop/utility - :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image - :uiop/run-program :uiop/lisp-build - :uiop/configuration :uiop/backward-driver)) + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image + :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) ;; Provide both lowercase and uppercase, to satisfy more people. (provide "uiop") (provide "UIOP") @@ -6857,7 +6778,7 @@ for common-lisp. DEPRECATED." (:export #:asdf-version #:*previous-asdf-versions* #:*asdf-version* #:asdf-message #:*verbose-out* - #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:defparameter* + #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! #:intern*) @@ -6879,7 +6800,16 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (cons (format nil "~{~D~^.~}" rev)) (null "1.0")))))) ;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly. - (defvar *previous-asdf-versions* (if-let (previous (asdf-version)) (list previous))) + (defvar *previous-asdf-versions* + (let ((previous (asdf-version))) + (when previous + ;; Punt on hard package upgrade: from ASDF1 or ASDF2 + (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature. + (let ((away (format nil "~A-~A" :asdf previous))) + (rename-package :asdf away) + (when *load-verbose* + (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))) + (list previous))) (defvar *asdf-version* nil) ;; We need to clear systems from versions yet older than the below: (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component. @@ -6916,7 +6846,7 @@ previously-loaded version of ASDF." ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "3.1.5.4") + (asdf-version "3.1.7") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -6930,21 +6860,7 @@ previously-loaded version of ASDF." (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. ;; NB: it's too late to do anything about functions in UIOP! ;; If you introduce some critically incompatibility there, you must change name. - '(#:component-relative-pathname #:component-parent-pathname ;; component - #:source-file-type - #:find-system #:system-source-file #:system-relative-pathname ;; system - #:find-component ;; find-component - #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action - #:component-depends-on #:operation-done-p #:component-depends-on - #:traverse ;; backward-interface - #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan - #:operate ;; operate - #:parse-component-form ;; defsystem - #:apply-output-translations ;; output-translations - #:process-output-translations-directive - #:inherit-source-registry #:process-source-registry ;; source-registry - #:process-source-registry-directive - #:trivial-system-p)) ;; bundle + '()) ;; empty now that we don't unintern, but wholly punt on ASDF 2.26 or earlier. (redefined-classes ;; redefining the classes causes interim circularities ;; with the old ASDF during upgrade, and many implementations bork @@ -6966,12 +6882,6 @@ previously-loaded version of ASDF." ;;; Self-upgrade functions (with-upgradability () - (defun asdf-upgrade-error () - ;; Important notice for whom it concerns. The crux of the matter is that - ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late. - (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ - Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%")) - (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) (let ((new-version (asdf-version))) (unless (equal old-version new-version) @@ -7076,7 +6986,7 @@ another pathname in a degenerate way.")) ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] - #+cmu (:report print-object)) + #+cmucl (:report print-object)) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) @@ -7114,10 +7024,9 @@ another pathname in a degenerate way.")) ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) - ;; methods defined using the "inline" style inside a defsystem form: - ;; need to store them somewhere so we can delete them when the system - ;; is re-evaluated. - (inline-methods :accessor component-inline-methods :initform nil) ;; OBSOLETE! DELETE THIS IF NO ONE USES. + ;; Methods defined using the "inline" style inside a defsystem form: + ;; we store them here so we can delete them when the system is re-evaluated. + (inline-methods :accessor component-inline-methods :initform nil) ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative. ;; There is no initform and no direct accessor for this specified pathname, ;; so we only access the information through appropriate methods, after it has been processed. @@ -7506,7 +7415,8 @@ in which the system specification (.asd file) is located." #:remove-entry-from-registry #:coerce-entry-to-directory #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:locate-system #:load-asd - #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems + #:system-registered-p #:register-system #:registered-systems* #:registered-systems + #:clear-system #:map-systems #:missing-component #:missing-requires #:missing-parent #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error #:load-system-definition-error #:error-name #:error-pathname #:error-condition @@ -7571,9 +7481,12 @@ of which is a system object.") (defun system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) - (defun registered-systems () + (defun registered-systems* () (loop :for registered :being :the :hash-values :of *defined-systems* - :collect (coerce-name (cdr registered)))) + :collect (cdr registered))) + + (defun registered-systems () + (mapcar 'coerce-name (registered-systems*))) (defun register-system (system) (check-type system system) @@ -7792,7 +7705,8 @@ Going forward, we recommend new users should be using the source-registry. (find-system (coerce-name name) error-p)) (defun find-system-if-being-defined (name) - ;; notable side effect: mark the system as being defined, to avoid infinite loops + ;; NB: this depends on a corresponding side-effect in parse-defsystem; + ;; this protocol may change somewhat in the future. (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) (defun load-asd (pathname @@ -7813,10 +7727,10 @@ Going forward, we recommend new users should be using the source-registry. ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. (pathname-directory-pathname (physicalize-pathname pathname)))) (handler-bind - ((error #'(lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname - :condition condition)))) + (((and error (not missing-component)) + #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname :condition condition)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") name pathname) (load* pathname :external-format external-format)))))) @@ -8450,6 +8364,7 @@ The class needs to be updated for ASDF 3.1 and specify appropriate propagation m ;;;; Done performing (with-upgradability () (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp + (defgeneric (setf component-operation-time) (time operation component)) (define-convenience-action-methods component-operation-time (operation component)) (defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp) @@ -8486,9 +8401,11 @@ in some previous image, or T if it needs to be done.") (defmethod component-operation-time ((o operation) (c component)) (gethash (type-of o) (component-operation-times c))) + (defmethod (setf component-operation-time) (stamp (o operation) (c component)) + (setf (gethash (type-of o) (component-operation-times c)) stamp)) + (defmethod mark-operation-done ((o operation) (c component)) - (setf (gethash (type-of o) (component-operation-times c)) - (compute-action-stamp nil o c :just-done t)))) + (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t)))) ;;;; Perform @@ -8623,7 +8540,13 @@ in some previous image, or T if it needs to be done.") &optional #+(or clasp ecl mkcl) object-file #+clisp lib-file - warnings-file) outputs + warnings-file &rest rest) outputs + ;; Allow for extra outputs that are not of type warnings-file + ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional. + (declare (ignore rest)) + (when warnings-file + (unless (equal (pathname-type warnings-file) (warnings-file-type)) + (setf warnings-file nil))) (call-with-around-compile-hook c #'(lambda (&rest flags) (apply 'compile-file* input-file @@ -8980,7 +8903,7 @@ the action of OPERATION on COMPONENT in the PLAN")) (latest-in (stamps-latest (cons dep-stamp in-stamps)))) (when (and missing-in (not just-done)) (return (values t nil)))) ;; collect timestamps from outputs, and exit early if any is missing - (let* ((out-files (output-files o c)) + (let* ((out-files (remove-if 'null (output-files o c))) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (earliest-out (stamps-earliest out-stamps))) @@ -9121,6 +9044,8 @@ the action of OPERATION on COMPONENT in the PLAN")) :index (if status ; index of action amongst all nodes in traversal (action-index status) ;; if already visited, keep index (incf (plan-total-action-count plan))))) ; else new index + (when (and done-p (not add-to-plan-p)) + (setf (component-operation-time operation component) stamp)) (when add-to-plan-p ; if it needs to be added to the plan, (incf (plan-planned-action-count plan)) ; count it (unless aniip ; if it's output-producing, @@ -9411,7 +9336,7 @@ to load it in current image." (defun already-loaded-systems () "return a list of the names of the systems that have been successfully loaded so far" - (remove-if-not 'component-loaded-p (registered-systems))) + (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*)))) (defun require-system (system &rest keys &key &allow-other-keys) "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the @@ -9816,7 +9741,7 @@ effectively disabling the output translation facility." #:default-user-source-registry #:default-system-source-registry #:user-source-registry #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory - #:environment-source-registry #:process-source-registry + #:environment-source-registry #:process-source-registry #:inherit-source-registry #:compute-source-registry #:flatten-source-registry #:sysdef-source-registry-search)) (in-package :asdf/source-registry) @@ -9839,6 +9764,8 @@ effectively disabling the output translation facility." "Either NIL (for uninitialized), or an equal hash-table, mapping system names to pathnames of .asd files") + (defvar *source-registry-parameter* nil) + (defun source-registry-initialized-p () (typep *source-registry* 'hash-table)) @@ -9849,7 +9776,7 @@ system names to pathnames of .asd files") (register-clear-configuration-hook 'clear-source-registry) (defparameter *wild-asd* - (make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) (defun directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -9873,15 +9800,22 @@ after having found a .asd file? True by default.") (defun collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache) - (collect-sub*directories - directory - #'(lambda (dir) - (unless (and (not ignore-cache) (process-source-registry-cache directory collect)) - (let ((asds (collect-asds-in-directory dir collect))) - (or recurse-beyond-asds (not asds))))) - #'(lambda (x) - (not (member (car (last (pathname-directory x))) exclude :test #'equal))) - (constantly nil))) + (let ((visited (make-hash-table :test 'equalp))) + (collect-sub*directories + directory + #'(lambda (dir) + (unless (and (not ignore-cache) (process-source-registry-cache directory collect)) + (let ((asds (collect-asds-in-directory dir collect))) + (or recurse-beyond-asds (not asds))))) + #'(lambda (x) ; x will be a directory pathname + (and + (not (member (car (last (pathname-directory x))) exclude :test #'equal)) + (flet ((pathname-key (x) + (namestring (truename* x)))) + (let ((visitedp (gethash (pathname-key x) visited))) + (if visitedp nil + (setf (gethash (pathname-key x) visited) t)))))) + (constantly nil)))) (defun validate-source-registry-directive (directive) (or (member directive '(:default-registry)) @@ -9974,7 +9908,7 @@ after having found a .asd file? True by default.") #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) :inherit-configuration #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) - #+cmu (:tree #p"modules:") + #+cmucl (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) (defun default-user-source-registry () `(:source-registry @@ -10060,7 +9994,7 @@ after having found a .asd file? True by default.") (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) - (defun flatten-source-registry (&optional parameter) + (defun flatten-source-registry (&optional (parameter *source-registry-parameter*)) (remove-duplicates (while-collecting (collect) (with-pathname-defaults () ;; be location-independent @@ -10073,7 +10007,7 @@ after having found a .asd file? True by default.") :test 'equal :from-end t)) ;; Will read the configuration and initialize all internal variables. - (defun compute-source-registry (&optional parameter (registry *source-registry*)) + (defun compute-source-registry (&optional (parameter *source-registry-parameter*) (registry *source-registry*)) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates @@ -10103,8 +10037,6 @@ after having found a .asd file? True by default.") h))) (values)) - (defvar *source-registry-parameter* nil) - (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) ;; Record the parameter used to configure the registry (setf *source-registry-parameter* parameter) @@ -10293,7 +10225,7 @@ after having found a .asd file? True by default.") ;;; Main parsing function (with-upgradability () - (defun* parse-dependency-def (dd) + (defun parse-dependency-def (dd) (if (listp dd) (case (first dd) (:feature @@ -10314,12 +10246,12 @@ after having found a .asd file? True by default.") (otherwise (sysdef-error "Ill-formed dependency: ~s" dd))) (coerce-name dd))) - (defun* parse-dependency-defs (dd-list) + (defun parse-dependency-defs (dd-list) "Parse the dependency defs in DD-LIST into canonical form by translating all system names contained using COERCE-NAME. Return the result." (mapcar 'parse-dependency-def dd-list)) - (defun* (parse-component-form) (parent options &key previous-serial-component) + (defun (parse-component-form) (parent options &key previous-serial-component) (destructuring-bind (type name &rest rest &key (builtin-system-p () bspp) @@ -10409,6 +10341,15 @@ system names contained using COERCE-NAME. Return the result." (with-asdf-cache () (let* ((name (coerce-name name)) (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) + ;; NB: handle defsystem-depends-on BEFORE to create the system object, + ;; so that in case it fails, there is no incomplete object polluting the build. + (checked-defsystem-depends-on + (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) + (deps (loop :for spec :in dep-forms + :when (resolve-dependency-spec nil spec) + :collect :it))) + (load-systems* deps) + dep-forms)) (registered (system-registered-p name)) (registered! (if registered (rplaca registered (get-file-stamp source-file)) @@ -10417,17 +10358,12 @@ system names contained using COERCE-NAME. Return the result." (system (reset-system (cdr registered!) :name name :source-file source-file)) (component-options - (remove-plist-keys '(:defsystem-depends-on :class) options)) - (defsystem-dependencies (loop :for spec :in defsystem-depends-on - :when (resolve-dependency-spec nil spec) - :collect :it))) - ;; cache defsystem-depends-on in canonical form - (when defsystem-depends-on - (setf component-options - (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on)) - component-options))) + (append + (remove-plist-keys '(:defsystem-depends-on :class) options) + ;; cache defsystem-depends-on in canonical form + (when checked-defsystem-depends-on + `(:defsystem-depends-on ,checked-defsystem-depends-on))))) (set-asdf-cache-entry `(find-system ,name) (list system)) - (load-systems* defsystem-dependencies) ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. (let ((class (class-for-type nil class))) @@ -10453,7 +10389,7 @@ system names contained using COERCE-NAME. Return the result." :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) (:export #:bundle-op #:bundle-type #:program-system - #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files + #:bundle-system #:bundle-pathname-type #:direct-dependency-files #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p #:basic-compile-bundle-op #:prepare-bundle-op #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op @@ -10511,7 +10447,8 @@ itself.")) ;; operation on a system and its dependencies (:documentation "Abstract operation for linking files together")) (defclass gather-op (bundle-op) - ((gather-op :initform nil :allocation :class :reader gather-op)) + ((gather-op :initform nil :allocation :class :reader gather-op) + (gather-type :initform :no-output-file :allocation :class :reader gather-type)) (:documentation "Abstract operation for gathering many input files from a system")) (defun operation-monolithic-p (op) @@ -10531,7 +10468,9 @@ itself.")) ;; operation on a system and its dependencies ;; create a single fasl for the entire library (defclass basic-compile-bundle-op (bundle-op) - ((bundle-type :initform :fasl))) + ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object + :allocation :class) + (bundle-type :initform :fasl :allocation :class))) (defclass prepare-bundle-op (sideway-operation) ((sideway-operation @@ -10539,16 +10478,32 @@ itself.")) ;; operation on a system and its dependencies :allocation :class))) (defclass lib-op (link-op gather-op non-propagating-operation) - ((bundle-type :initform :lib)) - (:documentation "compile the system and produce linkable (.a) library for it.")) + ((gather-type :initform :object :allocation :class) + (bundle-type :initform :lib :allocation :class)) + (:documentation "Compile the system and produce a linkable static library (.a/.lib) +for all the linkable object files associated with the system. Compare with DLL-OP. + +On most implementations, these object files only include extensions to the runtime +written in C or another language with a compiler producing linkable object files. +On CLASP, ECL, MKCL, these object files also include the contents of Lisp files +themselves. In any case, this operation will produce what you need to further build +a static runtime for your system, or a dynamic library to load in an existing runtime.")) (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op) ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op) - :allocation :class))) + :allocation :class)) + (:documentation "This operator is an alternative to COMPILE-OP. Build a system +and all of its dependencies, but build only a single (\"monolithic\") FASL, instead +of one per source file, which may be more resource efficient. That monolithic +FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP.")) (defclass load-bundle-op (basic-load-op selfward-operation) - ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))) + ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)) + (:documentation "This operator is an alternative to LOAD-OP. Build a system +and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with +respect to LOAD-OP is that it builds only a single FASL, which may be +faster and more resource efficient.")) ;; NB: since the monolithic-op's can't be sideway-operation's, ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's, @@ -10556,39 +10511,55 @@ itself.")) ;; operation on a system and its dependencies ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. (defclass dll-op (link-op gather-op non-propagating-operation) - ((bundle-type :initform :dll)) - (:documentation "compile the system and produce dynamic (.so/.dll) library for it.")) + ((gather-type :initform :object :allocation :class) + (bundle-type :initform :dll :allocation :class)) + (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) +for all the linkable object files associated with the system. Compare with LIB-OP.")) (defclass deliver-asd-op (basic-compile-op selfward-operation) - ((selfward-operation :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class)) + ((selfward-operation + ;; TODO: implement link-op on all implementations, and make that + ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op) + :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) + :allocation :class)) (:documentation "produce an asd file for delivering the system as a single fasl")) (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op) ((selfward-operation + ;; TODO: implement link-op on all implementations, and make that + ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op) :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) :allocation :class)) (:documentation "produce fasl and asd files for combined system and dependencies.")) - (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op - #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation) - ((gather-op :initform #+(or clasp ecl mkcl) 'lib-op #-(or clasp ecl mkcl) 'compile-bundle-op :allocation :class)) + (defclass monolithic-compile-bundle-op + (monolithic-bundle-op basic-compile-bundle-op + #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation) + ((gather-op :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op + :allocation :class) + (gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library + :allocation :class)) (:documentation "Create a single fasl for the system and its dependencies.")) (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op) ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)) (:documentation "Load a single fasl for the system and its dependencies.")) - (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) () - (:documentation "Create a single linkable library for the system and its dependencies.")) + (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) + ((gather-type :initform :static-library :allocation :class)) + (:documentation "Compile the system and produce a linkable static library (.a/.lib) +for all the linkable object files associated with the system or its dependencies. See LIB-OP.")) (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation) - ((bundle-type :initform :dll)) - (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) + ((gather-type :initform :static-library :allocation :class)) + (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) +for all the linkable object files associated with the system or its dependencies. See LIB-OP")) (defclass image-op (monolithic-bundle-op selfward-operation #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op) ((bundle-type :initform :image) + #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class) (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) (:documentation "create an image file from the system and its dependencies")) @@ -10598,17 +10569,29 @@ itself.")) ;; operation on a system and its dependencies (defun bundle-pathname-type (bundle-type) (etypecase bundle-type - ((eql :no-output-file) nil) ;; should we error out instead? - ((or null string) bundle-type) - ((eql :fasl) #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb") - #+(or clasp ecl) - ((member :dll :lib :shared-library :static-library :program :object :program) - (compile-file-type :type bundle-type)) - ((member :image) #+allegro "dxl" #+(and clisp os-windows) "exe" #-(or allegro (and clisp os-windows)) "image") - ((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) - ((member :lib :static-library) (os-cond ((os-unix-p) "a") - ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) - ((eql :program) (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) + ((or null string) ;; pass through nil or string literal + bundle-type) + ((eql :no-output-file) ;; marker for a bundle-type that has NO output file + (error "No output file, therefore no pathname type")) + ((eql :fasl) ;; the type of a fasl + #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output + #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles + ((member :image) + #+allegro "dxl" + #+(and clisp os-windows) "exe" + #-(or allegro (and clisp os-windows)) "image") + ;; NB: on CLASP and ECL these implementations, we better agree with + ;; (compile-file-type :type bundle-type)) + ((eql :object) ;; the type of a linkable object file + (os-cond ((os-unix-p) "o") + ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj")))) + ((member :lib :static-library) ;; the type of a linkable library + (os-cond ((os-unix-p) "a") + ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) + ((member :dll :shared-library) ;; the type of a shared library + (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) + ((eql :program) ;; the type of an executable program + (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) (defun bundle-output-files (o c) (let ((bundle-type (bundle-type o))) @@ -10618,7 +10601,10 @@ itself.")) ;; operation on a system and its dependencies (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) (type (bundle-pathname-type bundle-type))) (values (list (subpathname (component-pathname c) name :type type)) - (eq (type-of o) (component-build-operation c))))))) + (eq (class-of o) (coerce-class (component-build-operation c) + :package :asdf/interface + :super 'operation + :error nil))))))) (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) @@ -10673,16 +10659,6 @@ itself.")) ;; operation on a system and its dependencies :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments (operation-original-initargs instance)))) - (defun bundlable-file-p (pathname) - (let ((type (pathname-type pathname))) - (declare (ignorable type)) - (or #+(or clasp ecl) (or (equalp type (compile-file-type :type :object)) - (equalp type (compile-file-type :type :static-library))) - #+mkcl (or (equalp type (compile-file-type :fasl-p nil)) - #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW - #+(and windows (not (or mingw32 mingw64))) (equalp type "lib")) - #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) - (defgeneric* (trivial-system-p) (component)) (defun user-system-p (s) @@ -10711,9 +10687,14 @@ itself.")) ;; operation on a system and its dependencies (loop :for f :in (funcall key sub-o sub-c) :when (funcall test f) :do (collect f)))))) + (defun pathname-type-equal-function (type) + #'(lambda (p) (equal (pathname-type p) type))) + (defmethod input-files ((o gather-op) (c system)) (unless (eq (bundle-type o) :no-output-file) - (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) + (direct-dependency-files + o c :key 'output-files + :test (pathname-type-equal-function (bundle-pathname-type (gather-type o)))))) (defun select-bundle-operation (type &optional monolithic) (ecase type @@ -10912,10 +10893,11 @@ itself.")) ;; operation on a system and its dependencies #+(or clasp ecl mkcl) (with-upgradability () - ;; I think that Juanjo intended for this to be, - ;; but beware the weird bug in test-xach-update-bug.script, - ;; and also it makes mkcl fail test-logical-pathname.script, - ;; and ecl fail test-bundle.script. + ;; I think that Juanjo intended for this to be, but it was disabled before 3.1 + ;; due to implementation bugs in ECL and MKCL that seem to have been fixed since + ;; -- see for ECL test-xach-update-bug.script and test-bundle.script, + ;; and for MKCL test-logical-pathname.script. + ;; We should probably reenable these after consulting with ECL and MKCL maintainers. ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p)) ;; (setf *load-system-operation* 'load-bundle-op)) @@ -10975,16 +10957,6 @@ itself.")) ;; operation on a system and its dependencies :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c))) :no-uiop (no-uiop c) (when programp `(:entry-point ,(component-entry-point c)))))))) - -#+(and (not asdf-use-unsafe-mac-bundle-op) - (or (and clasp ecl darwin) - (and abcl darwin (not abcl-bundle-op-supported)))) -(defmethod perform :before ((o basic-compile-bundle-op) (c component)) - (unless (featurep :asdf-use-unsafe-mac-bundle-op) - (cerror "Continue after modifying *FEATURES*." - "BASIC-COMPILE-BUNDLE-OP operations are not supported on Mac OS X for this lisp.~%~T~ -To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~ -Please report to ASDF-DEVEL if this works for you."))) ;;;; ------------------------------------------------------------------------- ;;;; Concatenate-source @@ -11171,11 +11143,12 @@ otherwise return a default system name computed from PACKAGE-NAME." (remove t (mapcar 'package-name-system (package-dependencies defpackage-form))) (error 'package-inferred-system-missing-package-error :system system :pathname file))) - (defun same-package-inferred-system-p (system name directory subpath dependencies) + (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies) (and (eq (type-of system) 'package-inferred-system) (equal (component-name system) name) (pathname-equal directory (component-pathname system)) (equal dependencies (component-sideway-dependencies system)) + (equal around-compile (around-compile-hook system)) (let ((children (component-children system))) (and (length=n-p children 1) (let ((child (first children))) @@ -11189,20 +11162,22 @@ otherwise return a default system name computed from PACKAGE-NAME." (unless (equal primary system) (let ((top (find-system primary nil))) (when (typep top 'package-inferred-system) - (if-let (dir (system-source-directory top)) + (if-let (dir (component-pathname top)) (let* ((sub (subseq system (1+ (length primary)))) (f (probe-file* (subpathname dir sub :type "lisp") :truename *resolve-symlinks*))) (when (file-pathname-p f) (let ((dependencies (package-inferred-system-file-dependencies f system)) - (previous (cdr (system-registered-p system)))) - (if (same-package-inferred-system-p previous system dir sub dependencies) + (previous (cdr (system-registered-p system))) + (around-compile (around-compile-hook top))) + (if (same-package-inferred-system-p previous system dir sub around-compile dependencies) previous (eval `(defsystem ,system :class package-inferred-system :source-file nil :pathname ,dir :depends-on ,dependencies + :around-compile ,around-compile :components ((cl-source-file "lisp" :pathname ,sub))))))))))))))) (with-upgradability () @@ -11216,27 +11191,14 @@ otherwise return a default system name computed from PACKAGE-NAME." (uiop/package:define-package :asdf/backward-internals (:recycle :asdf/backward-internals :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) - (:export ;; for internal use - #:make-sub-operation - #:load-sysdef #:make-temporary-package)) + (:export #:load-sysdef)) (in-package :asdf/backward-internals) -(when-upgrading (:when (fboundp 'make-sub-operation)) - (defun make-sub-operation (c o dep-c dep-o) - (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) - -;;;; load-sysdef (with-upgradability () (defun load-sysdef (name pathname) - (load-asd pathname :name name)) - - (defun make-temporary-package () - ;; For loading a .asd file, we don't make a temporary package anymore, - ;; but use ASDF-USER. I'd like to have this function do this, - ;; but since whoever uses it is likely to delete-package the result afterwards, - ;; this would be a bad idea, so preserve the old behavior. - (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) - + (declare (ignore name pathname)) + ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. + (error "Use asdf:load-asd instead of asdf::load-sysdef"))) ;;;; ------------------------------------------------------------------------- ;;; Backward-compatible interfaces @@ -11606,12 +11568,12 @@ Please use UIOP:RUN-PROGRAM instead." (in-package :asdf/footer) ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. -#+(or abcl clasp clisp clozure cmu ecl mkcl sbcl) +#+(or abcl clasp clisp clozure cmucl ecl mkcl sbcl) (with-upgradability () (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))) (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* - #+(or clasp cmu ecl) ext:*module-provider-functions* + #+(or clasp cmucl ecl) ext:*module-provider-functions* #+clisp ,x #+clozure ccl:*module-provider-functions* #+mkcl mk-ext:*module-provider-functions* @@ -11635,7 +11597,7 @@ Please use UIOP:RUN-PROGRAM instead." (and (first l) (register-preloaded-system (coerce-name name))) (values-list l)))))))) -#+cmu ;; Hook into the CMUCL herald. +#+cmucl ;; Hook into the CMUCL herald. (with-upgradability () (defun herald-asdf (stream) (format stream " ASDF ~A" (asdf-version))) @@ -11646,7 +11608,7 @@ Please use UIOP:RUN-PROGRAM instead." (with-upgradability () #+allegro (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*)) + (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf-package-system)) (pushnew f *features*)) diff --git a/contrib/asdf/asdf.texinfo b/contrib/asdf/asdf.texinfo index 61e2e04e8..db8218c87 100644 --- a/contrib/asdf/asdf.texinfo +++ b/contrib/asdf/asdf.texinfo @@ -34,13 +34,13 @@ This manual describes ASDF, a system definition facility for Common Lisp programs and libraries. You can find the latest version of this manual at -@url{http://common-lisp.net/project/asdf/asdf.html}. +@url{https://common-lisp.net/project/asdf/asdf.html}. -ASDF Copyright @copyright{} 2001-2014 Daniel Barlow and contributors. +ASDF Copyright @copyright{} 2001-2015 Daniel Barlow and contributors. -This manual Copyright @copyright{} 2001-2014 Daniel Barlow and contributors. +This manual Copyright @copyright{} 2001-2015 Daniel Barlow and contributors. -This manual revised @copyright{} 2009-2014 Robert P. Goldman and Francois-Rene Rideau. +This manual revised @copyright{} 2009-2015 Robert P. Goldman and Francois-Rene Rideau. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -63,11 +63,9 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. @end copying - - @titlepage @title ASDF: Another System Definition Facility - +@subtitle Manual for Version 3.1.7 @c The following two commands start the copyright page. @page @vskip 0pt plus 1filll @@ -83,6 +81,10 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. @node Top, Introduction, (dir), (dir) @top ASDF: Another System Definition Facility +@ifnottex +Manual for Version 3.1.6.14 +@end ifnottex + @insertcopying @@ -115,13 +117,9 @@ Loading ASDF * Loading a pre-installed ASDF:: * Checking whether ASDF is loaded:: * Upgrading ASDF:: +* Replacing your implementation's ASDF:: * Loading ASDF from source:: -Upgrading ASDF - -* Upgrading your implementation's ASDF:: -* Issues with upgrading ASDF:: - Configuring ASDF * Configuring ASDF to find your systems:: @@ -132,7 +130,7 @@ Configuring ASDF Using ASDF * Loading a system:: -* Other Operations:: +* Convenience Functions:: * Moving on:: Defining systems with defsystem @@ -209,11 +207,13 @@ Miscellaneous additional functionality * Controlling file compilation:: * Controlling source file character encoding:: +* Miscellaneous Functions:: * Some Utility Functions:: FAQ * Where do I report a bug?:: +* Mailing list:: * What has changed between ASDF 1 ASDF 2 and ASDF 3?:: * Issues with installing the proper version of ASDF:: * Issues with configuring ASDF:: @@ -233,6 +233,7 @@ FAQ * ASDF can be upgraded:: * Decoupled release cycle:: * Pitfalls of the transition to ASDF 2:: +* Pitfalls of the upgrade to ASDF 3:: * What happened to the bundle operations:: Issues with installing the proper version of ASDF @@ -254,10 +255,11 @@ Issues with using and extending ASDF to define systems * How do I create a system definition where all the source files have a .cl extension?:: * How do I mark a source file to be loaded only and not compiled?:: * How do I work with readtables?:: +* How can I capture ASDF's output?:: ASDF development FAQs -* How do run the tests interactively in a REPL?:: +* How do I run the tests interactively in a REPL?:: @end detailmenu @end menu @@ -291,7 +293,7 @@ one for writers of Common Lisp software who want to specify how to build their s and one for implementers of Common Lisp extensions who want to extend the build system. For more specifics, -@pxref{Using ASDF,,Loading a system}, +@pxref{Using ASDF}, to learn how to use ASDF to load a system. @xref{Defining systems with defsystem}, to learn how to define a system of your own. @@ -299,14 +301,14 @@ to learn how to define a system of your own. the ASDF internals and how to extend ASDF. Note that -ASDF is @emph{not} a tool for library and system @emph{installation}; it -plays a role like @t{make} or @t{ant}, not like a package manager. -In particular, ASDF should not to be confused with ASDF-Install, which attempts to find and -download ASDF systems for you. -Despite the name, ASDF-Install is not part of ASDF, but a separate piece of software. +ASDF is @emph{not} a tool for library and system @emph{installation}; +it plays a role like @code{make} or @code{ant}, not like a package manager. +In particular, ASDF should not to be confused with Quicklisp or ASDF-Install, +that attempt to find and download ASDF systems for you. +Despite what the name might suggest, ASDF-Install is not part of ASDF, but a separate piece of software. ASDF-Install is also unmaintained and obsolete. We recommend you use Quicklisp -(@uref{http://www.quicklisp.org}) instead, +(@uref{http://www.quicklisp.org/}) instead, a Common Lisp package manager which works well and is being actively maintained. If you want to download software from version control instead of tarballs, so you may more easily modify it, we recommend clbuild (@uref{http://common-lisp.net/project/clbuild/}). @@ -314,6 +316,15 @@ We recommend @file{~/common-lisp/} as a place into which to install Common Lisp software; starting with ASDF 3.1.2, it is included in the default source-registry configuration. +Finally, note that this manual is incomplete. +All the bases are covered, +but many advanced topics are only barely alluded to, +and there is not much in terms of examples. +The source code remains the ultimate source of information, +free software systems in Quicklisp remain the best source of examples, +and the mailing-list the best place to ask for help. + + @node Quick start summary, Loading ASDF, Introduction, Top @chapter Quick start summary @@ -323,23 +334,22 @@ starting with ASDF 3.1.2, it is included in the default source-registry configur @itemize @item -Load ASDF itself into your Lisp image, either through -@code{(require "asdf")} (if it's supplied by your lisp implementation) -or else through -@code{(load "/path/to/asdf.lisp")}. For more details, @ref{Loading ASDF}. +Load ASDF itself into your Lisp image, using +@code{(require "asdf")}. +Check that you have a recent version using @code{(asdf:asdf-version)}. +For more details, or if any of the above fails, @pxref{Loading ASDF}. @item -Make sure ASDF can find system definitions -through proper source-registry configuration. -For more details, @xref{Configuring ASDF to find your systems}. -The simplest way is simply to put all your lisp code in subdirectories of +Make sure software is installed where ASDF can find it. +The simplest way is to put all your Lisp code in subdirectories of @file{~/common-lisp/} (starting with ASDF 3.1.2), or @file{~/.local/share/common-lisp/source/} (for ASDF 2 and later, or if you want to keep source in a hidden directory). -Such code will automatically be found. +For more details, @pxref{Configuring ASDF to find your systems}. @item -Load a system with @code{(asdf:load-system :system)}. @xref{Using ASDF}. +Load your system with @code{(asdf:load-system "@var{my-system}")}. +@xref{Using ASDF}. @end itemize @@ -350,21 +360,22 @@ Load a system with @code{(asdf:load-system :system)}. @xref{Using ASDF}. As above, load and configure ASDF. @item -Make a new directory for your system, @code{my-system/} in a location -where ASDF can find it (@pxref{Configuring ASDF to find your systems}). +Make a new directory for your system, @code{@var{my-system}/}, +again in a location where ASDF can find it. All else being equal, the easiest location is probably @file{~/common-lisp/my-system/}. +@xref{Configuring ASDF to find your systems}. @item Create an ASDF system definition listing the dependencies of your system, its components, and their interdependencies, -and put it in @file{my-system.asd}. -This file must have the same name as your system. +and put it in @file{@var{my-system}.asd}. +This file must have the same name as your system, all lowercase. @xref{Defining systems with defsystem}. @item -Use @code{(asdf:load-system :my-system)} +Use @code{(asdf:load-system "@var{my-system}")} to make sure it's all working properly. @xref{Using ASDF}. @end itemize @@ -385,45 +396,58 @@ to make sure it's all working properly. @xref{Using ASDF}. * Loading a pre-installed ASDF:: * Checking whether ASDF is loaded:: * Upgrading ASDF:: +* Replacing your implementation's ASDF:: * Loading ASDF from source:: @end menu @node Loading a pre-installed ASDF, Checking whether ASDF is loaded, Loading ASDF, Loading ASDF @section Loading a pre-installed ASDF -Most recent Lisp implementations include a copy of ASDF 3, -or at least ASDF 2. -You can usually load this copy using Common Lisp's @code{require} function.@footnote{ +The recommended way to load ASDF is via: +@lisp +(require "asdf") +@end lisp + +All actively maintained Lisp implementations now include a copy of ASDF 3 +that you can load this way using Common Lisp's @code{require} function.@footnote{ NB: all implementations except GNU CLISP also accept @code{(require "ASDF")}, @code{(require 'asdf)} and @code{(require :asdf)}. For portability's sake, you should use @code{(require "asdf")}. } -@lisp -(require "asdf") -@end lisp +If the implementation you are using doesn't provide a recent ASDF 3, +we recommend you upgrade it. +If for some reason you would rather not upgrade it, +we recommend you replace your implementation's ASDF. +@xref{Replacing your implementation's ASDF}. +If all else fails, see @pxref{Loading ASDF from source} below. + +If you use an actively maintained implementation that fails to provide +an up-to-date enough stable release of ASDF, +you may also send a bug report to your Lisp vendor and complain about it +--- or you may fix the issue yourself if it's free software. As of the writing of this manual, the following implementations provide ASDF 3 this way: -ABCL, Allegro CL, Clozure CL, CMUCL, ECL, GNU CLISP, MKCL, SBCL. +ABCL, Allegro CL, CLASP, Clozure CL, CMUCL, ECL, GNU CLISP, LispWorks, MKCL, SBCL. The following implementations only provide ASDF 2: -LispWorks, mocl, XCL. +MOCL, XCL. The following implementations don't provide ASDF: Corman CL, GCL, Genera, MCL, SCL. -The latter implementations are not actively maintained; +The latter implementations are not actively maintained (except maybe GCL); if some of them are ever released again, they probably will include ASDF 3. -If the implementation you are using doesn't provide ASDF 2 or ASDF 3, -see @pxref{Loading ASDF,,Loading ASDF from source} below. -If that implementation is still actively maintained, -you may also send a bug report to your Lisp vendor and complain -about their failing to provide ASDF. +For maximum convenience you might want to have ASDF loaded +whenever you start your Lisp implementation, +for example by loading it from the startup script or dumping a custom core +--- check your Lisp implementation's manual for details. +SLIME notably sports a @code{slime-asdf} contrib that makes life easier with ASDF. + @node Checking whether ASDF is loaded, Upgrading ASDF, Loading a pre-installed ASDF, Loading ASDF @section Checking whether ASDF is loaded -To check whether ASDF is properly loaded in your current Lisp image, -you can run this form: +To check that ASDF is properly loaded, you can run this form: @lisp (asdf:asdf-version) @@ -431,72 +455,55 @@ you can run this form: If it returns a string, that is the version of ASDF that is currently installed. +If that version is suitably recent (say, 3.1.2 or later), +then you can skip directly to next chapter: @xref{Configuring ASDF}. If it raises an error, then either ASDF is not loaded, or you are using a very old version of ASDF, and need to install ASDF 3. -You can check whether an old version is loaded -by checking if the ASDF package is present. -The form below will allow you to programmatically determine -whether a recent version is loaded, an old version is loaded, -or none at all: - -@lisp -(when (find-package :asdf) - (let ((ver (symbol-value - (or (find-symbol (string :*asdf-version*) :asdf) - (find-symbol (string :*asdf-revision*) :asdf))))) - (etypecase ver - (string ver) - (cons (with-output-to-string (s) - (loop for (n . m) on ver - do (princ n s) - (when m (princ "." s))))) - (null "1.0")))) -@end lisp - -If it returns @code{nil} then ASDF is not installed. -Otherwise it should return a string. -If it returns @code{"1.0"}, then it can actually be -any version before 1.77 or so, or some buggy variant of 1.x. +For more precision in detecting versions old and new, +@pxref{How do I detect the ASDF version?}. If you are experiencing problems with ASDF, please try upgrading to the latest released version, using the method below, before you contact us and raise an issue. -@node Upgrading ASDF, Loading ASDF from source, Checking whether ASDF is loaded, Loading ASDF +@node Upgrading ASDF, Replacing your implementation's ASDF, Checking whether ASDF is loaded, Loading ASDF @section Upgrading ASDF @c FIXME: tighten this up a bit -- there's a lot of stuff here that @c doesn't matter to almost anyone. Move discussion of updating antique @c versions of ASDF down, or encapsulate it. -If you want to upgrade to a more recent ASDF version, -you need to install and configure your ASDF just like any other system +If your implementation already provides ASDF 3 or later (and it should), +but you want a more recent ASDF version than your implementation provides, +then you just need to ensure the more recent ASDF is installed in a configured path, like any other system. +We recommend you download an official tarball or checkout a release from git into +@file{~/common-lisp/asdf/}. (@pxref{Configuring ASDF to find your systems}). -If your implementation provides ASDF 3 or later, -you only need to @code{(require "asdf")}: -ASDF will automatically look whether an updated version of itself is available +Once the source code for ASDF is installed, +you don't need any extra step to load it beyond the usual @code{(require "asdf")}: +ASDF 3 will automatically look whether an updated version of itself is available amongst the regularly configured systems, before it compiles anything else. -@menu -* Upgrading your implementation's ASDF:: -* Issues with upgrading ASDF:: -@end menu +If your implementation fails to provide ASDF 3 or later, +@pxref{Replacing your implementation's ASDF}. -@node Upgrading your implementation's ASDF, Issues with upgrading ASDF, Upgrading ASDF, Upgrading ASDF -@subsection Upgrading your implementation's ASDF -Most implementations provide a recent ASDF 3 in their latest release. -If yours doesn't, we recommend upgrading your implementation. -If the latest version of your implementation still doesn't provide ASDF, -or provides an old version, we recommend installing a recent ASDF so your implementation provides it, -as explained below. -If all fails, we recommend you load ASDF from source -@pxref{Loading ASDF,,Loading ASDF from source}. +@node Replacing your implementation's ASDF, Loading ASDF from source, Upgrading ASDF, Loading ASDF +@section Replacing your implementation's ASDF + +All maintained implementations now provide ASDF 3 in their latest release. +If your doesn't, we recommend you upgrade it. + +Now, if you insist on using an old implementation that didn't provide ASDF or provided an old version, +we recommend installing a recent ASDF, as explained below, +into your implementation's installation directory. +Thus your modified implementation will now provide ASDF 3. +This requires proper write permissions and may necessitate execution as a system administrator. The ASDF source repository contains a tool to help you upgrade your implementation's ASDF. You can invoke it from the shell command-line as @@ -504,91 +511,21 @@ You can invoke it from the shell command-line as (where you can replace @code{lispworks} by the name of the relevant implementation), or you can @code{(load "tools/install-asdf.lisp")} from your Lisp REPL. -It works on +This script works on Allegro CL, Clozure CL, CMU CL, ECL, GCL, GNU CLISP, LispWorks, MKCL, SBCL, SCL, XCL. It doesn't work on ABCL, Corman CL, Genera, MCL, MOCL. Happily, ABCL is usually pretty up to date and shouldn't need that script. -GCL requires a very recent version, and hasn't been tested for lack of success compiling it. +GCL requires a very recent version, and hasn't been tested much. Corman CL, Genera, MCL are obsolete anyway. -MOCL is under development. +MOCL is incomplete. -Finally, if your implementation only provides ASDF 2, -and you can't or won't upgrade it or override its ASDF module, -you may simply configure ASDF to find a proper upgrade; -however, to avoid issues with a self-upgrade in mid-build, -you @emph{must} make sure to upgrade ASDF immediately -after requiring the builtin ASDF 2: -@lisp -(require "asdf") -;; <--- insert programmatic configuration here if needed -(asdf:load-system :asdf) -@end lisp - -@node Issues with upgrading ASDF, , Upgrading your implementation's ASDF, Upgrading ASDF -@subsection Issues with upgrading ASDF - -Note that there are some limitations to upgrading ASDF: -@itemize -@item -Previously loaded ASDF extensions become invalid, and will need to be reloaded. -Examples include CFFI-Grovel, hacks used by ironclad, etc. -Since it isn't possible to automatically detect what extensions -need to be invalidated, -ASDF will invalidate @emph{all} previously loaded systems -when it is loaded on top of a forward-incompatible ASDF version. -@footnote{ -@vindex *oldest-forward-compatible-asdf-version* -Forward incompatibility can be determined using the variable -@code{asdf/upgrade::*oldest-forward-compatible-asdf-version*}, -which is 2.33 at the time of this writing.} - -Starting with ASDF 3 (2.27 or later), -this self-upgrade will be automatically attempted as the first step -to any system operation, to avoid any possibility of -a catastrophic attempt to self-upgrade in mid-build. - -@c FIXME: Fix grammar below. -@item -For this and many other reasons, -you should load, configure and upgrade ASDF -as one of the very first things done by your build and startup scripts. -It is safer if you upgrade ASDF and its extensions as a special step -at the very beginning of whatever script you are running, -before you start using ASDF to load anything else. - -@item -Until all implementations provide ASDF 3 or later, -it is unsafe to upgrade ASDF as part of loading a system -that depends on a more recent version of ASDF, -since the new one might shadow the old one while the old one is running, -and the running old one will be confused -when extensions are loaded into the new one. -In the meantime, we recommend that your systems should @emph{not} specify -@code{:depends-on (:asdf)}, or @code{:depends-on ((:version :asdf "3.0.1"))}, -but instead that they check that a recent enough ASDF is installed, -with such code as: -@example -(unless (or #+asdf2 (asdf:version-satisfies - (asdf:asdf-version) *required-asdf-version*)) - (error "FOO requires ASDF ~A or later." *required-asdf-version*)) -@end example -@item -Until all implementations provide ASDF 3 or later, -it is unsafe for a system to transitively depend on ASDF -and not directly depend on ASDF; -if any of the system you use either depends-on asdf, -system-depends-on asdf, or transitively does, -you should also do as well. -@end itemize - -@node Loading ASDF from source, , Upgrading ASDF, Loading ASDF +@node Loading ASDF from source, , Replacing your implementation's ASDF, Loading ASDF @section Loading ASDF from source -If your implementation doesn't include ASDF, -if for some reason the upgrade somehow fails, -does not or cannot apply to your case, -you will have to install the file @file{asdf.lisp} +If you write build scripts that must remain portable to old machines with old implementations +that you cannot ensure have been upgraded or modified to provide a recent ASDF, +you may have to install the file @file{asdf.lisp} somewhere and load it with: @lisp @@ -598,15 +535,15 @@ somewhere and load it with: The single file @file{asdf.lisp} is all you normally need to use ASDF. You can extract this file from latest release tarball on the -@url{http://common-lisp.net/project/asdf/,ASDF website}. +@url{https://common-lisp.net/project/asdf/,ASDF website}. If you are daring and willing to report bugs, you can get the latest and greatest version of ASDF from its git repository. @xref{Getting the latest version}. -For maximum convenience you might want to have ASDF loaded -whenever you start your Lisp implementation, -for example by loading it from the startup script or dumping a custom core ---- check your Lisp implementation's manual for details. +For scripts that try to use ASDF simply via @code{require} at first, and +make heroic attempts to load it the hard way if at first they don't succeed, +see @file{tools/load-asdf.lisp} distributed with the ASDF source repository, +or the code of @url{https://cliki.net/cl-launch,@code{cl-launch}}. @node Configuring ASDF, Using ASDF, Loading ASDF, Top @@ -640,8 +577,8 @@ ASDF, starting from easiest to the most complex: @itemize @bullet @item -Put all of your systems in one of the standard locations, subdirectories -of +Put all of your systems in one of the standard locations, +subdirectories of @itemize @item @file{~/common-lisp/} or @@ -649,9 +586,15 @@ of @file{~/.local/share/common-lisp/source/}. @end itemize If you install software there, you don't need further -configuration.@footnote{@file{~/common-lisp/} is only included in -the default configuration -starting with ASDF 3.1.2 or later.} +configuration.@footnote{ + @file{~/common-lisp/} is only included in + the default configuration + starting with ASDF 3.1.2 or later. + If your implementation provides an earlier variant of ASDF, + you may need to explicitly configure it to use this path, + as further explained. +} +You can then skip to the next section. @xref{Loading a system}. @item If you're using some tool to install software (e.g. Quicklisp), @@ -662,34 +605,49 @@ If you have more specific desires about how to lay out your software on disk, the preferred way to configure where ASDF finds your systems is the @code{source-registry} facility, fully described in its own chapter of this manual. -@xref{Controlling where ASDF searches for systems}. Here is a quick -recipe for getting started: +@xref{Controlling where ASDF searches for systems}. +Here is a quick recipe for getting started. -The simplest way to add a path to your search path, -say @file{/home/luser/.asd-link-farm/} -is to create the directory -@file{~/.config/common-lisp/source-registry.conf.d/} -and there create a file with any name of your choice, -and with the type @file{conf}@footnote{By requiring the @file{.conf} -extension, and ignoring other files, ASDF allows you to have disabled files, -editor backups, etc. in the same directory with your active -configuration files. +First create the directory +@file{~/.config/common-lisp/source-registry.conf.d/}@footnote{ + For Windows users, and starting with ASDF 3.1.5, start from your + @file{%LOCALAPPDATA%}, which is usually @file{~/AppData/Local/} + (but you can ask in a @code{CMD.EXE} terminal + @code{echo %LOCALAPPDATA%} to make sure) + and underneath create a subpath + @file{config/common-lisp/source-registry.conf.d/}. +}; +there create a file with any name of your choice +but with the type @file{conf}@footnote{ + By requiring the @file{.conf} + extension, and ignoring other files, ASDF allows you to have disabled files, + editor backups, etc. in the same directory with your active + configuration files. -ASDF will also ignore files whose names start with a @file{.} character. - -It is customary to start the filename with two digits, to control the -sorting of the @code{conf} files in the source registry directory, and -thus the order in which the directories will be scanned.}, -for instance @file{42-asd-link-farm.conf}, -containing the line: - -@kbd{(:directory "/home/luser/.asd-link-farm/")} - -If you want all the subdirectories under @file{/home/luser/lisp/} -to be recursively scanned for @file{.asd} files, instead use: + ASDF will also ignore files whose names start with a @file{.} character. + It is customary to start the filename with two digits, to control the + sorting of the @code{conf} files in the source registry directory, and + thus the order in which the directories will be scanned. +}, +for instance @file{50-luser-lisp.conf}; +in this file, add the following line +to tell ASDF to recursively scan all the subdirectories under @file{/home/luser/lisp/} +for @file{.asd} files: @kbd{(:tree "/home/luser/lisp/")} +That's enough. You may replace @file{/home/luser/lisp/} by wherever you want to install your source code. +You don't actually need to specify anything if you use the default @file{~/common-lisp/} as above +and your implementation provides ASDF 3.1.2 or later. +If your implementation provides an earlier variant of ASDF 3, +you might want to specify @kbd{(:tree (:home "common-lisp/"))} for bootstrap purposes, +then install a recent source tree of ASDF under @file{~/common-lisp/asdf/}. + +If you prefer to use a ``link farm'', which is faster to use but costlier to manage than a recursive traversal, +say at @file{/home/luser/.asd-link-farm/}, then +you may instead (or additionally) create a file @file{42-asd-link-farm.conf}, containing the line: +@kbd{(:directory "/home/luser/.asd-link-farm/")} + ASDF will automatically read your configuration the first time you try to find a system. If necessary, you can reset the source-registry configuration with: @@ -789,8 +747,9 @@ instead of pushing each individual system directory. ASDF knows to follow @emph{symlinks} to the actual location of the systems.@footnote{ -On Windows, you can use Windows shortcuts instead of POSIX symlinks. -if you try aliases under MacOS, we are curious to hear about your experience.} + On Windows, you can use Windows shortcuts instead of POSIX symlinks. + if you try aliases under MacOS, we are curious to hear about your experience. +} For example, if @code{#p"/home/me/cl/systems/"} is an element of @code{*central-registry*}, you could set up the @@ -802,8 +761,8 @@ $ ln -s ~/src/foo/foo.asd . @end example This old style for configuring ASDF is not recommended for new users, -but it is supported for old users, and for users who want to programmatically -control what directories are added to the ASDF search path. +but it is supported for old users, and for users who want a simple way to +programmatically control what directories are added to the ASDF search path. @node Configuring where ASDF stores object files, Resetting the ASDF configuration, Configuring ASDF to find your systems --- old style, Configuring ASDF @@ -921,11 +880,11 @@ on CMUCL and SCL, etc. @menu * Loading a system:: -* Other Operations:: +* Convenience Functions:: * Moving on:: @end menu -@node Loading a system, Other Operations, Using ASDF, Using ASDF +@node Loading a system, Convenience Functions, Using ASDF, Using ASDF @section Loading a system The system @var{foo} is loaded (and compiled, if necessary) @@ -935,26 +894,18 @@ by evaluating the following Lisp form: (asdf:load-system :@var{foo}) @end example -On some implementations (namely recent versions of -ABCL, Clozure CL, CMUCL, ECL, GNU CLISP, MKCL and SBCL), -ASDF hooks into the @code{CL:REQUIRE} facility -and you can just use: +On some implementations (@pxref{Convenience Functions}), +ASDF hooks into the @code{cl:require} facility and you can just use: @example (require :@var{foo}) @end example -In older versions of ASDF, you needed to use -@code{(asdf:oos 'asdf:load-op :@var{foo})}. -If your ASDF is too old to provide @code{asdf:load-system} though -we recommend that you upgrade to ASDF 3. -@xref{Loading ASDF,,Loading ASDF from source}. - -Note the name of a system is specified as a string or a symbol. -If a symbol (including a keyword), its name is taken and lowercased. +Note that the canonical name of a system is a string, conventionally lowercase. +A system name can also be specified as a symbol (including a keyword), +in which case its @code{symbol-name} is taken and lowercased. The name must be a suitable value for the @code{:name} initarg -to @code{make-pathname} in whatever filesystem the system is to be -found. +to @code{make-pathname} in whatever filesystem the system is to be found. The lower-casing-symbols behaviour is unconventional, but was selected after some consideration. @@ -964,58 +915,143 @@ or silently convert lowercase to uppercase (lpns). @c so this makes more sense than attempting to use @code{:case :common}, @c which is reported not to work on some implementations -@node Other Operations, Moving on, Loading a system, Using ASDF -@section Other Operations -@findex load-system -@findex compile-system -@findex test-system -@findex requrie-system +@node Convenience Functions, Moving on, Loading a system, Using ASDF +@section Convenience Functions + +@c I believe thes are all unnecessary because of the function macros +@c below [2016/01/30:rpg] +@c @findex load-system +@c @findex compile-system +@c @findex test-system +@c @findex require-system +@c @findex make ASDF provides three commands for the most common system operations: @code{load-system}, @code{compile-system}, and @code{test-system}. -It also provides @code{require-system}, a version of @code{load-system} -that skips trying to update systems that are already loaded. -@c FIXME: We seem to export @findex bundle-system also. +ASDF also provides @code{require-system}, a variant of @code{load-system} +that skips loading systems that are already loaded. This is sometimes +useful, for example, in order to avoid re-loading libraries that come +pre-loaded into your lisp implementation. +ASDF also provides @code{make}, a way of allowing system developers to +choose a default operation for their systems. For example, a developer +who has created a system intended to format a specific document, might +make document-formatting the default operation invoked by @code{make}, +instead of loading. If the system developer doesn't specify in the +system definition, the default operation will be loading. + +@c FIXME: We seem to export @findex bundle-system also, that some ECL users seem to rely on. +@c But it's probably better that bundle operations have their own manual chapter at some point. + + +@c FIXME: There should be a @defun for OPERATE, but there isn't. Not +@c sure where it belongs... The discussion here is just confusing if +@c the reader doesn't understand how ASDF works. [2016/01/30:rpg] @findex operate @findex oos Because ASDF is an extensible system for defining @emph{operations} on @emph{components}, -it also provides a generic function @code{operate} -(which is usually abbreviated by @code{oos}, -which stands for operate-on-system). -You'll use @code{oos} whenever you want to do something beyond +it also provides a generic function @code{operate}, +so you may arbitrarily operate on your systems beyond the default operations. +(At the interactive REPL, users often use its shorter alias @code{oos}, +which stands for operate-on-system, a name inherited from @code{mk-defsystem}.) +You'll use @code{operate} whenever you want to do something beyond compiling, loading and testing. -Output from ASDF and ASDF extensions are sent -to the CL stream @code{*standard-output*}, -so rebinding that stream around calls to @code{asdf:operate} -should redirect all output from ASDF operations. - @c Reminder: before ASDF can operate on a system, however, @c it must be able to find and load that system's definition. -@c @xref{Configuring ASDF,,Configuring ASDF to find your systems}. +@c @xref{Configuring ASDF to find your systems}. @c FIXME: the following is too complicated for here, especially since @c :force hasn't been defined yet. Move it. [2014/02/27:rpg] -@findex already-loaded-systems -@findex require-system -@findex load-system @vindex *load-system-operation* -For advanced users, note that -@code{require-system} calls @code{load-system} -with keyword arguments @code{:force-not (already-loaded-systems)}. -@code{already-loaded-systems} returns a list of the names of loaded systems. -@code{load-system} applies @code{operate} with the operation from -@code{*load-system-operation*} (which by default is @code{load-op}), -the system, and any provided keyword arguments. +@findex already-loaded-systems + +@defun load-system system @Arest{} keys @Akey{} force force-not verbose version @AallowOtherKeys{} +Apply @code{operate} with the operation from +@code{*load-system-operation*} +the @var{system}, and any provided keyword arguments. +@code{*load-system-operation*} by default is @code{load-op}; +it would be @code{load-bundle-op} by default on ECL, +if only an implementation bug were fixed. +Calling @code{load-system} is the regular, recommended way +to load a system into the current image. +@end defun + +@defun compile-system system @Arest{} keys @Akey{} force force-not verbose version @AallowOtherKeys{} +Apply @code{operate} with the operation @code{compile-op}, +the @var{system}, and any provided keyword arguments. +This will make sure all the files in the system are compiled, +but not necessarily load any of them in the current image; +on most systems, it will @emph{not} load all compiled files in the current image. +This function exists for symmetry with @code{load-system} but is not recommended +unless you are writing build scripts and know what you're doing. +But then, you might be interested in @code{program-op} rather than @code{compile-op}. +@end defun + +@defun test-system system @Arest{} keys @Akey{} force force-not verbose version @AallowOtherKeys{} +Apply @code{operate} with the operation @code{test-op}, +the @var{system}, and any provided keyword arguments. +@xref{test-op}. +@end defun + +@defun make system @Arest{} keys @Akey{} @AallowOtherKeys{} +Do ``The Right Thing'' with your system. +Starting with ASDF 3.1, this function @code{make} is also available. +The default behaviour is to load the system as if by @code{load-system}; +but system authors can override this default in their system definition +they may specify an alternate operation as the intended use of their system, +with a @code{:build-operation} option in the @code{defsystem} form +(@pxref{The defsystem grammar, build-operation}), +and an intended output pathname for that operation with +@code{:build-pathname}. +@c Document :build-operation in the defsystem section. +@c Document in the extension section that for richer programmatic access, you may instead use an overriding +@c @code{(defmethod component-depends-on ((o build-op) (s system)) +@c ...)}. +This function is experimental and largely untested. Use at your own risk. +@end defun +@cindex build-operation + +@defun require-system system @Arest{} keys @Akey{} @AallowOtherKeys{} +@code{require-system} skips any update to systems that have already been loaded, +in the spirit of @code{cl:require}. +It does it by calling @code{load-system} with a keyword option +excluding already loaded systems.@footnote{ + For the curious, the option is @code{:force-not (already-loaded-systems)}. +}. +On actively maintained free software implementations +(namely recent versions of ABCL, Clozure CL, CMUCL, ECL, GNU CLISP, MKCL and SBCL), +once ASDF itself is loaded, @code{cl:require} too can load ASDF systems, +by falling back on @code{require-system} +for module names not recognized by the implementation. +(Note however that @code{require-system} does @emph{not} fall back on @code{cl:require}; +that would introduce an ``interesting'' potential infinite loop to break somehow.) + +@code{cl:require} and @code{require-system} are appropriate to load code +that is not being modified during the current programming session. +@code{cl:require} will notably load the implementation-provided extension modules; +@code{require-system} won't, unless they are also defined as systems somehow, +which SBCL and MKCL do. +@code{require-system} may also be used to load any number of ASDF systems +that the user isn't either developing or debugging, +for which a previously installed version is deemed to be satisfactory; +@code{cl:require} on the above-mentioned implementations will delegate to @code{require-system} +and may load them as well. +But for code that you are actively developing, debugging, or otherwise modifying, +you should use @code{load-system}, so ASDF will pick on your modifications +and transitively re-build the modified files and everything that depends on them +(that the requested @var{system} itself depends on --- +ASDF itself never builds anything unless +it's an explicitly requested system or the dependencies thereof). +@end defun -@node Moving on, , Other Operations, Using ASDF +@node Moving on, , Convenience Functions, Using ASDF @section Moving on That's all you need to know to use ASDF to load systems written by others. @@ -1055,17 +1091,15 @@ This is a complete file that should be saved as @file{hello-lisp.asd} (in order that ASDF can find it when ordered to operate on the system named @code{"hello-lisp"}). -@c FIXME: the first example should have an outside dependency, e.g., -@c CL-PPCRE. - @lisp -(in-package :asdf-user) +;; Usual Lisp comments are allowed here (defsystem "hello-lisp" :description "hello-lisp: a sample Lisp system." :version "0.0.1" :author "Joe User " :licence "Public Domain" + :depends-on ("optima.ppcre" "command-line-arguments") :components ((:file "packages") (:file "macros" :depends-on ("packages")) (:file "hello" :depends-on ("macros")))) @@ -1075,63 +1109,14 @@ Some notes about this example: @itemize -@item -The file starts with an @code{in-package} form -for package @code{asdf-user}. Quick summary: just do this, because it -helps make interactive development of @code{defsystem} forms behave in -the same was as when these forms are loaded by ASDF. If that's enough -for you, skip the rest of this item. Otherwise read on for the gory details. - -If your file is loaded by ASDF 3, it will be loaded into the -@code{asdf-user} package. The @code{in-package} form -will ensure that the system definition is read the -same as within ASDF when you load it interactively with @code{cl:load}. -However, we recommend that you load @file{.asd} files -through function @code{asdf::load-asd} rather than through @code{cl:load}, -in which case this form is unnecessary. -Recent versions of SLIME (2013-02 and later) know to do that. - -@item -You can always rely on symbols -from both package @code{asdf} and @code{common-lisp} being available in -@code{.asd} files -- -most importantly including @code{defsystem}. - -@c FIXME: the following should be inserted in a more advanced -@c bit of the manual. For now, it is simply elided. -@c Starting with ASDF 3.1, -@c @file{.asd} files are read in the package @code{asdf-user} -@c that uses @code{asdf}, @code{uiop} and @code{uiop/common-lisp} -@c (a variant of @code{common-lisp} -@c that has some portability fixes on old implementations). -@c ASDF 3 releases before 3.1 also read in package @code{asdf-user} -@c but that package don't use the full @code{uiop}, only @code{uiop/package}. -@c ASDF 1 and ASDF 2 releases (up until 2.26) instead read @file{.asd} files -@c in a temporary package @code{asdf@emph{N}} -@c that uses @code{asdf} and @code{common-lisp}. -@c You may thus have to package-qualify some symbols with @code{uiop:} -@c to support older variants of ASDF 3, -@c and/or package-qualify them with @code{asdf::} -@c to be compatible with even older variants of ASDF 2 -@c (and then only use the few already available in ASDF 2). - - @item The @code{defsystem} form defines a system named @code{hello-lisp} that contains three source files: -@file{packages}, @file{macros} and @file{hello}. - -@c FIXME: The first example system should probably use just :serial T. -@item -The file @file{macros} depends on @file{packages} -(presumably because the package it's in is defined in @file{packages}), -and the file @file{hello} depends on @file{macros} -(and hence, transitively on @file{packages}). -This means that ASDF will compile and load @file{packages} and @file{macros} -before starting the compilation of file @file{hello}. +@file{packages.lisp}, @file{macros.lisp} and @file{hello.lisp}. @item -System source files should be located in the same directory +The @file{.lisp} suffix is implicit for Lisp source files. +The source files are located in the same directory as the @code{.asd} file with the system definition. @c FIXME: the following should live somewhere, but not in the quickstart @c page. [2014/05/03:rpg] @@ -1142,6 +1127,30 @@ as the @code{.asd} file with the system definition. @c This is a good thing because the user can move the system sources @c without having to edit the system definition. +@c FIXME: The first example system should probably use just :serial T. +@item +The file @file{macros} depends on @file{packages} +(presumably because the package it's in is defined in @file{packages}), +and the file @file{hello} depends on @file{macros} +(and hence, transitively on @file{packages}). +This means that ASDF will compile and load @file{packages} then @file{macros} +before starting the compilation of file @file{hello}. + +@item +This example system has external dependencies on two other systems, +@code{optima.ppcre} (that provides a friendly interface to matching regular expressions), +and @code{command-line-arguments} (that provides a way to parse arguments passed from the shell command line). +To use this system, ASDF must be configured to find installed copies of these systems; +it will load them before it tries to compile and load @code{hello-lisp}. + +@item +This system also defines a bunch of metadata. +While it is optional to define these fields +(and other fields like @code{:bug-tracker}, @code{:mailto}, @code{:long-name}, +@code{:long-description}, @code{:source-control}), +it is strongly recommended to define the fields @code{:description}, @code{:version}, @code{:author}, and @code{:licence}, +especially if you intend your software to be eventually included in Quicklisp. + @c FIXME: Should have cross-reference to "Version specifiers" in the @c defsystem grammar, but the cross-referencing is so broken by @c insufficient node breakdown that I have not put one in. @@ -1149,12 +1158,28 @@ as the @code{.asd} file with the system definition. @c move it! @item Make sure you know how the @code{:version} numbers will be parsed! -Only period-separated non-negative integers are accepted. +Only period-separated non-negative integers are accepted at present. See below Version specifiers in @ref{The defsystem grammar}. + +@item +This file contains a single form, the @code{defsystem} declaration. +No @code{in-package} form, no @code{asdf:} package prefix, no nothing. +Just the one naked @code{defsystem} form. +This is what we recommend. +More complex system definition files are possible with arbitrary Lisp code, +but we recommend that you keep it simple if you can. +This will make your system definitions more robust and more future-proof. + @cindex :version @end itemize +This is all you need to know to define simple systems. +The next example is much more involved, to give you a glimpse of how you can do more complex things. +However, since it's ultimately arbitrary Lisp code, there is no bottom to the rabbit hole. +@c FIXME: divide the next example into many examples, to introduce fewer concepts at once. + + @node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem @comment node-name, next, previous, up @section A more involved example @@ -1167,40 +1192,80 @@ slightly convoluted example: (in-package :asdf-user) (defsystem "foo" - :version "1.0.0" - :components ((:module "mod" - :components ((:file "bar") - (:file"baz") - (:file "quux")) - :perform (compile-op :after (op c) - (do-something c)) - :explain (compile-op :after (op c) - (explain-something c))) - (:file "blah"))) + :version (:read-file-form "variables" :at (3 2)) + :components + ((:file "package") + (:file "variables" :depends-on ("package")) + (:module "mod" + :depends-on ("package") + :serial t + :components ((:file "utils") + (:file "reader") + (:file "cooker") + (:static-file "data.raw")) + :output-files (compile-op (o c) (list "data.cooked")) + :perform (compile-op :after (o c) + (cook-data + :in (component-pathname (find-component c "data.raw")) + :out (first (output-files o c))))) + (:file "foo" :depends-on ("mod")))) + +(defmethod action-description + ((o compile-op) (c (eql (find-component "foo" "mod")))) + "cooking data") @end lisp -The @code{:module} component named @code{"mod"} is a collection of three files, -which will be located in a subdirectory of the main code directory named -@file{mod} (this location can be overridden; see the discussion of the -@code{:pathname} option in @ref{The defsystem grammar}). +Here are some notes about this example: +@itemize + +@item +The main thing this file does is define a system @code{foo}. +It also contains other Lisp forms, which we'll examine below. + +@item +Besides Lisp source files, this system contains a @code{:module} component +named @code{"mod"}, which is a collection of three Lisp source files +@file{utils.lisp}, @file{reader.lisp}, @file{cooker.lisp} and @file{data.raw} + +@item +Note that the @code{:static-file} does not have an implicit file type, +unlike the Lisp source files. + +@item +This files will be located in a subdirectory of the main code directory named +@file{mod/} (this location could have been overridden to be +in the same directory, or in a different subdirectory; +see the discussion of the @code{:pathname} option in @ref{The defsystem grammar}). + +@item +The @code{:serial t} says that each sub-component of @code{mod} depends on the previous components, +so that @file{cooker.lisp} depends-on @file{utils.lisp}, which depends-on @file{reader.lisp}. +Also @file{data.raw} depends on all of them, but that doesn't matter since it's a static file; +on the other hand, if it appeared first, then all the Lisp files would be recompiled +when the data is modified, which is probably not what is desired in this case. + +@item The method-form tokens provide a shorthand for defining methods on particular components. This part @lisp - :perform (compile-op :after (op c) - (do-something c)) - :explain (compile-op :after (op c) - (explain-something c)) + :output-files (compile-op (o c) (list "data.cooked")) + :perform (compile-op :after (o c) + (cook-data + :in (component-pathname (find-component c "data.raw")) + :out (first (output-files o c)))) @end lisp has the effect of @lisp -(defmethod perform :after ((op compile-op) (c (eql ...))) - (do-something c)) -(defmethod explain :after ((op compile-op) (c (eql ...))) - (explain-something c)) +(defmethod output-files ((o compile-op) (c (eql ...))) + (list "data.cooked")) +(defmethod perform :after ((o compile-op) (c (eql ...))) + (cook-data + :in (component-pathname (find-component c "data.raw")) + :out (first (output-files o c)))) @end lisp where @code{...} is the component in question. @@ -1210,11 +1275,17 @@ In this case @code{...} would expand to something like (find-component "foo" "mod") @end lisp -For more details on the syntax of such forms, see @ref{The defsystem -grammar}. +For more details on the syntax of such forms, +@pxref{The defsystem grammar}. For more details on what these methods do, @pxref{Operations} in @ref{The object model of ASDF}. +@item +There is an additional @code{defmethod} with a similar effect, +because ASDF (as of ASDF 3.1.5) +fails to accept inline-methods as above for @code{action-description}, +instead only supporting the deprecated @code{explain} interface. + @c FIXME: The following plunge into detail weeds is not appropriate in this @c location. [2010/10/03:rpg] @c note that although this also supports @code{:before} methods, @@ -1223,22 +1294,90 @@ For more details on what these methods do, @pxref{Operations} in @c will run after all the dependencies and sub-components have been processed, @c but before the component in question has been compiled. +@item +In this case, these methods describe how this module defines code +that it then uses to cook some data. -@c FIXME: There should be YA example that shows definitions of functions -@c and classes. The following material should go there. -@c @item -@c If in addition to simply using @code{defsystem}, -@c you are going to define functions, -@c create ASDF extension, globally bind symbols, etc., -@c it is recommended that to avoid namespace pollution between systems, -@c you should create your own package for that purpose, with: +@item +Importantly, ASDF is told about the input and output files +used by the data cooker, +and to make sure everyone agrees, +the cooking function explicitly uses ASDF to access pathnames +to the input and output data. -@c @lisp -@c (defpackage :hello-lisp-system -@c (:use :cl :asdf)) +@c FIXME: move most of this package discussion to its own section, +@c and leave only a reference here. -@c (in-package :hello-lisp-system) -@c @end lisp +@item +The file starts with a form @code{(in-package :asdf-user)}, +but it is actually redundant, not necessary and not recommended. +But yet more complex cases (also not recommended) may usefully use an @code{in-package} form. + +@item +Indeed, ASDF does not load @file{.asd} files simply with @code{cl:load}, +and neither should you. +You should let ASDF find and load them when you operate on systems. +If you somehow @emph{must} load a @file{.asd} file, +use the same function @code{asdf:load-asd} that ASDF uses. +Among other things, it already binds the @code{*package*} to @code{asdf-user}. +Recent versions of SLIME (2013-02 and later) know to do that when you @kbd{C-c C-k} +when you use the @code{slime-asdf} contrib. + +@item +You shouldn't use an @code{in-package} form +if you're keeping things simple. +You should only use @code{in-package} (and before it, a @code{defpackage}) +when you're going to define new classes, functions, variables, macros, etc., +in the @code{.asd} file, and want to thereby avoid name clashes. +Manuals for old versions of ASDF recommended use of such an idiom in @file{.asd} files, +but as of ASDF 3, we recommend that you don't do that anymore, +and instead define any ASDF extensions in their own system, +on which you can then declare a dependency using @code{:defsystem-depends-on}. +@xref{The defsystem grammar}. + +@item +More generally, you can always rely on symbols +from packages @code{asdf}, @code{common-lisp} and @code{uiop} +being available in @code{.asd} files --- +most importantly including @code{defsystem}. +It is therefore redundant and in bad taste to use a package-prefixed @code{asdf:defsystem} symbol +in a @file{.asd} file. +Just use @code{(defsystem ...)}. +Only package-prefix it when somehow dynamically generating system definitions +from a package that doesn't already use the ASDF package. + +@item +@code{asdf-user} is actually only available starting since ASDF 3, but then again, +ASDF 1 and 2 did crazy things with packages that ASDF 3 has stopped doing@footnote{ + ASDF 1 and 2 (up until 2.26) + used to dynamically create and delete temporary packages @code{asdf@emph{N}}, + one for each @file{.asd} file, in a misguided attempt to thereby reduce name clashes; + but it failed at that goal and only made things more complex. + ASDF 3 just uses a shared package @code{asdf-user} instead, + and relies on the usual Common Lisp conventions to avoid clashes. + As far as package oddities go, you may just notice that + the @code{asdf-user} package also uses @code{uiop/common-lisp}, + a variant of the @code{common-lisp} package that papers over + deficiencies in more obscure Common Lisp implementations; + but unless you care about Corman Lisp, GCL, Genera or MCL, you shouldn't be concerned. +}, +and since all implementations provide ASDF 3, you shouldn't care about compatibility with ASDF 2. +We do not support ASDF 2 anymore, and we recommend that neither should you. + +@item +Starting with ASDF 3.1, @code{asdf-user} uses @code{uiop}, +whereas in earlier variants of ASDF 3 it only used @code{uiop/package}. +We recommend you either prefix use of UIOP functions with the package prefix @code{uiop:}, +or make sure your system @code{:depends-on ((:version "asdf" "3.1.2"))} +or has a @code{#-asdf3.1 (error "MY-SYSTEM requires ASDF 3.1.2")}. + +@item +Finally, we elided most metadata, but showed how you can have ASDF automatically extract +the system's version from a source file. In this case, the 3rd subform of the 4th form +(note that Lisp uses 0-based indexing, English uses 1-based indexing). +Presumably, the 4th form looks like @code{(defparameter *foo-version* "5.6.7")}. + +@end itemize @node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem @@ -1257,9 +1396,21 @@ system-definition := ( defsystem system-designator @var{system-option}* ) system-option := :defsystem-depends-on system-list | :weakly-depends-on @var{system-list} | :class class-name (see discussion below) + | :build-operation @var{operation-name} + | system-option | module-option | option +# These are only available since ASDF 3 (actually its alpha release 2.27) +system-option := :homepage string + | :bug-tracker string + | :mailto string + | :long-name string + | :source-control source-control + | :version version-specifier + +source-control := (keyword string) + module-option := :components component-list | :serial [ t | nil ] @@ -1306,7 +1457,7 @@ simple-component-name := string pathname-specifier := pathname | string | symbol method-form := (operation-name qual lambda-list @Arest{} body) -qual := method qualifier +qual := method qualifier? component-dep-fail-option := :fail | :try-next | :ignore @@ -1363,6 +1514,18 @@ must be loaded @emph{before} the system definition is processed. Typically this is used to load an ASDF extension that is used in the system definition. +@subsection Build-operation +@cindex :build-operation + +The @code{:build-operation} option to @code{defsystem} allows the +programmer to specify an operation that will be applied, in place of +@code{load-op} when @code{make} (@pxref{Convenience Functions, make}) +is run on the system. The option +value should be the name of an operation. E.g., @code{:build-operation doc-op} + +This feature is +experimental and largely untested. Use at your own risk. + @subsection Weakly depends on @cindex :weakly-depends-on @@ -1371,7 +1534,7 @@ If you are tempted to write a system @var{foo} that weakly-depends-on a system @var{bar}, we recommend that you should instead write system @var{foo} in a parametric way, -and offer some special variable and/or some hook to specialize its behavior; +and offer some special variable and/or some hook to specialize its behaviour; then you should write a system @var{foo+bar} that does the hooking of things together. @@ -1388,13 +1551,13 @@ this option is accepted at any component, but it probably only makes sense at the @code{defsystem} level. Programmers are cautioned not to use this component option except at the @code{defsystem} level, as -this anomalous behavior may be removed without warning. +this anomalous behaviour may be removed without warning. @c Finally, you might look into the @code{asdf-system-connections} extension, @c that will let you define additional code to be loaded @c when two systems are simultaneously loaded. @c It may or may not be considered good style, but at least it can be used -@c in a way that has deterministic behavior independent of load order, +@c in a way that has deterministic behaviour independent of load order, @c unlike @code{weakly-depends-on}. @@ -1452,9 +1615,9 @@ Such objects are typically specified using reader macros such as @code{#p} or @code{#.(make-pathname ...)}. Note however, that @code{#p...} is a shorthand for @code{#.(parse-namestring ...)} -and that the behavior of @code{parse-namestring} is completely non-portable, +and that the behaviour of @code{parse-namestring} is completely non-portable, unless you are using Common Lisp @code{logical-pathname}s, -which themselves involve other non-portable behavior +which themselves involve other non-portable behaviour (@pxref{The defsystem grammar,,Using logical pathnames}, below). Pathnames made with @code{#.(make-pathname ...)} can usually be done more easily with the string syntax above. @@ -1516,6 +1679,11 @@ where significant API incompatibilities are signaled by an increased major numbe Use the implementation's own @code{require} to load the @var{module-name}. +It is good taste to use @code{:if-feature @emph{:implementation-name}} +rather than @code{#+@emph{implementation-name}} +to only depend on the specified module on the specific implementation that provides it. +@xref{if-feature-option}. + @subsection Using logical pathnames @cindex logical pathnames @@ -1554,7 +1722,7 @@ ASDF currently provides no specific support for defining logical pathname translations. Note that the reasons we do not recommend logical pathnames are that -(1) there is no portable way to set up logical pathnames before they are used, +(1) there is no portable way to set up logical pathnames @emph{before} they are used, (2) logical pathnames are limited to only portably use a single character case, digits and hyphens. While you can solve the first issue on your own, @@ -1731,7 +1899,6 @@ whereby each file is its own system, and dependencies are deduced from the @code{defpackage} form (or its variant @code{uiop:define-package}). - In this style, packages refer to a system with the same name (downcased); and if a system is defined with @code{:class package-inferred-system}, then system names that start with that name @@ -1744,40 +1911,36 @@ will be found in file @file{/foo/bar/my-lib/src/utility.lisp}. This style was made popular by @code{faslpath} and @code{quick-build} before, and at the cost of a stricter package discipline, seems to make for more maintainable code. -It is used by ASDF itself (starting with ASDF 3) and by @code{lisp-interface-library}. +It is used by ASDF itself (starting with ASDF 3), by @code{lisp-interface-library}, +and a few other libraries. To use this style, choose a toplevel system name, e.g. @code{my-lib}, and create a file @file{my-lib.asd} with the @code{:class :package-inferred-system} option in its @code{defsystem}. For instance: @example -#-asdf3 (error "my-lib requires ASDF 3") -(defsystem my-lib +#-asdf3.1 (error "my-lib requires ASDF 3.1") +(defsystem "my-lib" :class :package-inferred-system - :defsystem-depends-on (:asdf-package-system) - :depends-on (:my-lib/interface/all - :my-lib/src/all - :my-lib/extras/all) - :in-order-to ((test-op (load-op :my-lib/test/all))) + :depends-on ("my-lib/interface/all" + "my-lib/src/all" + "my-lib/extras/all") + :in-order-to ((test-op (load-op "my-lib/test/all"))) :perform (test-op (o c) (symbol-call :my-lib/test/all :test-suite))) -(defsystem :my-lib/test :depends-on (:my-lib/test/all)) +(defsystem "my-lib/test" :depends-on ("my-lib/test/all")) -(register-system-packages :my-lib/interface/all '(:my-lib-interface)) -(register-system-packages :my-lib/src/all '(:my-lib-implementation)) -(register-system-packages :my-lib/test/all '(:my-lib-test)) +(register-system-packages "my-lib/interface/all" '(:my-lib-interface)) +(register-system-packages "my-lib/src/all" '(:my-lib-implementation)) +(register-system-packages "my-lib/test/all" '(:my-lib-test)) (register-system-packages - :closer-mop + "closer-mop" '(:c2mop :closer-common-lisp :c2cl :closer-common-lisp-user :c2cl-user)) @end example -In the code above, the -@code{:defsystem-depends-on (:asdf-package-system)} is -for compatibility with older versions of ASDF 3 (ASDF 2 is not supported), -and requires the @code{asdf-package-system} library to be present -(it is implicitly provided by ASDF starting with release 3.1.2, -which can be detected with the feature @code{:asdf3.1}). +In the code above, the first line checks that we are using ASDF 3.1, +which provides @code{package-inferred-system}. The function @code{register-system-packages} has to be called to register packages used or provided by your system and its components @@ -1824,6 +1987,15 @@ and has many options that prove useful in this context, such as @code{:use-reexport} and @code{:mix-reexport} that allow for ``inheritance'' of symbols being exported. +Note that starting with ASDF 3.1.5.6 only, ASDF will look for source files under +the @code{component-pathname} as specified via the @code{:pathname} option, +whereas earlier versions ignore this option and use the @code{system-source-directory} +where the @file{.asd} file resides. + +@c See this blog post about it: +@c @url{http://davazp.net/2014/11/26/modern-library-with-asdf-and-package-inferred-system.html} + + @node The object model of ASDF, Controlling where ASDF searches for systems, Defining systems with defsystem, Top @comment node-name, next, previous, up @chapter The Object model of ASDF @@ -1832,10 +2004,10 @@ that allow for ``inheritance'' of symbols being exported. ASDF is designed in an object-oriented way from the ground up. Both a system's structure and the operations that can be performed on systems -follow a extensible protocol, allowing programmers to add new behaviors to ASDF. +follow a extensible protocol, allowing programmers to add new behaviours to ASDF. For example, @code{cffi} adds support for special FFI description files that interface with C libraries and for wrapper files that embed C code in Lisp. -@code{abcl-jar} supports creating Java JAR archives in ABCL. +@code{asdf-jar} supports creating Java JAR archives in ABCL. @code{poiu} supports compiling code in parallel using background processes. The key classes in ASDF are @code{component} and @code{operation}. @@ -1852,8 +2024,9 @@ by traversing the dependency graph using function @code{make-plan}.@footnote{ Historically, the function that built a plan was called @code{traverse}, and returned a list of actions; it was deprecated in favor of @code{make-plan} (that returns a plan object) - when the @code{plan} objects were introduced; - the old function is kept for backward compatibility and debugging purposes only. + when the @code{plan} objects were introduced with ASDF 3; + the old function is kept for backward compatibility and debugging purposes only, + and may be removed in the near future. } The resulting plan object contains an ordered list of @emph{actions}. An action is a pair of an @code{operation} and a @code{component}, @@ -1862,7 +2035,8 @@ The ordering of the plan ensures that no action is performed before all its dependencies have been fulfilled.@footnote{ The term @emph{action} was used by Kent Pitman in his article, ``The Description of Large Systems,'' - (@pxref{Bibliography}). + (@pxref{Bibliography}), + and we suspect might be traced to @code{make}. Although the term was only used by ASDF hackers starting with ASDF 2, the concept was there since the very beginning of ASDF 1, just not clearly articulated. @@ -1878,7 +2052,7 @@ We will describe the built-in component and operation classes, and explain how to extend the ASDF protocol by defining new classes and methods for ASDF's generic functions. We will also describe the many @emph{hooks} that can be configured to -customize the behavior of existing @emph{functions}. +customize the behaviour of existing @emph{functions}. @c FIXME: Swap operations and components. @c FIXME: Possibly add a description of the PLAN object. @@ -1968,13 +2142,16 @@ are forced not to be recompiled even if modified since last compilation If @var{force-not} is a list, then it specifies a list of systems that are forced not to be recompiled even if modified since last compilation. +@findex register-immutable-system +@cindex immutable systems Both @var{force} and @var{force-not} apply to systems that are dependencies and were already compiled. @var{force-not} takes precedences over @var{force}, as it should, really, but unhappily only since ASDF 3.1.2. -Moreover, systems the name of which is member of the set @var{*immutable-systems*} -(represented as an equal hash-table) are always considered @var{forced-not}, and -even their @file{.asd} is not refreshed from the filesystem. +Moreover, systems which have been registered as immutable by @code{register-immutable-system} (since ASDF 3.1.5) +are always considered @var{forced-not}, and even their @file{.asd} are not refreshed from the filesystem. +@xref{Miscellaneous Functions}. +@findex traverse To see what @code{operate} would do, you can use: @example (asdf:traverse operation-class system-name) @@ -2051,7 +2228,7 @@ This operation will perform some tests on the module. The default method will do nothing. The default dependency is to require @code{load-op} to be performed on the module first. -Its @code{operation-done-p} method returns @code{nil}, +Its default @code{operation-done-p} method returns @code{nil}, which means that the operation is @emph{never} done -- we assume that if you invoke the @code{test-op}, @@ -2072,22 +2249,22 @@ People typically define a separate test @emph{system} to hold the tests. Doing this avoids unnecessarily adding a test framework as a dependency on a library. For example, one might have @lisp -(defsystem foo +(defsystem "foo" :in-order-to ((test-op (test-op "foo/test"))) ...) -(defsystem foo/test - :depends-on (foo fiveam) ; fiveam is a test framework library +(defsystem "foo/test" + :depends-on ("foo" "fiveam") ; fiveam is a test framework library ...) @end lisp Then one defines @code{perform} methods on @code{test-op} such as the following: @lisp -(defsystem foo/test - :depends-on (foo fiveam) ; fiveam is a test framework library +(defsystem "foo/test" + :depends-on ("foo" "fiveam") ; fiveam is a test framework library :perform (test-op (o s) - (uiop:symbol-call :fiveam '#:run! + (uiop:symbol-call :fiveam '#:run! (uiop:find-symbol* '#:foo-test-suite :foo-tests))) ...) @@ -2184,7 +2361,7 @@ The pathname of the output of bundle operations is subject to output-translation as usual, unless the operation is equal to the @code{:build-operation} argument to @code{defsystem}. -This behavior is not very satisfactory and may change in the future. +This behaviour is not very satisfactory and may change in the future. Maybe you have suggestions on how to better configure it? @end deffn @@ -2309,9 +2486,17 @@ An operation @emph{may} provide methods for the following generic functions: @findex input-files A method for this function is often not needed, since ASDF has a pretty clever default @code{input-files} mechanism. -You only need create a method if there are multiple ultimate input files, -and/or the bottom one doesn't depend -on the @code{component-pathname} of the component. +You only need create a method if there are multiple ultimate input +files. +Most operations inherit from @code{selfward-operation}, which +appropriately sets the input-files to include the source file itself. + +@c FIXME: Add documentation of built-in operation types. + +@defun input-files operation component +Return a list of pathnames that represent the input to @var{operation} +performed on @var{component}. +@end defun @item @code{operation-done-p} @findex operation-done-p @@ -2521,7 +2706,7 @@ then @var{locate-system} will return the following values: @var{pathname} will be @code{#p"/current/path/to/foo.asd"}, @item @var{previous} will be an object of type @code{SYSTEM} with -@code{system-source-file} slot value of +@code{system-source-file} slot value of @code{#p"/previous/path/to/foo.asd"} @item @var{previous-time} will be the timestamp of @@ -2745,6 +2930,29 @@ does additional processing to set the filesystem location of the top component in that system. This is detailed elsewhere. @xref{Defining systems with defsystem}. +To find the CL pathname corresponding to a component, use + +@defun component-pathname component +Returns the pathname corresponding to @var{component}. For components +such as source files, this will be a filename pathname. For example: + +@lisp +CL-USER> (asdf:component-pathname (asdf:find-system "xmls")) +#P"/Users/rpg/lisp/xmls/" +@end lisp + +and + +@lisp +CL-USER> (asdf:component-pathname + (asdf:find-component + (asdf:find-system "xmls") "xmls")) +#P"/Users/rpg/lisp/xmls/xmls.lisp" +@end lisp +@end defun + + + @subsubsection properties @@ -3108,13 +3316,16 @@ Mentions of XDG variables refer to that document. This specification allows the user to specify some environment variables to customize how applications behave to his preferences. -On Windows platforms, when not using Cygwin, -instead of the XDG base directory specification, -we try to use folder configuration from the registry regarding -@code{Common AppData} and similar directories. +On Windows platforms, even when not using Cygwin, and starting with ASDF 3.1.5, +we still do a best effort at following the XDG base directory specification, +even though it doesn't exactly fit common practice for Windows applications. +However, we replace the fixed Unix paths @file{~/.local}, @file{/usr/local} and @file{/usr} +with their rough Windows equivalent @file{Local AppData}, @file{AppData}, @file{Common AppData}, etc. Since support for querying the Windows registry is not possible to do in reasonable amounts of portable Common Lisp code, -ASDF 3 relies on the environment variables that Windows usually exports. +ASDF 3 relies on the environment variables that Windows usually exports, +and are hopefully in synch with the Windows registry. +If you care about the details, see @file{uiop/configuration.lisp} and don't hesitate to suggest improvements. @node Backward Compatibility, Configuration DSL, XDG base directory, Controlling where ASDF searches for systems @section Backward Compatibility @@ -3422,7 +3633,7 @@ from the file specified. An inherit-configuration statement cause the search to recurse with the path specifications from the next configuration -(@pxref{Controlling where ASDF searches for systems,,Configurations} above). +(@pxref{Configurations} above). @node Caching Results, Configuration API, Search Algorithm, Controlling where ASDF searches for systems @@ -3619,7 +3830,7 @@ for the sake of keeping ASDF no more complex than strictly necessary. or @code{(:add-directory X :recurse t)} for @code{(:tree X)}. @item - The possibility to register individual files instead of directories. + The possibility to register individual files instead of directories. @item Integrate Xach Beane's tilde expander into the parser, @@ -3630,7 +3841,7 @@ for the sake of keeping ASDF no more complex than strictly necessary. Hopefully, these are already superseded by the @code{:default-registry} @item - Using the shell-unfriendly syntax @code{/**} instead of @code{//} to specify recursion + Using the shell-unfriendly syntax @code{/**} instead of TEXINPUTS-like @code{//} to specify recursion down a filesystem tree in the environment variable. It isn't that Lisp friendly either. @end itemize @@ -3675,6 +3886,8 @@ while changing formats from version to version (or platform to platform). This can lead to many errors and much confusion as you switch from one implementation to the next. +Finally, this requires write access to the source directory, +and therefore precludes sharing of a same source code directory between multiple users. Since ASDF 2, ASDF includes the @code{asdf-output-translations} facility to mitigate the problem. @@ -3804,7 +4017,7 @@ we provide a limited emulation mode: @defun enable-asdf-binary-locations-compatibility @Akey{} centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings This function will initialize the new @code{asdf-output-translations} facility in a way -that emulates the behavior of the old @code{ASDF-Binary-Locations} facility. +that emulates the behaviour of the old @code{ASDF-Binary-Locations} facility. Where you would previously set global variables @var{*centralize-lisp-binaries*}, @var{*default-toplevel-directory*}, @@ -4176,11 +4389,11 @@ These are signalled using generalised instances of @section Compilation error and warning handling @vindex *compile-file-warnings-behaviour* -@vindex *compile-file-errors-behavior* +@vindex *compile-file-failure-behaviour* ASDF checks for warnings and errors when a file is compiled. The variables @var{*compile-file-warnings-behaviour*} and -@var{*compile-file-errors-behavior*} +@var{*compile-file-failure-behaviour*} control the handling of any such events. The valid values for these variables are @code{:error}, @code{:warn}, and @code{:ignore}. @@ -4195,6 +4408,7 @@ useful for system definition and development. @menu * Controlling file compilation:: * Controlling source file character encoding:: +* Miscellaneous Functions:: * Some Utility Functions:: @end menu @@ -4276,7 +4490,7 @@ though it may at times require some creativity (see e.g. the @code{package-renaming} system). -@node Controlling source file character encoding, Some Utility Functions, Controlling file compilation, Miscellaneous additional functionality +@node Controlling source file character encoding, Miscellaneous Functions, Controlling file compilation, Miscellaneous additional functionality @section Controlling source file character encoding Starting with ASDF 2.21, components accept a @code{:encoding} option @@ -4310,7 +4524,7 @@ and translates the former to the implementation-dependent @var{*utf-8-external-f and the latter to itself (that itself is portable but has an implementation-dependent meaning). In other words, there now are plenty of extension hooks, but -by default ASDF enforces the previous @emph{de facto} standard behavior +by default ASDF enforces the previous @emph{de facto} standard behaviour of using @code{:utf-8}, independently from whatever configuration the user may be using. Thus, system authors can now rely on @code{:utf-8} @@ -4330,9 +4544,9 @@ on implementations that support Unicode, and you can use reader-conditionalizati to protect any @code{:encoding @emph{encoding}} statement, as in @code{#+asdf-unicode :encoding #+asdf-unicode :utf-8}. We recommend that you avoid using unprotected @code{:encoding} specifications -until after ASDF 2.21 or later becomes widespread -(in April 2014, only LispWorks lags with ASDF 2.019, -and is scheduled to be updated later this year). +until after ASDF 2.21 or later becomes widespread. +As of May 2015, all maintained implementations provide ASDF 3, +so you may prudently start using this and other features without such protection. While it offers plenty of hooks for extension, and one such extension is available (see @code{asdf-encodings} below), @@ -4360,7 +4574,7 @@ even without any explicit specification in your @file{.asd} files. Indeed, on some implementations and configurations, UTF-8 is already the @code{:default}, and loading your code may cause errors if it is encoded in anything but UTF-8. -Therefore, even with the legacy behavior, +Therefore, even with the legacy behaviour, non-UTF-8 is guaranteed to break for some users, whereas UTF-8 is pretty much guaranteed not to break anywhere (provided you do @emph{not} use a BOM), @@ -4369,7 +4583,7 @@ although it might be read incorrectly on some implementations. If you need non-standard character encodings for your source code, use the extension system @code{asdf-encodings}, by specifying -@code{:defsystem-depends-on (:asdf-encodings)} in your @code{defsystem}. +@code{:defsystem-depends-on ("asdf-encodings")} in your @code{defsystem}. This extension system will register support for more encodings using the @code{*encoding-external-format-hook*} facility, so you can explicitly specify @code{:encoding :latin1} @@ -4386,11 +4600,11 @@ which is the most portable (next to it is @code{:latin1}). Recent versions of Quicklisp include @code{asdf-encodings}; if you're not using it, you may get this extension using git: -@kbd{git clone git://common-lisp.net/projects/asdf/asdf-encodings.git} +@kbd{git clone https://gitlab.common-lisp.net/asdf/asdf-encodings.git} or -@kbd{git clone ssh://common-lisp.net/project/asdf/git/asdf-encodings.git}. +@kbd{git clone git@@gitlab.common-lisp.net:asdf/asdf-encodings.git}. You can also browse the repository on -@url{http://common-lisp.net/gitweb?p=projects/asdf/asdf-encodings.git}. +@url{https://gitlab.common-lisp.net/asdf/asdf-encodings}. When you use @code{asdf-encodings}, any @file{.asd} file loaded @@ -4410,6 +4624,7 @@ Otherwise, the main data in these files is component (path)names, and we don't recommend using non-ASCII characters for these, for the result probably isn't very portable. +@node Miscellaneous Functions, Some Utility Functions, Controlling source file character encoding, Miscellaneous additional functionality @section Miscellaneous Functions These functions are exported by ASDF for your convenience. @@ -4492,11 +4707,32 @@ and want to register systems so that dependencies will work uniformly whether you're using your software from source or from fasl. @end defun +@defun register-immutable-system name @Arest{} keys +A system with name @var{name}, +created by @code{make-instance} with extra keys @var{keys} +(e.g. @code{:version}), +is registered as @emph{immutable}. +That is, its code has already been loaded into the current image, +and if at some point some other system @code{:depends-on} it, +it is considered as already provided, and +no attempt will be made to search for an updated version from the source-registry +or any other method. +There will be no search for an @file{.asd} file, and no @code{missing-component} error. + +This function (available since ASDF 3.1.5) is particularly useful if +you distribute a large body of code as a precompiled image, +and want to allow users to extend the image with further extension systems, +but without making thousands of filesystem requests looking for inexistent (or worse, out of date) source code +for all the systems that came bundled with the image but aren't +distributed as source code to regular users. +@cindex immutable systems +@end defun + @defun run-shell-command control-string @Arest{} args This function is obsolete and present only for the sake of backwards-compatibility: ``If it's not backwards, it's not compatible''. We @emph{strongly} discourage its use. -Its current behavior is only well-defined on Unix platforms +Its current behaviour is only well-defined on Unix platforms (which include MacOS X and cygwin). On Windows, anything goes. The following documentation is only for the purpose of your migrating away from it in a way that preserves semantics. @@ -4513,7 +4749,7 @@ while others (like SBCL) will make an attempt at invoking a POSIX shell (and fail if it is not present). @end defun -@node Some Utility Functions, , Controlling source file character encoding, Miscellaneous additional functionality +@node Some Utility Functions, , Miscellaneous Functions, Miscellaneous additional functionality @section Some Utility Functions The below functions are not exported by ASDF itself, but by UIOP, available since ASDF 3. @@ -4609,14 +4845,14 @@ or a string to be executed by a shell. It spawns the command, waits for it to return, verifies that it exited cleanly (unless told not too below), and optionally captures and processes its output. -It accepts many keyword arguments to configure its behavior. +It accepts many keyword arguments to configure its behaviour. @code{run-program} returns three values: the first for the output, the second for the error-output, and the third for the return value. (Beware that before ASDF 3.0.2.11, it didn't handle input or error-output, and returned only one value, the one for the output if any handler was specified, or else the exit code; -please upgrade ASDF, or at least UIOP, to rely on the new enhanced behavior.) +please upgrade ASDF, or at least UIOP, to rely on the new enhanced behaviour.) @var{output} is its most important argument; it specifies how the output is captured and processed. @@ -4735,6 +4971,7 @@ We recommend you control the syntax with such macro as @comment node-name, next, previous, up @chapter Getting the latest version + Decide which version you want. The @code{master} branch is where development happens; its @code{HEAD} is usually OK, including the latest fixes and portability tweaks, @@ -4745,17 +4982,14 @@ it has usually been tested more, and releases are cut at a point where there isn't any known unresolved issue. You may get the ASDF source repository using git: -@kbd{git clone git://common-lisp.net/projects/asdf/asdf.git} +@kbd{git clone https://gitlab.common-lisp.net/asdf/asdf.git} You will find the above referenced tags in this repository. You can also browse the repository on -@url{http://common-lisp.net/gitweb?p=projects/asdf/asdf.git}. +@url{https://gitlab.common-lisp.net/asdf/asdf}. Discussion of ASDF development is conducted on the -mailing list -@kbd{asdf-devel@@common-lisp.net}. -@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} - +mailing list (@pxref{Mailing list}). @node FAQ, Ongoing Work, Getting the latest version, Top @comment node-name, next, previous, up @@ -4763,6 +4997,7 @@ mailing list @menu * Where do I report a bug?:: +* Mailing list:: * What has changed between ASDF 1 ASDF 2 and ASDF 3?:: * Issues with installing the proper version of ASDF:: * Issues with configuring ASDF:: @@ -4770,38 +5005,54 @@ mailing list * ASDF development FAQs:: @end menu -@node Where do I report a bug?, What has changed between ASDF 1 ASDF 2 and ASDF 3?, FAQ, FAQ +@node Where do I report a bug?, Mailing list, FAQ, FAQ @section ``Where do I report a bug?'' - +@cindex bug tracker +@cindex launchpad ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}. If you're unsure about whether something is a bug, or for general discussion, -use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} +use the asdf-devel mailing list (@pxref{Mailing list}). + +@node Mailing list, What has changed between ASDF 1 ASDF 2 and ASDF 3?, Where do I report a bug?, FAQ +@section Mailing list +@cindex mailing list + +Discussion of ASDF development is conducted on the +mailing list +@kbd{asdf-devel@@common-lisp.net}. +@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} -@node What has changed between ASDF 1 ASDF 2 and ASDF 3?, Issues with installing the proper version of ASDF, Where do I report a bug?, FAQ +@node What has changed between ASDF 1 ASDF 2 and ASDF 3?, Issues with installing the proper version of ASDF, Mailing list, FAQ @section ``What has changed between ASDF 1, ASDF 2, and ASDF 3?'' We released ASDF 2.000 on May 31st 2010, -and ASDF 3.0.0 on May 15th 2013. -Releases of ASDF 2 and later have since then been included +ASDF 3.0.0 on May 15th 2013, +ASDF 3.1.2 on May 6th 2014. +Releases of ASDF 2 and now ASDF 3 have since then been included in all actively maintained CL implementations that used to bundle ASDF 1, -plus some implementations that previously did not. +plus many implementations that previously did not. ASDF has been made to work with all actively maintained CL implementations and even a few implementations that are @emph{not} actively maintained. -@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. + Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 or ASDF 3 on the fly -(though we recommend instead upgrading your implementation or its ASDF module). +(though we recommend instead upgrading your implementation or replacing its ASDF module). For this reason, we have stopped supporting ASDF 1 and ASDF 2. If you are using ASDF 1 or ASDF 2 and are experiencing any kind of issues or limitations, we recommend you upgrade to ASDF 3 --- and we explain how to do that. @xref{Loading ASDF}. -(In the context of compatibility requirements, -ASDF 2.27, released on Feb 1st 2013, and further 2.x releases up to 2.33, -count as pre-releases of ASDF 3, and define the @code{:asdf3} feature; -still, please use the latest release). -Release ASDF 3.1.2 and later also define the @code{:asdf3.1} feature. + +Note that in the context of compatibility requirements, +ASDF 2.27, released on Feb 1st 2013, and further releases up to 2.33, +count as pre-releases of ASDF 3, and define the @code{:asdf3} feature, +though the first stable release of ASDF 3 was release 3.0.1. +Significant new or improved functionality were added in ASDF 3.1; +the @code{:asdf3.1} feature is present in recent enough versions to detect this functionality; +the first stable release since then was ASDF 3.1.2. +New @code{*features*} are only added at major milestones, +and the next one will probably be @code{:asdf3.2}. @menu @@ -4816,6 +5067,7 @@ Release ASDF 3.1.2 and later also define the @code{:asdf3.1} feature. * ASDF can be upgraded:: * Decoupled release cycle:: * Pitfalls of the transition to ASDF 2:: +* Pitfalls of the upgrade to ASDF 3:: * What happened to the bundle operations:: @end menu @@ -4827,12 +5079,15 @@ and to any development revision earlier than 2.000 (May 2010). If your copy of ASDF doesn't even contain version information, it's an old ASDF 1. Revisions between 1.656 and 1.728 may count as development releases for ASDF 2. -ASDF 2 refers to releases from 2.000 (May 31st 2010) to 2.26 (Oct 30 2012), -and any development revision newer than ASDF 1 and older than 2.27 (Feb 1 2013). +ASDF 2 refers to releases from 2.000 (May 31st 2010) to 2.26 (Oct 30th 2012), +and any development revision newer than ASDF 1 and older than 2.27 (Feb 1st 2013). -ASDF 3 refers to releases from 2.27 (Feb 1 2013) to 2.33 and 3.0.0 onward (May 15 2013). +ASDF 3 refers to releases from 2.27 (Feb 1st 2013) to 2.33 and 3.0.0 onward (May 15th 2013). 2.27 to 2.33 count as pre-releases to ASDF 3. +ASDF 3.1 refers to releases from 3.1.2 (May 6th 2014) onward. +These releases are also considered part of ASDF 3. + @node How do I detect the ASDF version?, ASDF can portably name files in subdirectories, What are ASDF 1 2 3?, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection How do I detect the ASDF version? @findex asdf-version @@ -4846,7 +5101,7 @@ Releases starting with ASDF 3 (including 2.27 and later pre-releases) push @code{:asdf3} onto @code{*features*}. Furthermore, releases starting with ASDF 3.1.2 (May 2014), though they count as ASDF 3, include enough progress that they -push @code{:asdf3.1} onto @code{*features*}. +also push @code{:asdf3.1} onto @code{*features*}. You may depend on the presence or absence of these features to write code that takes advantage of recent ASDF functionality but still works on older versions, or at least detects the old version and signals an error. @@ -4859,6 +5114,32 @@ on the second line of the @file{asdf.lisp} source file. If you are experiencing problems or limitations of any sort with ASDF 1 or ASDF 2, we recommend that you should upgrade to the latest release, be it ASDF 3 or other. +Finally, here is a code snippet to programmatically determine what version of ASDF is loaded, if any, +that works on all versions including very old ones: + +@lisp +(when (find-package :asdf) + (let ((ver (symbol-value + (or (find-symbol (string :*asdf-version*) :asdf) + (find-symbol (string :*asdf-revision*) :asdf))))) + (etypecase ver + (string ver) + (cons (with-output-to-string (s) + (loop for (n . m) on ver + do (princ n s) + (when m (princ "." s))))) + (null "1.0")))) +@end lisp + +If it returns @code{nil} then ASDF is not installed. +Otherwise it should return a string. +If it returns @code{"1.0"}, then it can actually be +any version before 1.77 or so, or some buggy variant of 1.x. +If it returns anything older than @code{"3.0.1"}, +you really need to upgrade your implementation or at least upgrade its ASDF. +@xref{Replacing your implementation's ASDF}. + + @node ASDF can portably name files in subdirectories, Output translations, How do I detect the ASDF version?, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection ASDF can portably name files in subdirectories @@ -5071,7 +5352,7 @@ the practical consequence of which will mean faster convergence towards the latest version for everyone. -@node Pitfalls of the transition to ASDF 2, What happened to the bundle operations, Decoupled release cycle, What has changed between ASDF 1 ASDF 2 and ASDF 3? +@node Pitfalls of the transition to ASDF 2, Pitfalls of the upgrade to ASDF 3, Decoupled release cycle, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection Pitfalls of the transition to ASDF 2 The main pitfalls in upgrading to ASDF 2 seem to be related @@ -5160,13 +5441,118 @@ and instead you will @code{(defclass cl-source-file.lis (cl-source-file) ((type and use @code{:default-component-class cl-source-file.lis} as argument to @code{defsystem}, as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below. +@code{source-file-type} is deprecated. To access a component's +file-type, use @code{file-type}, instead. @code{source-file-type} will +be removed. @findex source-file-type - +@findex file-type @end itemize -@node What happened to the bundle operations, , Pitfalls of the transition to ASDF 2, What has changed between ASDF 1 ASDF 2 and ASDF 3? + +@node Pitfalls of the upgrade to ASDF 3, What happened to the bundle operations, Pitfalls of the transition to ASDF 2, What has changed between ASDF 1 ASDF 2 and ASDF 3? +@subsection Pitfalls of the upgrade to ASDF 3 + +While ASDF 3 is largely compatible with ASDF 2, +there are a few pitfalls when upgrading from ASDF 2, +due to limitations in ASDF 2. + +@itemize + +@item +ASDF 2 was designed so it could be upgraded; +but upgrading it required a special setup at the beginning of your build files. +Failure to upgrade it early could result in catastrophic attempt to self-upgrade in mid-build. + +@item +Starting with ASDF 3 (2.27 or later), +ASDF will automatically attempt to upgrade itself +as the first step before any system operation, +to avoid any possibility of such catastrophic mid-build self-upgrade. +But that doesn't help if your old implementation still provides ASDF 2. + +@item +It was unsafe in ASDF 2 for a system definition to declare a dependency on ASDF, +since it could trigger such catastrophe for users who were not carefully configured. +If you declare a dependency on a recent enough ASDF, +yet want to be nice with these potentially misconfigured users, +we recommend that you not only specify a recent ASDF in your dependencies with +@code{:depends-on ((:version "asdf" "3.1.2"))}, +but that you @emph{also} check that ASDF 3 is installed, +or else the upgrade catastrophe might happen before that specification is checked, +by starting your @file{.asd} file with a version check as follows: +@example +#-asdf3 (error "@var{MY-SYSTEM} requires ASDF 3.1.2") +@end example + +@item +When you upgrade from too old a version of ASDF, +previously loaded ASDF extensions become invalid, and will need to be reloaded. +Example extensions include CFFI-Grovel, hacks used by ironclad, etc. +Since it isn't possible to automatically detect what extensions +need to be invalidated and what systems use them, +ASDF will invalidate @emph{all} previously loaded systems +when it is loaded on top of a forward-incompatible ASDF version. +@footnote{ +@vindex *oldest-forward-compatible-asdf-version* +Forward incompatibility can be determined using the variable +@code{asdf/upgrade::*oldest-forward-compatible-asdf-version*}, +which is 2.33 at the time of this writing.} + +@item +To write a portable build script, you need to rely on a recent version of UIOP, +but until you have ensured a recent ASDF is loaded, +you can't rely on UIOP being present, +and thus must manually avoid all the pathname pitfalls when loading ASDF itself. + +@item +Bugs in CMUCL and XCL prevent upgrade of ASDF from an old forward-incompatible version. +Happily, CMUCL comes with a recent ASDF, +and XCL is more of a working demo than something you'd use seriously anyway. + +@item +For the above reasons, your build and startup scripts +should load, configure and upgrade ASDF among the very first things they do, +and ensure that ASDF 3 or later is present indeed, +before they start using ASDF to load anything else. + +@item +Now that all implementations provide ASDF 3 or later (since May 2015), +the simple solution is just to use code as below in your setup, +and when it fails, upgrade your implementation or replace its ASDF. +(@pxref{Replacing your implementation's ASDF}): +@example +(require "asdf") +#-asdf3 (error "ASDF 3 or bust") +@end example + +@item +For scripts that try to use ASDF simply via @code{require} at first, and +make heroic attempts to load it the hard way if at first they don't succeed, +see @file{tools/load-asdf.lisp} distributed with the ASDF source repository, +or the code of @url{https://cliki.net/cl-launch,@code{cl-launch}}. + +@item +Note that in addition to the pitfalls and constraints above, +these heroic scripts (should you wish to write or modify one), +must take care to configure ASDF @emph{twice}. +A first time, right after you load the old ASDF 2 and before you upgrade to the new ASDF 3, +so it may find where you put ASDF 3. +A second time, because some implementations can't handle a smooth upgrade to ASDF 3, +and lose configuration as they do. +@lisp +(ignore-errors (funcall 'require "asdf")) ;; <--- try real hard +;; <--- insert heroics here, if that failed to provide ASDF 2 or 3 +;; <--- insert configuration here, if that succeeded +(asdf:load-system "asdf") +;; <--- re-configure here, too, in case at first you got ASDF 2 +@end lisp + +@end itemize + + +@node What happened to the bundle operations, , Pitfalls of the upgrade to ASDF 3, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection What happened to the bundle operations? @tindex fasl-op (obsolete) @@ -5182,6 +5568,14 @@ as detailed in a @pxref{FAQ,How do I create a system definition where all the so @tindex monolithic-load-bundle-op @tindex monolithic-deliver-asd-op +@code{asdf-ecl} and its short-lived successor @code{asdf-bundle} are no more, +having been replaced by code now built into ASDF 3. +Moreover, the name of the bundle operations has changed since ASDF 3.1.3. + +And yet, the feature is not enabled to be used by @code{load-system} by default on ECL as originally intended, +because of a bug in ECL itself found during testing. + + Some of the bundle operations were renamed after ASDF 3.1.3, and the old names have been removed. Old bundle operations, and their modern equivalents are: @@ -5214,13 +5608,15 @@ equivalents are: @node My Common Lisp implementation comes with an outdated version of ASDF. What to do?, I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, Issues with installing the proper version of ASDF, Issues with installing the proper version of ASDF @subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?'' -We recommend you upgrade ASDF. -@xref{Loading ASDF,,Upgrading ASDF}. +If you have a recent implementation, it should already come with ASDF 3 or later. +If you need a more recent version than is provided, +we recommend you simply upgrade ASDF by installing a recent version +in a path configured in your source-registry. +@xref{Upgrading ASDF}. -If this does not work, it is a bug, and you should report it. -@xref{FAQ, report-bugs, Where do I report a bug}. -In the meantime, you can load @file{asdf.lisp} directly. -@xref{Loading ASDF,Loading an otherwise installed ASDF}. +If you have an old implementation that does not provide ASDF 3, +we recommend you replace your implementation's ASDF. +@xref{Replacing your implementation's ASDF}. @node I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, , My Common Lisp implementation comes with an outdated version of ASDF. What to do?, Issues with installing the proper version of ASDF @@ -5249,7 +5645,7 @@ You may have it load some other version configured by the user, if you allow such configuration. @item -If your system provides a mechanism to hook into @code{CL:REQUIRE}, +If your system provides a mechanism to hook into @code{cl:require}, then it would be nice to add ASDF to this hook the same way that ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it. Please send us appropriate code to this end. @@ -5259,9 +5655,9 @@ You may, like SBCL since 1.1.13 or MKCL since 1.1.9, have ASDF create bundle FASLs that are provided as modules by your Lisp distribution. You may also, but we don't recommend that anymore, -have ASDF like SBCL up until 1.1.12 be implicitly used -when requiring modules that are provided by your Lisp distribution; -if you do, you should add them in the beginning of both +as in SBCL up until 1.1.12, have ASDF be implicitly used +to @code{cl:require} these modules that are provided by your Lisp distribution; +if you do, you should add these modules in the beginning of both @code{wrapping-source-registry} and @code{wrapping-output-translations}. @item @@ -5346,7 +5742,8 @@ for all future runs of ASDF, you can: @example mkdir -p ~/.config/common-lisp/asdf-output-translations.conf.d/ -echo ':disable-cache' > ~/.config/common-lisp/asdf-output-translations.conf.d/99-disable-cache.conf +echo ':disable-cache' > \ +~/.config/common-lisp/asdf-output-translations.conf.d/99-disable-cache.conf @end example This assumes that you didn't otherwise configure the ASDF files @@ -5385,6 +5782,7 @@ and only do this from your personal configuration or build scripts. * How do I create a system definition where all the source files have a .cl extension?:: * How do I mark a source file to be loaded only and not compiled?:: * How do I work with readtables?:: +* How can I capture ASDF's output?:: @end menu @node How can I cater for unit-testing in my system?, How can I cater for documentation generation in my system?, Issues with using and extending ASDF to define systems, Issues with using and extending ASDF to define systems @@ -5395,9 +5793,10 @@ ASDF provides a predefined test operation, @code{test-op}. The test operation, however, is largely left to the system definer to specify. @code{test-op} has been a topic of considerable discussion on the -@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}, +@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} +(@pxref{Mailing list}), and on the -@url{https://launchpad.net/asdf,launchpad bug-tracker}. +@url{https://launchpad.net/asdf,launchpad bug-tracker} (@pxref{Where do I report a bug?}). We provide some guidelines in the discussion of @code{test-op}. @c cut the following because it's discussed in the discussion of test-op. @@ -5466,19 +5865,19 @@ in a subdirectory with the same name as the module. However, this can be overridden by adding a @code{:pathname ""} argument to the module description. For example, here is how it could be done -in the spatial-trees ASDF system definition for ASDF 2: +in the spatial-trees ASDF system definition for ASDF 2 or later: @example -(asdf:defsystem :spatial-trees +(asdf:defsystem "spatial-trees" :components - ((:module base + ((:module "base" :pathname "" :components ((:file "package") (:file "basedefs" :depends-on ("package")) (:file "rectangles" :depends-on ("package")))) (:module tree-impls - :depends-on (base) + :depends-on ("base") :pathname "" :components ((:file "r-trees") @@ -5487,12 +5886,12 @@ in the spatial-trees ASDF system definition for ASDF 2: (:file "rplus-trees" :depends-on ("r-trees")) (:file "x-trees" :depends-on ("r-trees" "rstar-trees")))) (:module viz - :depends-on (base) + :depends-on ("base") :pathname "" :components ((:static-file "spatial-tree-viz.lisp"))) (:module tests - :depends-on (base) + :depends-on ("base") :pathname "" :components ((:static-file "spatial-tree-test.lisp"))) @@ -5576,20 +5975,6 @@ you might skip package complications: ...) @end lisp -It is possible to achieve the same effect -in a way that supports both ASDF 1 and ASDF 2, -but really, friends don't let friends use ASDF 1. -Please upgrade to ASDF 3. -In short, though: do same as above, but -@emph{before} you use the class in a @code{defsystem}, -you also define the following method: - -@lisp -(defmethod source-file-type ((f cl-source-file.lis) (s system)) - (declare (ignorable f s)) - "lis") -@end lisp - @node How do I mark a source file to be loaded only and not compiled?, How do I work with readtables?, How do I create a system definition where all the source files have a .cl extension?, Issues with using and extending ASDF to define systems @subsection How do I mark a source file to be loaded only and not compiled? @@ -5609,7 +5994,7 @@ to allow for such a trick. @c to adjust your compiler settings, @c or eschew compilation by @code{eval}uating a quoted source form at load-time. -@node How do I work with readtables?, , How do I mark a source file to be loaded only and not compiled?, Issues with using and extending ASDF to define systems +@node How do I work with readtables?, How can I capture ASDF's output?, How do I mark a source file to be loaded only and not compiled?, Issues with using and extending ASDF to define systems @subsection How do I work with readtables? @cindex readtables @@ -5677,15 +6062,28 @@ to eschew using such an important library anymore. Use from the @code{named-readtables} system the macro @code{named-readtables:defreadtable}. +@node How can I capture ASDF's output?, , How do I work with readtables?, Issues with using and extending ASDF to define systems +@subsection How can I capture ASDF's output? + +@cindex ASDF output +@cindex Capturing ASDF output +@vindex *standard-output* + +Output from ASDF and ASDF extensions are sent to the CL stream +@code{*standard-output*}, so rebinding that stream around calls to +@code{asdf:operate} should redirect all output from ASDF operations. + + + @node ASDF development FAQs, , Issues with using and extending ASDF to define systems, FAQ @section ASDF development FAQs @menu -* How do run the tests interactively in a REPL?:: +* How do I run the tests interactively in a REPL?:: @end menu -@node How do run the tests interactively in a REPL?, , ASDF development FAQs, ASDF development FAQs -@subsection How do run the tests interactively in a REPL? +@node How do I run the tests interactively in a REPL?, , ASDF development FAQs, ASDF development FAQs +@subsection How do I run the tests interactively in a REPL? This not-so-frequently asked question is primarily for ASDF developers, but those who encounter an unexpected error in some test may be @@ -5733,7 +6131,7 @@ Here's the procedure for experimenting with tests in a REPL: For an active list of things to be done, see the @file{TODO} file in the source repository. -Also, bugs are now tracked on launchpad: +Also, bugs are currently tracked on launchpad: @url{https://launchpad.net/asdf}. @node Bibliography, Concept Index, Ongoing Work, Top @@ -5744,7 +6142,7 @@ Also, bugs are now tracked on launchpad: ``ASDF 3, or Why Lisp is Now an Acceptable Scripting Language'', 2014. This article describes the innovations in ASDF 3 and 3.1, as well as historical information on previous versions. - @url{http://github.com/fare/asdf3-2013} + @url{https://github.com/fare/asdf3-2013} @item Alastair Bridgewater: ``Quick-build'' (private communication), 2012. @code{quick-build} is a simple and robust one file, one package build system, @@ -5761,19 +6159,19 @@ Also, bugs are now tracked on launchpad: @item Francois-Rene Rideau and Robert Goldman: ``Evolving ASDF: More Cooperation, Less Coordination'', 2010. This article describes the main issues solved by ASDF 2. - @url{http://common-lisp.net/project/asdf/doc/ilc2010draft.pdf} - @url{http://www.common-lisp.org/gitweb?p=projects/asdf/ilc2010.git} + @url{https://common-lisp.net/project/asdf/doc/ilc2010draft.pdf} + @url{https://gitlab.common-lisp.org/asdf/ilc2010} @item Francois-Rene Rideau and Spencer Brody: ``XCVB: an eXtensible Component Verifier and Builder for Common Lisp'', 2009. - This article describes XCVB, a proposed competitor for ASDF, - many ideas of which have been incorporated into ASDF 2 and 3, - though many other of which still haven't. - @url{http://common-lisp.net/projects/xcvb/} + This article describes XCVB, a proposed competitor for ASDF; + many of its ideas have been incorporated into ASDF 2 and 3, + though many other ideas still haven't. + @url{https://common-lisp.net/project/xcvb/} @item Peter von Etter: ``faslpath'', 2009. @code{faslpath} is similar to the latter @code{quick-build} - and our letter @code{asdf/package-system} extension, - except that it uses the dot @code{.} rather than the slash @code{/} as a separator. + and our yet latter @code{asdf/package-system} extension, + except that it uses dot @code{.} rather than slash @code{/} as a separator. @url{https://code.google.com/p/faslpath/} @item Drew McDermott: ``A Framework for Maintaining the Coherence of a Running Lisp,'' From 3ff0b11f7b08522bd7676824fd1a34bd8a17257b Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Wed, 7 Sep 2016 11:18:56 -0400 Subject: [PATCH 89/92] msvc 2015 - client will break if integer types are redefined on this compiler. --- msvc/ecl/config.h.msvc6 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/msvc/ecl/config.h.msvc6 b/msvc/ecl/config.h.msvc6 index 162f81832..83833b050 100755 --- a/msvc/ecl/config.h.msvc6 +++ b/msvc/ecl/config.h.msvc6 @@ -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 +#endif /* We can use small, two-words conses, without type information */ /* #undef ECL_SMALL_CONS */ From 1c452a9f1d18c85a625dfd2fa9bb353309481429 Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Thu, 8 Sep 2016 12:45:30 -0400 Subject: [PATCH 90/92] MSVC - avoid name clash on export libraries for program link. fix #287 --- src/cmp/cmpmain.lsp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 2a1568fbf..fb56d8656 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -132,7 +132,9 @@ the environment variable TMPDIR to a different value." template)) ,@object-files ,@(split-program-options *ld-rpath*) ,@(split-program-options *user-ld-flags*) - ,@ld-flags)) + ,@ld-flags + ,(if (eq type :program) + (concatenate 'string "/IMPLIB:prog" (file-namestring o-pathname) ".lib") "" ))) (embed-manifest-file o-pathname type) (delete-msvc-generated-files o-pathname)) From 11e35ea5b939848ce58920d1d8eead6f79b60215 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 16 Sep 2016 11:03:44 +0200 Subject: [PATCH 91/92] windows: gc: remove spurious define Older bdwgc didn't export that symbol, so ECL patched that definition for its own threaded needs. bdwgc has improved since then and our own definition breaks CC builds. Fixes #288. See https://gitlab.com/embeddable-common-lisp/ecl/issues/288 --- src/c/threads/process.d | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/c/threads/process.d b/src/c/threads/process.d index 19e98e340..944bd1607 100755 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -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 -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 From 2208de9f8d674476ea5b22df4d62d3910b67d161 Mon Sep 17 00:00:00 2001 From: MatthewRock Date: Sat, 17 Sep 2016 22:21:46 +0200 Subject: [PATCH 92/92] Deprecate one-dash longflags --- src/doc/ecl.man.in | 45 ++++++++++++++++++++++++++---------------- src/lsp/cmdline.lsp | 48 ++++++++++++++++++++++++++++++++++++++------- 2 files changed, 69 insertions(+), 24 deletions(-) diff --git a/src/doc/ecl.man.in b/src/doc/ecl.man.in index a2c257c8e..e13ef0053 100644 --- a/src/doc/ecl.man.in +++ b/src/doc/ecl.man.in @@ -1,4 +1,4 @@ -.TH ECL 1 2016-06-18 +.TH ECL 1 2016-09-17 .UC 4 .SH NAME ecl \- Embeddable Common Lisp @@ -7,23 +7,28 @@ ecl \- Embeddable Common Lisp \fBecl\fP [\fB-?\fP | \fB--help\fP] .br -[\fB-dir\fP \fIdir\fP] [\fB-load\fP \fIfile\fP] [\fB-shell\fP \fIfile\fP] [\fB-eval\fP \fIexpr\fP] +[\fB--dir\fP \fIdir\fP] [\fB--load\fP \fIfile\fP] [\fB--shell\fP \fIfile\fP] [\fB--eval\fP \fIexpr\fP] .br -[\fB-norc\fP] +[\fB--norc\fP] [\fB--hp\fP | \fB--nohp\fP] +.br +[\fB--debug\fP | \fB--nodevbug\fP] .br [\fB--c-stack\fP \fIsize\fP] [\fB--lisp-stack\fP \fIsize\fP] .br [\fB--heap-size\fP \fIsize\fP] [\fB--frame-stack\fP \fIsize\fP] .br -[[\fB-o\fP \fIofile\fP] [\fB-c\fP [\fIcfile\fP]] [\fB-h\fP [\fIhfile\fP]] [\fB-data\fP [\fIdatafile\fP]] +[[\fB-o\fP \fIofile\fP] [\fB-c\fP [\fIcfile\fP]] [\fB-h\fP [\fIhfile\fP]] [\fB--data\fP [\fIdatafile\fP]] .br - [\fB-s\fP] [\fB-q\fP] \fB-compile\fP \fIfile\fP] + [\fB-s\fP] [\fB-q\fP] \fB--compile\fP \fIfile\fP] .br -[[\fB-o\fP \fIofile\fP] \fB-link\fP \fIfile\fP+] +[[\fB-o\fP \fIofile\fP] \fB--link\fP \fIfile\fP+] .br [\fB--input-encoding\fP \fIexternal-format\fP] [\fB--output-encoding\fP \fIexternal-format\fP] .br [\fB--error-encoding\fP \fIexternal-format\fP] [\fB--encoding\fP \fIexternal-format\fP] +.br +\fBDEPRECATION NOTE:\fP one-dash versions of long flags(e.g. \fB-eval\fP or \fB-data\fP) are deprecated; you should use two-dash versions (e.g. \fB--eval\fP or \fB--data\fP) now. + .SH DESCRIPTION .sp @@ -55,7 +60,7 @@ A reasonable license .B \-?, \-\-help Shows the help prompt without running the ECL. .TP -.BI \-norc +.BI \-\-norc Do not load configuration files at startup. .TP .BI \-\-version @@ -65,29 +70,29 @@ Prints the current version of ECL, without running the ECL. Turned on by default, this enables the debugging in the setup phase, so that you can debug your files. .TP -.BI \-nodebug +.BI \-\-nodebug Run without debugging setup phase, meaning that errors prevent ECL from starting up. .TP -.BI \-eval " file" +.BI \-\-eval " file" Evaluate the .I file before loading the .rc file and starting the Top Level. .TP -.BI \-shell " file" +.BI \-\-shell " file" Executes the given .I file and exits, without providing a read-eval-print loop. If you want to use lisp as a scripting language, you can write -.BR "#!@bindir@/ecl -shell" +.BR "#!@bindir@/ecl --shell" on the first line of the file to be executed, and then ECL will be automatically invoked. .TP -.BI \-load " file" +.BI \-\-load " file" Load source .I file before loading the .rc file and starting the Top Level. .TP -.BI \-dir " directory" +.BI \-\-dir " directory" Use .I directory as a system directory. @@ -154,12 +159,12 @@ When compiling name the intermediary C file .I cfile and do not delete it afterwards. .TP -.BI \-data " [datafile]" +.BI \-\-data " [datafile]" Dumps compiler data into \fIdatafile\fP or, if not supplied, into a file named after the source file, but with .data as extension. .TP -.BI \-compile " file" +.BI \-\-compile " file" Translates .I file to C and invokes the local C compiler to produce a @@ -168,6 +173,12 @@ native code program. .BI \-q Short for quiet - produce less notes. .TP +.BI \-\-hp +This option is deprecated and doesn't do anything. +.TP +.BI \-\-nodp +This option is deprecated and doesn't do anything. +.TP .BI \-s Produce a linkable object file. It cannot be loaded with load, but it can be used to build libraries @@ -186,8 +197,8 @@ the ECL mailing list. .TP .BR "~/.ecl, ~/.eclrc" Default initialization files loaded at startup unless the option -.BR \-norc -is provided +.BR \-\-norc +is provided. (if they exist). .SH SEE ALSO diff --git a/src/lsp/cmdline.lsp b/src/lsp/cmdline.lsp index 0a9c5f42c..ae21725b2 100644 --- a/src/lsp/cmdline.lsp +++ b/src/lsp/cmdline.lsp @@ -23,11 +23,11 @@ (defparameter *help-message* " Usage: ecl [-? | --help] - [-dir dir] [-load file] [-shell file] [-eval expr] [-rc | -norc] [-hp | -nohp] + [--dir dir] [--load file] [--shell file] [--eval expr] [--rc | --norc] [--hp | --nohp] [--c-stack size] [--lisp-stack size] [--heap-size size] [--frame-stack size] - [[-o ofile] [-c [cfile]] [-h [hfile]] [-data [datafile]] [-s] [-q] - -compile file] - [[-o ofile] -link file+] + [[-o ofile] [-c [cfile]] [-h [hfile]] [--data [datafile]] [-s] [-q] + --compile file] + [[-o ofile] --link file+] [--input-encoding external-format] [--output-encoding external-format] [--error-encoding external-format] [--encoding external-format] [--trap-fpe | --no-trap-fpe] @@ -59,20 +59,31 @@ appeared after a '--'.") '(("--help" 0 #0=(progn (princ *help-message* *standard-output*) (quit)) :noloadrc) ("-?" 0 #0# :noloadrc) ("-norc" 0 nil :noloadrc) + ("--norc" 0 nil :noloadrc) ("--version" 0 (progn (setf quit 0) (format *standard-output* "ECL ~A~%" (lisp-implementation-version))) :noloadrc) ("-debug" 0 (setf *command-break-enable* t)) + ("--debug" 0 (setf *command-break-enable* t)) ("-nodebug" 0 (setf *command-break-enable* nil)) + ("--nodebug" 0 (setf *command-break-enable* nil)) ("-eval" 1 (eval (read-from-string 1))) + ("--eval" 1 (eval (read-from-string 1))) ("-shell" 1 (progn (setq quit 0) (setq ext:*unprocessed-ecl-command-args* (rest 1)) (load (first (rest 1)) :verbose nil)) :stop) + ("--shell" 1 (progn (setq quit 0) + (setq ext:*unprocessed-ecl-command-args* (rest 1)) + (load (first (rest 1)) :verbose nil)) + :stop) ("-load" 1 (load 1 :verbose verbose)) + ("--load" 1 (load 1 :verbose verbose)) ("-dir" 1 (setf (logical-pathname-translations "SYS") `(("**;*.*" ,(merge-pathnames "**/*.*" (truename 1)))))) + ("--dir" 1 (setf (logical-pathname-translations "SYS") + `(("**;*.*" ,(merge-pathnames "**/*.*" (truename 1)))))) ("--heap-size" 1 (ext:set-limit 'ext:heap-size (read-from-string 1))) ("--lisp-stack" 1 (ext:set-limit 'ext:lisp-stack (read-from-string 1))) ("--frame-stack" 1 (ext:set-limit 'ext:frame-stack (read-from-string 1))) @@ -92,9 +103,23 @@ appeared after a '--'.") (progn (setq quit (if (nth-value 3 - (compile-file 1 :output-file output-file :c-file c-file - :h-file h-file :data-file data-file - :verbose verbose :system-p system-p)) + (compile-file 1 :output-file output-file :c-file c-file + :h-file h-file :data-file data-file + :verbose verbose :system-p system-p)) + 1 + 0) + output-file t + c-file nil + h-file nil + data-file nil + system-p nil))) + ("--compile" 1 + (progn + (setq quit + (if (nth-value 3 + (compile-file 1 :output-file output-file :c-file c-file + :h-file h-file :data-file data-file + :verbose verbose :system-p system-p)) 1 0) output-file t @@ -108,13 +133,22 @@ appeared after a '--'.") (funcall (read-from-string "c::build-program") (or output-file "lisp.exe") :lisp-files '&rest) (setq output-file t quit t))) + ("--link" &rest + (progn + (require 'cmp) + (funcall (read-from-string "c::build-program") + (or output-file "lisp.exe") :lisp-files '&rest) + (setq output-file t quit t))) ("-o" &optional (setq output-file 1)) ("-c" &optional (setq c-file 1)) ("-h" &optional (setq h-file 1)) ("-data" 1 (setq data-file 1)) + ("--data" 1 (setq data-file 1)) ("-q" 0 (setq verbose nil)) ("-hp" 0 (setf *relative-package-names* t)) + ("--hp" 0 (setf *relative-package-names* t)) ("-nohp" 0 (setf *relative-package-names* nil)) + ("--nohp" 0 (setf *relative-package-names* nil)) ("-s" 0 (setq system-p t)) ("--" 1 (setf ext:*unprocessed-ecl-command-args* (rest 1)) :stop)))